diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2018-11-06 10:04:02 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2018-11-06 10:04:02 (GMT) |
| commit | 179e8f4df7568f6aca6e53525abfe0505fd2a578 (patch) | |
| tree | c9328ec8e0afd8af8a96b9f3da12b152cec7c281 /generic | |
| parent | c5a85dbfdc7dce9328b7f5fffb0bae519f68cf9f (diff) | |
| parent | 2798a075ee62ea5ab4aa80279d614a8634ba378a (diff) | |
| download | tcl-179e8f4df7568f6aca6e53525abfe0505fd2a578.zip tcl-179e8f4df7568f6aca6e53525abfe0505fd2a578.tar.gz tcl-179e8f4df7568f6aca6e53525abfe0505fd2a578.tar.bz2 | |
merge core-8-branch
Diffstat (limited to 'generic')
112 files changed, 22750 insertions, 12505 deletions
diff --git a/generic/regc_lex.c b/generic/regc_lex.c index affcb48..4c8f15f 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -457,7 +457,7 @@ next( if (ATEOS()) { FAILW(REG_EESCAPE); } - (DISCARD)lexescape(v); + (void)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; @@ -716,7 +716,7 @@ next( } RETV(PLAIN, *v->now++); } - (DISCARD)lexescape(v); + (void)lexescape(v); if (ISERR()) { FAILW(REG_EESCAPE); } @@ -1143,7 +1143,7 @@ skip( /* - newline - return the chr for a newline * This helps confine use of CHR to this source file. - ^ static chr newline(NOPARMS); + ^ static chr newline(void); */ static chr newline(void) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 8f67a52..002b264 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -137,8 +137,8 @@ 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, 0x52f}, {0x531, 0x556}, {0x561, 0x587}, - {0x5d0, 0x5ea}, {0x5f0, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, + {0x3f7, 0x481}, {0x48a, 0x52f}, {0x531, 0x556}, {0x560, 0x588}, + {0x5d0, 0x5ea}, {0x5ef, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, {0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea}, {0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86a}, {0x8a0, 0x8b4}, {0x8b6, 0x8bd}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980}, @@ -165,45 +165,42 @@ static const crange alphaRangeTable[] = { {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, 0x1884}, {0x1887, 0x18a8}, {0x18b0, 0x18f5}, + {0x1820, 0x1878}, {0x1880, 0x1884}, {0x1887, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191e}, {0x1950, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9}, {0x1a00, 0x1a16}, {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b}, {0x1b83, 0x1ba0}, {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, - {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d}, {0x1c80, 0x1c88}, {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, 0x312e}, {0x3131, 0x318e}, {0x31a0, 0x31ba}, {0x31f0, 0x31ff}, - {0x3400, 0x4db5}, {0x4e00, 0x9fea}, {0xa000, 0xa48c}, {0xa4d0, 0xa4fd}, - {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e}, {0xa67f, 0xa69d}, - {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788}, {0xa78b, 0xa7ae}, - {0xa7b0, 0xa7b7}, {0xa7f7, 0xa801}, {0xa803, 0xa805}, {0xa807, 0xa80a}, - {0xa80c, 0xa822}, {0xa840, 0xa873}, {0xa882, 0xa8b3}, {0xa8f2, 0xa8f7}, - {0xa90a, 0xa925}, {0xa930, 0xa946}, {0xa960, 0xa97c}, {0xa984, 0xa9b2}, - {0xa9e0, 0xa9e4}, {0xa9e6, 0xa9ef}, {0xa9fa, 0xa9fe}, {0xaa00, 0xaa28}, - {0xaa40, 0xaa42}, {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, {0xaa7e, 0xaaaf}, - {0xaab9, 0xaabd}, {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, - {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, - {0xab28, 0xab2e}, {0xab30, 0xab5a}, {0xab5c, 0xab65}, {0xab70, 0xabe2}, - {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xdc00, 0xdc3e}, - {0xdc40, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, {0xdd00, 0xdd3e}, - {0xdd40, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, {0xde00, 0xde3e}, - {0xde40, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, {0xdf00, 0xdf3e}, - {0xdf40, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, {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 + {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d}, {0x1c80, 0x1c88}, {0x1c90, 0x1cba}, + {0x1cbd, 0x1cbf}, {0x1ce9, 0x1cec}, {0x1cee, 0x1cf1}, {0x1d00, 0x1dbf}, + {0x1e00, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, + {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, + {0x1fc2, 0x1fc4}, {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, + {0x1fe0, 0x1fec}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x2090, 0x209c}, + {0x210a, 0x2113}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, + {0x213c, 0x213f}, {0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, + {0x2c60, 0x2ce4}, {0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, + {0x2d80, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, + {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, + {0x2dd8, 0x2dde}, {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, + {0x30a1, 0x30fa}, {0x30fc, 0x30ff}, {0x3105, 0x312f}, {0x3131, 0x318e}, + {0x31a0, 0x31ba}, {0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fef}, + {0xa000, 0xa48c}, {0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, + {0xa640, 0xa66e}, {0xa67f, 0xa69d}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, + {0xa722, 0xa788}, {0xa78b, 0xa7b9}, {0xa7f7, 0xa801}, {0xa803, 0xa805}, + {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873}, {0xa882, 0xa8b3}, + {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946}, {0xa960, 0xa97c}, + {0xa984, 0xa9b2}, {0xa9e0, 0xa9e4}, {0xa9e6, 0xa9ef}, {0xa9fa, 0xa9fe}, + {0xaa00, 0xaa28}, {0xaa40, 0xaa42}, {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, + {0xaa7e, 0xaaaf}, {0xaab9, 0xaabd}, {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, + {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, + {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xab30, 0xab5a}, {0xab5c, 0xab65}, + {0xab70, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, + {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, + {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, + {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, + {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, + {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, + {0xffda, 0xffdc} +#if CHRBITS > 16 ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10280, 0x1029c}, {0x102a0, 0x102d0}, {0x10300, 0x1031f}, {0x1032d, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375}, @@ -212,23 +209,25 @@ static const crange alphaRangeTable[] = { {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10860, 0x10876}, {0x10880, 0x1089e}, {0x108e0, 0x108f2}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109b7}, - {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, {0x10a60, 0x10a7c}, + {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a60, 0x10a7c}, {0x10a80, 0x10a9c}, {0x10ac0, 0x10ac7}, {0x10ac9, 0x10ae4}, {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, {0x10b80, 0x10b91}, {0x10c00, 0x10c48}, - {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x11003, 0x11037}, {0x11083, 0x110af}, - {0x110d0, 0x110e8}, {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111b2}, - {0x111c1, 0x111c4}, {0x11200, 0x11211}, {0x11213, 0x1122b}, {0x11280, 0x11286}, - {0x1128a, 0x1128d}, {0x1128f, 0x1129d}, {0x1129f, 0x112a8}, {0x112b0, 0x112de}, - {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, - {0x1135d, 0x11361}, {0x11400, 0x11434}, {0x11447, 0x1144a}, {0x11480, 0x114af}, - {0x11580, 0x115ae}, {0x115d8, 0x115db}, {0x11600, 0x1162f}, {0x11680, 0x116aa}, - {0x11700, 0x11719}, {0x118a0, 0x118df}, {0x11a0b, 0x11a32}, {0x11a5c, 0x11a83}, + {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10d00, 0x10d23}, {0x10f00, 0x10f1c}, + {0x10f30, 0x10f45}, {0x11003, 0x11037}, {0x11083, 0x110af}, {0x110d0, 0x110e8}, + {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, + {0x11200, 0x11211}, {0x11213, 0x1122b}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, + {0x1128f, 0x1129d}, {0x1129f, 0x112a8}, {0x112b0, 0x112de}, {0x11305, 0x1130c}, + {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, {0x1135d, 0x11361}, + {0x11400, 0x11434}, {0x11447, 0x1144a}, {0x11480, 0x114af}, {0x11580, 0x115ae}, + {0x115d8, 0x115db}, {0x11600, 0x1162f}, {0x11680, 0x116aa}, {0x11700, 0x1171a}, + {0x11800, 0x1182b}, {0x118a0, 0x118df}, {0x11a0b, 0x11a32}, {0x11a5c, 0x11a83}, {0x11a86, 0x11a89}, {0x11ac0, 0x11af8}, {0x11c00, 0x11c08}, {0x11c0a, 0x11c2e}, - {0x11c72, 0x11c8f}, {0x11d00, 0x11d06}, {0x11d0b, 0x11d30}, {0x12000, 0x12399}, - {0x12480, 0x12543}, {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, - {0x16a40, 0x16a5e}, {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f}, {0x16b40, 0x16b43}, - {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, {0x16f00, 0x16f44}, {0x16f93, 0x16f9f}, - {0x17000, 0x187ec}, {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, + {0x11c72, 0x11c8f}, {0x11d00, 0x11d06}, {0x11d0b, 0x11d30}, {0x11d60, 0x11d65}, + {0x11d6a, 0x11d89}, {0x11ee0, 0x11ef2}, {0x12000, 0x12399}, {0x12480, 0x12543}, + {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, + {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f}, {0x16b40, 0x16b43}, {0x16b63, 0x16b77}, + {0x16b7d, 0x16b8f}, {0x16e40, 0x16e7f}, {0x16f00, 0x16f44}, {0x16f93, 0x16f9f}, + {0x17000, 0x187f1}, {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, {0x1d50d, 0x1d514}, @@ -264,17 +263,18 @@ static const chr alphaCharTable[] = { 0x1baf, 0x1cf5, 0x1cf6, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x2071, 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, 0x303b, - 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa8fd, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, - 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44 -#if TCL_UTF_MAX > 4 + 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa8fd, 0xa8fe, 0xa9cf, 0xaa7a, 0xaab1, + 0xaab5, 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, + 0xfb44 +#if CHRBITS > 16 ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, 0x108f5, 0x109be, - 0x109bf, 0x10a00, 0x11176, 0x111da, 0x111dc, 0x11288, 0x1130f, 0x11310, 0x11332, - 0x11333, 0x1133d, 0x11350, 0x114c4, 0x114c5, 0x114c7, 0x11644, 0x118ff, 0x11a00, - 0x11a3a, 0x11a50, 0x11c40, 0x11d08, 0x11d09, 0x11d46, 0x16f50, 0x16fe0, 0x16fe1, - 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, - 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, - 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, - 0x1ee64, 0x1ee7e + 0x109bf, 0x10a00, 0x10f27, 0x11144, 0x11176, 0x111da, 0x111dc, 0x11288, 0x1130f, + 0x11310, 0x11332, 0x11333, 0x1133d, 0x11350, 0x114c4, 0x114c5, 0x114c7, 0x11644, + 0x118ff, 0x11a00, 0x11a3a, 0x11a50, 0x11a9d, 0x11c40, 0x11d08, 0x11d09, 0x11d46, + 0x11d67, 0x11d68, 0x11d98, 0x16f50, 0x16fe0, 0x16fe1, 0x1d49e, 0x1d49f, 0x1d4a2, + 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, + 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, + 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e #endif }; @@ -288,7 +288,7 @@ static const crange controlRangeTable[] = { {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x605}, {0x200b, 0x200f}, {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} -#if TCL_UTF_MAX > 4 +#if CHRBITS > 16 ,{0x1bca0, 0x1bca3}, {0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} #endif @@ -298,8 +298,8 @@ static const crange controlRangeTable[] = { static const chr controlCharTable[] = { 0xad, 0x61c, 0x6dd, 0x70f, 0x8e2, 0x180e, 0xfeff -#if TCL_UTF_MAX > 4 - ,0x110bd, 0xe0001 +#if CHRBITS > 16 + ,0x110bd, 0x110cd, 0xe0001 #endif }; @@ -320,12 +320,12 @@ static const crange digitRangeTable[] = { {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}, {0x112f0, 0x112f9}, {0x11450, 0x11459}, {0x114d0, 0x114d9}, - {0x11650, 0x11659}, {0x116c0, 0x116c9}, {0x11730, 0x11739}, {0x118e0, 0x118e9}, - {0x11c50, 0x11c59}, {0x11d50, 0x11d59}, {0x16a60, 0x16a69}, {0x16b50, 0x16b59}, - {0x1d7ce, 0x1d7ff}, {0x1e950, 0x1e959} +#if CHRBITS > 16 + ,{0x104a0, 0x104a9}, {0x10d30, 0x10d39}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, + {0x11136, 0x1113f}, {0x111d0, 0x111d9}, {0x112f0, 0x112f9}, {0x11450, 0x11459}, + {0x114d0, 0x114d9}, {0x11650, 0x11659}, {0x116c0, 0x116c9}, {0x11730, 0x11739}, + {0x118e0, 0x118e9}, {0x11c50, 0x11c59}, {0x11d50, 0x11d59}, {0x11da0, 0x11da9}, + {0x16a60, 0x16a69}, {0x16b50, 0x16b59}, {0x1d7ce, 0x1d7ff}, {0x1e950, 0x1e959} #endif }; @@ -348,19 +348,20 @@ static const crange punctRangeTable[] = { {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, - {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e49}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e4e}, {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} -#if TCL_UTF_MAX > 4 +#if CHRBITS > 16 ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10af0, 0x10af6}, {0x10b39, 0x10b3f}, - {0x10b99, 0x10b9c}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, {0x11140, 0x11143}, - {0x111c5, 0x111c9}, {0x111dd, 0x111df}, {0x11238, 0x1123d}, {0x1144b, 0x1144f}, - {0x115c1, 0x115d7}, {0x11641, 0x11643}, {0x11660, 0x1166c}, {0x1173c, 0x1173e}, - {0x11a3f, 0x11a46}, {0x11a9a, 0x11a9c}, {0x11a9e, 0x11aa2}, {0x11c41, 0x11c45}, - {0x12470, 0x12474}, {0x16b37, 0x16b3b}, {0x1da87, 0x1da8b} + {0x10b99, 0x10b9c}, {0x10f55, 0x10f59}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, + {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x111dd, 0x111df}, {0x11238, 0x1123d}, + {0x1144b, 0x1144f}, {0x115c1, 0x115d7}, {0x11641, 0x11643}, {0x11660, 0x1166c}, + {0x1173c, 0x1173e}, {0x11a3f, 0x11a46}, {0x11a9a, 0x11a9c}, {0x11a9e, 0x11aa2}, + {0x11c41, 0x11c45}, {0x12470, 0x12474}, {0x16b37, 0x16b3b}, {0x16e97, 0x16e9a}, + {0x1da87, 0x1da8b} #endif }; @@ -371,18 +372,20 @@ static const chr punctCharTable[] = { 0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a, 0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c, 0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970, - 0x9fd, 0xaf0, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, 0xf85, 0xfd9, - 0xfda, 0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, 0x1735, 0x1736, - 0x1944, 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, 0x207d, 0x207e, - 0x208d, 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, 0x29fd, 0x2cfe, - 0x2cff, 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, 0xa4ff, 0xa673, - 0xa67e, 0xa8ce, 0xa8cf, 0xa8fc, 0xa92e, 0xa92f, 0xa95f, 0xa9de, 0xa9df, - 0xaade, 0xaadf, 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, - 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d -#if TCL_UTF_MAX > 4 + 0x9fd, 0xa76, 0xaf0, 0xc84, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, + 0xf85, 0xfd9, 0xfda, 0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, + 0x1735, 0x1736, 0x1944, 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, + 0x207d, 0x207e, 0x208d, 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, + 0x29fd, 0x2cfe, 0x2cff, 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, + 0xa4ff, 0xa673, 0xa67e, 0xa8ce, 0xa8cf, 0xa8fc, 0xa92e, 0xa92f, 0xa95f, + 0xa9de, 0xa9df, 0xaade, 0xaadf, 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, + 0xfe63, 0xfe68, 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, + 0xff5b, 0xff5d +#if CHRBITS > 16 ,0x1039f, 0x103d0, 0x1056f, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc, - 0x11174, 0x11175, 0x111cd, 0x111db, 0x112a9, 0x1145b, 0x1145d, 0x114c6, 0x11c70, - 0x11c71, 0x16a6e, 0x16a6f, 0x16af5, 0x16b44, 0x1bc9f, 0x1e95e, 0x1e95f + 0x11174, 0x11175, 0x111cd, 0x111db, 0x112a9, 0x1145b, 0x1145d, 0x114c6, 0x1183b, + 0x11c70, 0x11c71, 0x11ef7, 0x11ef8, 0x16a6e, 0x16a6f, 0x16af5, 0x16b44, 0x1bc9f, + 0x1e95e, 0x1e95f #endif }; @@ -413,25 +416,25 @@ static const crange lowerRangeTable[] = { {0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180}, {0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293}, {0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7}, - {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x561, 0x587}, {0x13f8, 0x13fd}, - {0x1c80, 0x1c88}, {0x1d00, 0x1d2b}, {0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, - {0x1e95, 0x1e9d}, {0x1eff, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, - {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, - {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, - {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, - {0x1ff2, 0x1ff4}, {0x2146, 0x2149}, {0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, - {0x2d00, 0x2d25}, {0xa72f, 0xa731}, {0xa771, 0xa778}, {0xa793, 0xa795}, - {0xab30, 0xab5a}, {0xab60, 0xab65}, {0xab70, 0xabbf}, {0xfb00, 0xfb06}, - {0xfb13, 0xfb17}, {0xff41, 0xff5a} -#if TCL_UTF_MAX > 4 + {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x560, 0x588}, {0x10d0, 0x10fa}, + {0x10fd, 0x10ff}, {0x13f8, 0x13fd}, {0x1c80, 0x1c88}, {0x1d00, 0x1d2b}, + {0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07}, + {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, + {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, + {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, + {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149}, + {0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731}, + {0xa771, 0xa778}, {0xa793, 0xa795}, {0xab30, 0xab5a}, {0xab60, 0xab65}, + {0xab70, 0xabbf}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} +#if CHRBITS > 16 ,{0x10428, 0x1044f}, {0x104d8, 0x104fb}, {0x10cc0, 0x10cf2}, {0x118c0, 0x118df}, - {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}, {0x1e922, 0x1e943} + {0x16e60, 0x16e7f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467}, + {0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf}, + {0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f}, + {0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f}, + {0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714}, + {0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788}, + {0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9}, {0x1e922, 0x1e943} #endif }; @@ -501,8 +504,8 @@ static const chr lowerCharTable[] = { 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, - 0xa7b5, 0xa7b7, 0xa7fa -#if TCL_UTF_MAX > 4 + 0xa7af, 0xa7b5, 0xa7b7, 0xa7b9, 0xa7fa +#if CHRBITS > 16 ,0x1d4bb, 0x1d7cb #endif }; @@ -518,20 +521,22 @@ static const crange upperRangeTable[] = { {0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8}, {0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab}, {0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5}, - {0x13a0, 0x13f5}, {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, - {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, - {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, - {0x210b, 0x210d}, {0x2110, 0x2112}, {0x2119, 0x211d}, {0x212a, 0x212d}, - {0x2130, 0x2133}, {0x2c00, 0x2c2e}, {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, - {0x2c7e, 0x2c80}, {0xa7aa, 0xa7ae}, {0xa7b0, 0xa7b4}, {0xff21, 0xff3a} -#if TCL_UTF_MAX > 4 + {0x13a0, 0x13f5}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf}, {0x1f08, 0x1f0f}, + {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, + {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, + {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112}, + {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, {0x2c00, 0x2c2e}, + {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, {0xa7aa, 0xa7ae}, + {0xa7b0, 0xa7b4}, {0xff21, 0xff3a} +#if CHRBITS > 16 ,{0x10400, 0x10427}, {0x104b0, 0x104d3}, {0x10c80, 0x10cb2}, {0x118a0, 0x118bf}, - {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}, {0x1e900, 0x1e921} + {0x16e40, 0x16e5f}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481}, + {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a}, + {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, + {0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed}, + {0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0}, + {0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8}, + {0x1e900, 0x1e921} #endif }; @@ -600,8 +605,9 @@ static const chr upperCharTable[] = { 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, 0xa764, 0xa766, 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, 0xa77e, 0xa780, 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, 0xa796, 0xa798, - 0xa79a, 0xa79c, 0xa79e, 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7b6 -#if TCL_UTF_MAX > 4 + 0xa79a, 0xa79c, 0xa79e, 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7b6, + 0xa7b8 +#if CHRBITS > 16 ,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538, 0x1d539, 0x1d546, 0x1d7ca #endif @@ -616,85 +622,80 @@ static const chr upperCharTable[] = { static const crange graphRangeTable[] = { {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}, {0x860, 0x86a}, - {0x8a0, 0x8b4}, {0x8b6, 0x8bd}, {0x8d4, 0x8e1}, {0x8e3, 0x983}, - {0x985, 0x98c}, {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, - {0x9bc, 0x9c4}, {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fd}, - {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}, {0xaf9, 0xaff}, - {0xb01, 0xb03}, {0xb05, 0xb0c}, {0xb13, 0xb28}, {0xb2a, 0xb30}, - {0xb35, 0xb39}, {0xb3c, 0xb44}, {0xb4b, 0xb4d}, {0xb5f, 0xb63}, - {0xb66, 0xb77}, {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, - {0xba8, 0xbaa}, {0xbae, 0xbb9}, {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, - {0xbca, 0xbcd}, {0xbe6, 0xbfa}, {0xc00, 0xc03}, {0xc05, 0xc0c}, - {0xc0e, 0xc10}, {0xc12, 0xc28}, {0xc2a, 0xc39}, {0xc3d, 0xc44}, - {0xc46, 0xc48}, {0xc4a, 0xc4d}, {0xc58, 0xc5a}, {0xc60, 0xc63}, - {0xc66, 0xc6f}, {0xc78, 0xc83}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, - {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xcbc, 0xcc4}, - {0xcc6, 0xcc8}, {0xcca, 0xccd}, {0xce0, 0xce3}, {0xce6, 0xcef}, - {0xd00, 0xd03}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, {0xd12, 0xd44}, - {0xd46, 0xd48}, {0xd4a, 0xd4f}, {0xd54, 0xd63}, {0xd66, 0xd7f}, - {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, - {0xdcf, 0xdd4}, {0xdd8, 0xddf}, {0xde6, 0xdef}, {0xdf2, 0xdf4}, - {0xe01, 0xe3a}, {0xe3f, 0xe5b}, {0xe94, 0xe97}, {0xe99, 0xe9f}, - {0xea1, 0xea3}, {0xead, 0xeb9}, {0xebb, 0xebd}, {0xec0, 0xec4}, - {0xec8, 0xecd}, {0xed0, 0xed9}, {0xedc, 0xedf}, {0xf00, 0xf47}, - {0xf49, 0xf6c}, {0xf71, 0xf97}, {0xf99, 0xfbc}, {0xfbe, 0xfcc}, - {0xfce, 0xfda}, {0x1000, 0x10c5}, {0x10d0, 0x1248}, {0x124a, 0x124d}, - {0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, {0x128a, 0x128d}, - {0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, - {0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135a}, - {0x135d, 0x137c}, {0x1380, 0x1399}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, - {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f8}, {0x1700, 0x170c}, - {0x170e, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176c}, - {0x176e, 0x1770}, {0x1780, 0x17dd}, {0x17e0, 0x17e9}, {0x17f0, 0x17f9}, - {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1877}, {0x1880, 0x18aa}, - {0x18b0, 0x18f5}, {0x1900, 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}, {0x1ab0, 0x1abe}, - {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37}, - {0x1c3b, 0x1c49}, {0x1c4d, 0x1c88}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf9}, - {0x1d00, 0x1df9}, {0x1dfb, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, - {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, - {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, - {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, - {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20bf}, {0x20d0, 0x20f0}, - {0x2100, 0x218b}, {0x2190, 0x2426}, {0x2440, 0x244a}, {0x2460, 0x2b73}, - {0x2b76, 0x2b95}, {0x2b98, 0x2bb9}, {0x2bbd, 0x2bc8}, {0x2bca, 0x2bd2}, - {0x2bec, 0x2bef}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, + {0x559, 0x58a}, {0x58d, 0x58f}, {0x591, 0x5c7}, {0x5d0, 0x5ea}, + {0x5ef, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d}, + {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x7fd, 0x82d}, + {0x830, 0x83e}, {0x840, 0x85b}, {0x860, 0x86a}, {0x8a0, 0x8b4}, + {0x8b6, 0x8bd}, {0x8d3, 0x8e1}, {0x8e3, 0x983}, {0x985, 0x98c}, + {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, + {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fe}, {0xa01, 0xa03}, + {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42}, + {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa76}, {0xa81, 0xa83}, + {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, {0xaaa, 0xab0}, + {0xab5, 0xab9}, {0xabc, 0xac5}, {0xac7, 0xac9}, {0xacb, 0xacd}, + {0xae0, 0xae3}, {0xae6, 0xaf1}, {0xaf9, 0xaff}, {0xb01, 0xb03}, + {0xb05, 0xb0c}, {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, + {0xb3c, 0xb44}, {0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, + {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, + {0xbae, 0xbb9}, {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, + {0xbe6, 0xbfa}, {0xc00, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, + {0xc2a, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48}, {0xc4a, 0xc4d}, + {0xc58, 0xc5a}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc78, 0xc8c}, + {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, + {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd}, {0xce0, 0xce3}, + {0xce6, 0xcef}, {0xd00, 0xd03}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, + {0xd12, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4f}, {0xd54, 0xd63}, + {0xd66, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, + {0xdc0, 0xdc6}, {0xdcf, 0xdd4}, {0xdd8, 0xddf}, {0xde6, 0xdef}, + {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, {0xe94, 0xe97}, + {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb9}, {0xebb, 0xebd}, + {0xec0, 0xec4}, {0xec8, 0xecd}, {0xed0, 0xed9}, {0xedc, 0xedf}, + {0xf00, 0xf47}, {0xf49, 0xf6c}, {0xf71, 0xf97}, {0xf99, 0xfbc}, + {0xfbe, 0xfcc}, {0xfce, 0xfda}, {0x1000, 0x10c5}, {0x10d0, 0x1248}, + {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, + {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, + {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, + {0x1318, 0x135a}, {0x135d, 0x137c}, {0x1380, 0x1399}, {0x13a0, 0x13f5}, + {0x13f8, 0x13fd}, {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f8}, + {0x1700, 0x170c}, {0x170e, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, + {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17dd}, {0x17e0, 0x17e9}, + {0x17f0, 0x17f9}, {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1878}, + {0x1880, 0x18aa}, {0x18b0, 0x18f5}, {0x1900, 0x191e}, {0x1920, 0x192b}, + {0x1930, 0x193b}, {0x1944, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, + {0x19b0, 0x19c9}, {0x19d0, 0x19da}, {0x19de, 0x1a1b}, {0x1a1e, 0x1a5e}, + {0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad}, + {0x1ab0, 0x1abe}, {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, + {0x1bfc, 0x1c37}, {0x1c3b, 0x1c49}, {0x1c4d, 0x1c88}, {0x1c90, 0x1cba}, + {0x1cbd, 0x1cc7}, {0x1cd0, 0x1cf9}, {0x1d00, 0x1df9}, {0x1dfb, 0x1f15}, + {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, + {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, + {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, + {0x2010, 0x2027}, {0x2030, 0x205e}, {0x2074, 0x208e}, {0x2090, 0x209c}, + {0x20a0, 0x20bf}, {0x20d0, 0x20f0}, {0x2100, 0x218b}, {0x2190, 0x2426}, + {0x2440, 0x244a}, {0x2460, 0x2b73}, {0x2b76, 0x2b95}, {0x2b98, 0x2bc8}, + {0x2bca, 0x2bfe}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, {0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, - {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, {0x2de0, 0x2e49}, + {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, {0x2de0, 0x2e4e}, {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, - {0x3001, 0x303f}, {0x3041, 0x3096}, {0x3099, 0x30ff}, {0x3105, 0x312e}, + {0x3001, 0x303f}, {0x3041, 0x3096}, {0x3099, 0x30ff}, {0x3105, 0x312f}, {0x3131, 0x318e}, {0x3190, 0x31ba}, {0x31c0, 0x31e3}, {0x31f0, 0x321e}, - {0x3220, 0x32fe}, {0x3300, 0x4db5}, {0x4dc0, 0x9fea}, {0xa000, 0xa48c}, - {0xa490, 0xa4c6}, {0xa4d0, 0xa62b}, {0xa640, 0xa6f7}, {0xa700, 0xa7ae}, - {0xa7b0, 0xa7b7}, {0xa7f7, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, - {0xa880, 0xa8c5}, {0xa8ce, 0xa8d9}, {0xa8e0, 0xa8fd}, {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, 0xab65}, {0xab70, 0xabed}, - {0xabf0, 0xabf9}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, - {0xdc00, 0xdc3e}, {0xdc40, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, - {0xdd00, 0xdd3e}, {0xdd40, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, - {0xde00, 0xde3e}, {0xde40, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, - {0xdf00, 0xdf3e}, {0xdf40, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, - {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, - {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, - {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, - {0xfe20, 0xfe52}, {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, - {0xfe76, 0xfefc}, {0xff01, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, - {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee} -#if TCL_UTF_MAX > 4 + {0x3220, 0x32fe}, {0x3300, 0x4db5}, {0x4dc0, 0x9fef}, {0xa000, 0xa48c}, + {0xa490, 0xa4c6}, {0xa4d0, 0xa62b}, {0xa640, 0xa6f7}, {0xa700, 0xa7b9}, + {0xa7f7, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, {0xa880, 0xa8c5}, + {0xa8ce, 0xa8d9}, {0xa8e0, 0xa953}, {0xa95f, 0xa97c}, {0xa980, 0xa9cd}, + {0xa9cf, 0xa9d9}, {0xa9de, 0xa9fe}, {0xaa00, 0xaa36}, {0xaa40, 0xaa4d}, + {0xaa50, 0xaa59}, {0xaa5c, 0xaac2}, {0xaadb, 0xaaf6}, {0xab01, 0xab06}, + {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, + {0xab30, 0xab65}, {0xab70, 0xabed}, {0xabf0, 0xabf9}, {0xac00, 0xd7a3}, + {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, + {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, + {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, + {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe52}, {0xfe54, 0xfe66}, + {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff01, 0xffbe}, + {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}, + {0xffe0, 0xffe6}, {0xffe8, 0xffee} +#if CHRBITS > 16 ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133}, {0x10137, 0x1018e}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, @@ -705,80 +706,85 @@ static const crange graphRangeTable[] = { {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10857, 0x1089e}, {0x108a7, 0x108af}, {0x108e0, 0x108f2}, {0x108fb, 0x1091b}, {0x1091f, 0x10939}, {0x10980, 0x109b7}, {0x109bc, 0x109cf}, {0x109d2, 0x10a03}, - {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, {0x10a38, 0x10a3a}, - {0x10a3f, 0x10a47}, {0x10a50, 0x10a58}, {0x10a60, 0x10a9f}, {0x10ac0, 0x10ae6}, + {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a38, 0x10a3a}, + {0x10a3f, 0x10a48}, {0x10a50, 0x10a58}, {0x10a60, 0x10a9f}, {0x10ac0, 0x10ae6}, {0x10aeb, 0x10af6}, {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, {0x10b78, 0x10b91}, {0x10b99, 0x10b9c}, {0x10ba9, 0x10baf}, {0x10c00, 0x10c48}, - {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10cfa, 0x10cff}, {0x10e60, 0x10e7e}, - {0x11000, 0x1104d}, {0x11052, 0x1106f}, {0x1107f, 0x110bc}, {0x110be, 0x110c1}, - {0x110d0, 0x110e8}, {0x110f0, 0x110f9}, {0x11100, 0x11134}, {0x11136, 0x11143}, - {0x11150, 0x11176}, {0x11180, 0x111cd}, {0x111d0, 0x111df}, {0x111e1, 0x111f4}, - {0x11200, 0x11211}, {0x11213, 0x1123e}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, - {0x1128f, 0x1129d}, {0x1129f, 0x112a9}, {0x112b0, 0x112ea}, {0x112f0, 0x112f9}, - {0x11300, 0x11303}, {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, - {0x11335, 0x11339}, {0x1133c, 0x11344}, {0x1134b, 0x1134d}, {0x1135d, 0x11363}, - {0x11366, 0x1136c}, {0x11370, 0x11374}, {0x11400, 0x11459}, {0x11480, 0x114c7}, - {0x114d0, 0x114d9}, {0x11580, 0x115b5}, {0x115b8, 0x115dd}, {0x11600, 0x11644}, - {0x11650, 0x11659}, {0x11660, 0x1166c}, {0x11680, 0x116b7}, {0x116c0, 0x116c9}, - {0x11700, 0x11719}, {0x1171d, 0x1172b}, {0x11730, 0x1173f}, {0x118a0, 0x118f2}, - {0x11a00, 0x11a47}, {0x11a50, 0x11a83}, {0x11a86, 0x11a9c}, {0x11a9e, 0x11aa2}, - {0x11ac0, 0x11af8}, {0x11c00, 0x11c08}, {0x11c0a, 0x11c36}, {0x11c38, 0x11c45}, - {0x11c50, 0x11c6c}, {0x11c70, 0x11c8f}, {0x11c92, 0x11ca7}, {0x11ca9, 0x11cb6}, - {0x11d00, 0x11d06}, {0x11d0b, 0x11d36}, {0x11d3f, 0x11d47}, {0x11d50, 0x11d59}, + {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10cfa, 0x10d27}, {0x10d30, 0x10d39}, + {0x10e60, 0x10e7e}, {0x10f00, 0x10f27}, {0x10f30, 0x10f59}, {0x11000, 0x1104d}, + {0x11052, 0x1106f}, {0x1107f, 0x110bc}, {0x110be, 0x110c1}, {0x110d0, 0x110e8}, + {0x110f0, 0x110f9}, {0x11100, 0x11134}, {0x11136, 0x11146}, {0x11150, 0x11176}, + {0x11180, 0x111cd}, {0x111d0, 0x111df}, {0x111e1, 0x111f4}, {0x11200, 0x11211}, + {0x11213, 0x1123e}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, {0x1128f, 0x1129d}, + {0x1129f, 0x112a9}, {0x112b0, 0x112ea}, {0x112f0, 0x112f9}, {0x11300, 0x11303}, + {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, + {0x1133b, 0x11344}, {0x1134b, 0x1134d}, {0x1135d, 0x11363}, {0x11366, 0x1136c}, + {0x11370, 0x11374}, {0x11400, 0x11459}, {0x11480, 0x114c7}, {0x114d0, 0x114d9}, + {0x11580, 0x115b5}, {0x115b8, 0x115dd}, {0x11600, 0x11644}, {0x11650, 0x11659}, + {0x11660, 0x1166c}, {0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x11700, 0x1171a}, + {0x1171d, 0x1172b}, {0x11730, 0x1173f}, {0x11800, 0x1183b}, {0x118a0, 0x118f2}, + {0x11a00, 0x11a47}, {0x11a50, 0x11a83}, {0x11a86, 0x11aa2}, {0x11ac0, 0x11af8}, + {0x11c00, 0x11c08}, {0x11c0a, 0x11c36}, {0x11c38, 0x11c45}, {0x11c50, 0x11c6c}, + {0x11c70, 0x11c8f}, {0x11c92, 0x11ca7}, {0x11ca9, 0x11cb6}, {0x11d00, 0x11d06}, + {0x11d0b, 0x11d36}, {0x11d3f, 0x11d47}, {0x11d50, 0x11d59}, {0x11d60, 0x11d65}, + {0x11d6a, 0x11d8e}, {0x11d93, 0x11d98}, {0x11da0, 0x11da9}, {0x11ee0, 0x11ef8}, {0x12000, 0x12399}, {0x12400, 0x1246e}, {0x12470, 0x12474}, {0x12480, 0x12543}, {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, {0x16a60, 0x16a69}, {0x16ad0, 0x16aed}, {0x16af0, 0x16af5}, {0x16b00, 0x16b45}, {0x16b50, 0x16b59}, {0x16b5b, 0x16b61}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, - {0x16f00, 0x16f44}, {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, {0x17000, 0x187ec}, - {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, {0x1bc00, 0x1bc6a}, - {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, {0x1bc9c, 0x1bc9f}, - {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, {0x1d129, 0x1d172}, {0x1d17b, 0x1d1e8}, - {0x1d200, 0x1d245}, {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, 0x1da8b}, {0x1da9b, 0x1da9f}, - {0x1daa1, 0x1daaf}, {0x1e000, 0x1e006}, {0x1e008, 0x1e018}, {0x1e01b, 0x1e021}, - {0x1e026, 0x1e02a}, {0x1e800, 0x1e8c4}, {0x1e8c7, 0x1e8d6}, {0x1e900, 0x1e94a}, - {0x1e950, 0x1e959}, {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, 0x1f1ac}, {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23b}, {0x1f240, 0x1f248}, - {0x1f260, 0x1f265}, {0x1f300, 0x1f6d4}, {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6f8}, - {0x1f700, 0x1f773}, {0x1f780, 0x1f7d4}, {0x1f800, 0x1f80b}, {0x1f810, 0x1f847}, - {0x1f850, 0x1f859}, {0x1f860, 0x1f887}, {0x1f890, 0x1f8ad}, {0x1f900, 0x1f90b}, - {0x1f910, 0x1f93e}, {0x1f940, 0x1f94c}, {0x1f950, 0x1f96b}, {0x1f980, 0x1f997}, - {0x1f9d0, 0x1f9e6}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, - {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef} + {0x16e40, 0x16e9a}, {0x16f00, 0x16f44}, {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, + {0x17000, 0x187f1}, {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, + {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, + {0x1bc9c, 0x1bc9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, {0x1d129, 0x1d172}, + {0x1d17b, 0x1d1e8}, {0x1d200, 0x1d245}, {0x1d2e0, 0x1d2f3}, {0x1d300, 0x1d356}, + {0x1d360, 0x1d378}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, + {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, + {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, + {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb}, + {0x1d7ce, 0x1da8b}, {0x1da9b, 0x1da9f}, {0x1daa1, 0x1daaf}, {0x1e000, 0x1e006}, + {0x1e008, 0x1e018}, {0x1e01b, 0x1e021}, {0x1e026, 0x1e02a}, {0x1e800, 0x1e8c4}, + {0x1e8c7, 0x1e8d6}, {0x1e900, 0x1e94a}, {0x1e950, 0x1e959}, {0x1ec71, 0x1ecb4}, + {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, + {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, + {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, + {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b}, {0x1f030, 0x1f093}, + {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0bf}, {0x1f0c1, 0x1f0cf}, {0x1f0d1, 0x1f0f5}, + {0x1f100, 0x1f10c}, {0x1f110, 0x1f16b}, {0x1f170, 0x1f1ac}, {0x1f1e6, 0x1f202}, + {0x1f210, 0x1f23b}, {0x1f240, 0x1f248}, {0x1f260, 0x1f265}, {0x1f300, 0x1f6d4}, + {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6f9}, {0x1f700, 0x1f773}, {0x1f780, 0x1f7d8}, + {0x1f800, 0x1f80b}, {0x1f810, 0x1f847}, {0x1f850, 0x1f859}, {0x1f860, 0x1f887}, + {0x1f890, 0x1f8ad}, {0x1f900, 0x1f90b}, {0x1f910, 0x1f93e}, {0x1f940, 0x1f970}, + {0x1f973, 0x1f976}, {0x1f97c, 0x1f9a2}, {0x1f9b0, 0x1f9b9}, {0x1f9c0, 0x1f9c2}, + {0x1f9d0, 0x1f9ff}, {0x1fa60, 0x1fa6d}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, + {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d}, + {0xe0100, 0xe01ef} #endif }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) static const chr graphCharTable[] = { - 0x38c, 0x589, 0x58a, 0x85e, 0x98f, 0x990, 0x9b2, 0x9c7, 0x9c8, - 0x9d7, 0x9dc, 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, - 0xa38, 0xa39, 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, 0xab2, 0xab3, - 0xad0, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, 0xb56, 0xb57, - 0xb5c, 0xb5d, 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, - 0xba3, 0xba4, 0xbd0, 0xbd7, 0xc55, 0xc56, 0xcd5, 0xcd6, 0xcde, - 0xcf1, 0xcf2, 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, - 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, - 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, - 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xfb3e, - 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd -#if TCL_UTF_MAX > 4 + 0x38c, 0x85e, 0x98f, 0x990, 0x9b2, 0x9c7, 0x9c8, 0x9d7, 0x9dc, + 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, 0xa39, + 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, 0xab2, 0xab3, 0xad0, 0xb0f, + 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, 0xb56, 0xb57, 0xb5c, 0xb5d, + 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, + 0xbd0, 0xbd7, 0xc55, 0xc56, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, + 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, 0xe84, 0xe87, + 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, 0xec6, 0x10c7, + 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, 0x1f5b, 0x1f5d, + 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xfb3e, 0xfb40, 0xfb41, + 0xfb43, 0xfb44, 0xfffc, 0xfffd +#if CHRBITS > 16 ,0x1003c, 0x1003d, 0x101a0, 0x1056f, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, 0x108f5, 0x1093f, 0x10a05, 0x10a06, 0x11288, 0x1130f, 0x11310, 0x11332, 0x11333, - 0x11347, 0x11348, 0x11350, 0x11357, 0x1145b, 0x1145d, 0x118ff, 0x11d08, 0x11d09, - 0x11d3a, 0x11d3c, 0x11d3d, 0x16a6e, 0x16a6f, 0x16fe0, 0x16fe1, 0x1d49e, 0x1d49f, - 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, 0x1e023, 0x1e024, 0x1e95e, 0x1e95f, - 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, - 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, - 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, 0x1eef0, 0x1eef1, 0x1f250, 0x1f251, 0x1f9c0 + 0x11347, 0x11348, 0x11350, 0x11357, 0x1145b, 0x1145d, 0x1145e, 0x118ff, 0x11d08, + 0x11d09, 0x11d3a, 0x11d3c, 0x11d3d, 0x11d67, 0x11d68, 0x11d90, 0x11d91, 0x16a6e, + 0x16a6f, 0x16fe0, 0x16fe1, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, + 0x1d546, 0x1e023, 0x1e024, 0x1e95e, 0x1e95f, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, + 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, + 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, + 0x1eef0, 0x1eef1, 0x1f250, 0x1f251, 0x1f97a #endif }; @@ -1234,7 +1240,7 @@ cmp( const chr *x, const chr *y, /* strings to compare */ size_t len) /* exact length of comparison */ { - return memcmp(VS(x), VS(y), len*sizeof(chr)); + return memcmp((void*)(x), (void*)(y), len*sizeof(chr)); } /* diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 088c6c0..240fcfe 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -843,7 +843,7 @@ moveins( /* - copyins - copy in arcs of a state to another state - ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); + ^ static void copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( @@ -1100,7 +1100,7 @@ moveouts( /* - copyouts - copy out arcs of a state to another state - ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); + ^ static void copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( diff --git a/generic/regcomp.c b/generic/regcomp.c index 211cd70..58d55fb 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -82,7 +82,7 @@ static int lexescape(struct vars *); static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); -static chr newline(NOPARMS); +static chr newline(void); static chr chrnamed(struct vars *, const chr *, const chr *, pchr); /* === regc_color.c === */ static void initcm(struct vars *, struct colormap *); @@ -341,13 +341,13 @@ compile( re->re_info = 0; /* bits get set during parse */ re->re_csize = sizeof(chr); re->re_guts = NULL; - re->re_fns = VS(&functions); + re->re_fns = (void*)(&functions); /* * More complex setup, malloced things. */ - re->re_guts = VS(MALLOC(sizeof(struct guts))); + re->re_guts = (void*)(MALLOC(sizeof(struct guts))); if (re->re_guts == NULL) { return freev(v, REG_ESPACE); } @@ -434,7 +434,7 @@ compile( * Can sacrifice main NFA now, so use it as work area. */ - (DISCARD) optimize(v->nfa, debug); + (void) optimize(v->nfa, debug); CNOERR(); makesearch(v, v->nfa); CNOERR(); @@ -1920,10 +1920,10 @@ nfatree( assert(t != NULL && t->begin != NULL); if (t->left != NULL) { - (DISCARD) nfatree(v, t->left, f); + (void) nfatree(v, t->left, f); } if (t->right != NULL) { - (DISCARD) nfatree(v, t->right, f); + (void) nfatree(v, t->right, f); } return nfanode(v, t, f); diff --git a/generic/regcustom.h b/generic/regcustom.h index 681b97d..095385d 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,10 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define FUNCPTR(name, args) (*name)args -#define MALLOC(n) VS(attemptckalloc(n)) -#define FREE(p) ckfree(VS(p)) -#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n)) +#define MALLOC(n) (void*)(attemptckalloc(n)) +#define FREE(p) ckfree((void*)(p)) +#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is @@ -92,7 +91,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ -#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHR_MAX 0x10ffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ diff --git a/generic/regexec.c b/generic/regexec.c index 6d12827..128d439 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -44,7 +44,7 @@ struct sset { /* state set */ unsigned hash; /* hash of bitvector */ #define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) #define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ - memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) int flags; #define STARTER 01 /* the initial state set */ #define POSTSTATE 02 /* includes the goal state */ @@ -268,7 +268,7 @@ exec( if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { zapallsubs(pmatch, nmatch); n = (nmatch < v->nmatch) ? nmatch : v->nmatch; - memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); + memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); } /* diff --git a/generic/regguts.h b/generic/regguts.h index 1ac2465..b3dbaa4 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -49,41 +49,15 @@ #include <assert.h> #endif -/* voids */ -#ifndef VOID -#define VOID void /* for function return values */ -#endif -#ifndef DISCARD -#define DISCARD void /* for throwing values away */ -#endif -#ifndef PVOID -#define PVOID void * /* generic pointer */ -#endif -#ifndef VS -#define VS(x) ((void*)(x)) /* cast something to generic ptr */ -#endif -#ifndef NOPARMS -#define NOPARMS void /* for empty parm lists */ -#endif - -/* function-pointer declarator */ -#ifndef FUNCPTR -#if __STDC__ >= 1 -#define FUNCPTR(name, args) (*name)args -#else -#define FUNCPTR(name, args) (*name)() -#endif -#endif - /* memory allocation */ #ifndef MALLOC #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc(VS(p), n) +#define REALLOC(p, n) realloc(p, n) #endif #ifndef FREE -#define FREE(p) free(VS(p)) +#define FREE(p) free(p) #endif /* want size of a char in bits, and max value in bounded quantifiers */ @@ -96,7 +70,6 @@ */ #define NOTREACHED 0 -#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) @@ -408,7 +381,7 @@ struct subre { */ struct fns { - void FUNCPTR(free, (regex_t *)); + void (*free) (regex_t *); }; /* @@ -425,7 +398,7 @@ struct guts { struct cnfa search; /* for fast preliminary search */ int ntree; /* number of subre's, plus one */ struct colormap cmap; - int FUNCPTR(compare, (const chr *, const chr *, size_t)); + int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; diff --git a/generic/tcl.decls b/generic/tcl.decls index db1f892..0bc43e8 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -32,7 +32,7 @@ declare 0 { const char *version, const void *clientData) } declare 1 { - CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, + const char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } @@ -104,7 +104,7 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 { +declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) } declare 23 { @@ -119,7 +119,7 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -declare 26 { +declare 26 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) } declare 27 { @@ -152,9 +152,9 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 { +declare 36 {deprecated {No longer in use, changed to macro}} { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr) + const char *const *tablePtr, const char *msg, int flags, int *indexPtr) } declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) @@ -198,7 +198,7 @@ declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -declare 49 { +declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 { @@ -207,13 +207,13 @@ declare 50 { declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 { +declare 52 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewIntObj(int intValue) } declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -declare 54 { +declare 54 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewLongObj(long longValue) } declare 55 { @@ -222,7 +222,7 @@ declare 55 { declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -declare 57 { +declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 { @@ -235,13 +235,13 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 { +declare 61 {deprecated {No longer in use, changed to macro}} { void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -declare 63 { +declare 63 {deprecated {No longer in use, changed to macro}} { void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 { @@ -250,10 +250,10 @@ declare 64 { declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } -declare 66 { +declare 66 {deprecated {No longer in use, changed to macro}} { void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) } -declare 67 { +declare 67 {deprecated {No longer in use, changed to macro}} { void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length) } @@ -285,7 +285,7 @@ declare 75 { declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } -declare 77 { +declare 77 {deprecated {Use Tcl_UtfBackslash}} { char Tcl_Backslash(const char *src, int *readPtr) } declare 78 { @@ -306,7 +306,7 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, CONST84 char *const *argv) + char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { int Tcl_ConvertElement(const char *src, char *dst, int flags) @@ -318,7 +318,7 @@ declare 85 { declare 86 { int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv) + const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, @@ -352,7 +352,7 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -declare 95 { +declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) @@ -461,10 +461,10 @@ declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { - CONST84_RETURN char *Tcl_ErrnoId(void) + const char *Tcl_ErrnoId(void) } declare 128 { - CONST84_RETURN char *Tcl_ErrnoMsg(int err) + const char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) @@ -472,7 +472,7 @@ declare 129 { declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 { +declare 131 {deprecated {No longer in use, changed to macro}} { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { @@ -528,12 +528,12 @@ declare 147 { } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, - int *argcPtr, CONST84 char ***argvPtr) + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) } declare 149 { int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { @@ -558,7 +558,7 @@ declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan) + const char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -572,14 +572,14 @@ declare 159 { Tcl_CmdInfo *infoPtr) } declare 160 { - CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, + const char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - CONST84_RETURN char *Tcl_GetHostName(void) + const char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) @@ -622,20 +622,20 @@ declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { - CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) + const char *Tcl_GetStringResult(Tcl_Interp *interp) } -declare 175 { - CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, +declare 175 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 176 { - CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } declare 177 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } -declare 178 { +declare 178 {deprecated {No longer in use, changed to macro}} { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 { @@ -662,7 +662,7 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, CONST84 char *const *argv, + char *Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { @@ -685,7 +685,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, CONST84 char *const *argv) + char *Tcl_Merge(int argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -703,7 +703,7 @@ declare 196 { } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags) + const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { @@ -729,7 +729,7 @@ declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { - CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) + const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) @@ -765,7 +765,7 @@ declare 214 { } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, CONST84 char **endPtr) + const char **startPtr, const char **endPtr) } declare 216 { void Tcl_Release(ClientData clientData) @@ -779,8 +779,7 @@ declare 218 { declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { @@ -835,30 +834,30 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 { - CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, +declare 237 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } declare 238 { - CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { - CONST84_RETURN char *Tcl_SignalId(int sig) + const char *Tcl_SignalId(int sig) } declare 240 { - CONST84_RETURN char *Tcl_SignalMsg(int sig) + const char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr) + const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) + void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } declare 244 { void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -867,11 +866,10 @@ declare 244 { declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } -declare 247 { +declare 247 {deprecated {No longer in use, changed to macro}} { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -892,14 +890,14 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 { +declare 253 {deprecated {No longer in use, changed to macro}} { int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 { +declare 255 {deprecated {No longer in use, changed to macro}} { void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -911,7 +909,7 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 { +declare 258 {deprecated {No longer in use, changed to macro}} { int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags) } @@ -922,7 +920,7 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -declare 261 { +declare 261 {deprecated {No longer in use, changed to macro}} { ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } @@ -944,47 +942,47 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 { - CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, - CONST84 char **termPtr) + const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr) } -declare 271 { - CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +declare 271 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 272 { - CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, + const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } -declare 273 { +declare 273 {deprecated {No longer in use, changed to macro}} { int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version) } # TIP #268: The internally used new Require function is in slot 573. -declare 274 { - CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +declare 274 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { @@ -1058,7 +1056,7 @@ declare 293 { int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 294 { - void Tcl_ExitThread(int status) + TCL_NORETURN void Tcl_ExitThread(int status) } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1086,7 +1084,7 @@ declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding) + const char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) @@ -1147,22 +1145,22 @@ declare 319 { Tcl_QueuePosition position) } declare 320 { - Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) + int Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - Tcl_UniChar Tcl_UniCharToLower(int ch) + int Tcl_UniCharToLower(int ch) } declare 322 { - Tcl_UniChar Tcl_UniCharToTitle(int ch) + int Tcl_UniCharToTitle(int ch) } declare 323 { - Tcl_UniChar Tcl_UniCharToUpper(int ch) + int Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) + const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { int Tcl_UtfCharComplete(const char *src, int length) @@ -1171,16 +1169,16 @@ declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) + const char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) + const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - CONST84_RETURN char *Tcl_UtfNext(const char *src) + const char *Tcl_UtfNext(const char *src) } declare 331 { - CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) + const char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1213,10 +1211,10 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 { - CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) +declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { + const char *Tcl_GetDefaultEncodingDir(void) } -declare 342 { +declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { @@ -1265,7 +1263,7 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -declare 357 { +declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } @@ -1278,7 +1276,7 @@ declare 359 { } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) + Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, @@ -1291,7 +1289,7 @@ declare 362 { declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr) + const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1350,9 +1348,9 @@ declare 380 { int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -declare 382 { +declare 382 {deprecated {No longer in use, changed to macro}} { Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { @@ -1407,7 +1405,7 @@ declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { - CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) + const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( @@ -1547,12 +1545,12 @@ declare 434 { } # TIP#15 (math function introspection) dkf -declare 435 { +declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr) } -declare 436 { +declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } @@ -2325,6 +2323,49 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # +# TIP #456 +declare 631 { + Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, + const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +} + +# TIP #430 +declare 632 { + int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint, + const char *zipname, const char *passwd) +} +declare 633 { + int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint) +} +declare 634 { + Tcl_Obj *TclZipfs_TclLibrary(void) +} +declare 635 { + int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, + unsigned char *data, size_t datalen, int copy) +} + +# TIP #445 +declare 636 { + void Tcl_FreeIntRep(Tcl_Obj *objPtr) +} +declare 637 { + char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes) +} +declare 638 { + Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) +} +declare 639 { + void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr) +} +declare 640 { + int Tcl_HasStringRep(Tcl_Obj *objPtr) +} +# ----- BASELINE -- FOR -- 8.7.0 ----- # + ############################################################################## # Define the platform specific public Tcl interface. These functions are only @@ -2370,6 +2411,10 @@ export { void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { + void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + Tcl_Interp *interp) +} +export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tcl.h b/generic/tcl.h index 36001ca..35edebb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -38,8 +38,8 @@ extern "C" { * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.in (as above) + * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC @@ -53,13 +53,14 @@ extern "C" { */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 6 -#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 8 +#define TCL_MINOR_VERSION 7 +#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE +#define TCL_RELEASE_SERIAL 2 -#define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.8" +#define TCL_VERSION "8.7" +#define TCL_PATCH_LEVEL "8.7a2" +#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. @@ -89,6 +90,11 @@ extern "C" { # define JOIN1(a,b) a##b #endif +#ifndef TCL_THREADS +# define TCL_THREADS 1 +#endif +#endif /* !TCL_NO_DEPRECATED */ + /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. @@ -101,15 +107,10 @@ extern "C" { #ifndef RC_INVOKED /* - * Special macro to define mutexes, that doesn't do anything if we are not - * using threads. + * Special macro to define mutexes. */ -#ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; -#else -#define TCL_DECLARE_MUTEX(name) -#endif /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and @@ -135,14 +136,15 @@ extern "C" { */ #include <stdarg.h> -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#endif +#endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) +# define TCL_NOINLINE __attribute__ ((noinline)) # if defined(BUILD_tcl) || defined(BUILD_tk) # define TCL_NORETURN1 __attribute__ ((noreturn)) # else @@ -152,8 +154,10 @@ extern "C" { # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) +# define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ +# define TCL_NOINLINE /* nothing */ # endif # define TCL_NORETURN1 /* nothing */ #endif @@ -220,7 +224,7 @@ extern "C" { * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage - * class. If the symbol is beind declared for a static build or for use from a + * class. If the symbol is being declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of @@ -249,10 +253,9 @@ extern "C" { * New code should use prototypes. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # undef _ANSI_ARGS_ # define _ANSI_ARGS_(x) x -#endif /* * Definitions that allow this header file to be used either with or without @@ -262,34 +265,14 @@ extern "C" { #ifndef INLINE # define INLINE #endif - -#ifdef NO_CONST -# ifndef const -# define const -# endif -#endif #ifndef CONST # define CONST const #endif -#ifdef USE_NON_CONST -# ifdef USE_COMPAT_CONST -# error define at most one of USE_NON_CONST and USE_COMPAT_CONST -# endif -# define CONST84 -# define CONST84_RETURN -#else -# ifdef USE_COMPAT_CONST -# define CONST84 -# define CONST84_RETURN const -# else -# define CONST84 const -# define CONST84_RETURN const -# endif -#endif +#endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 -# define CONST86 CONST84 +# define CONST86 const #endif /* @@ -313,6 +296,7 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void @@ -328,23 +312,16 @@ typedef long LONG; */ #ifndef __VXWORKS__ -# ifndef NO_VOID -# define VOID void -# else -# define VOID char -# endif +# define VOID void #endif +#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA -# ifndef NO_VOID - typedef void *ClientData; -# else - typedef int *ClientData; -# endif + typedef void *ClientData; # define _CLIENTDATA #endif @@ -390,56 +367,45 @@ typedef long LONG; #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 -# ifdef __BORLANDC__ -# define TCL_LL_MODIFIER "L" -# else /* __BORLANDC__ */ -# define TCL_LL_MODIFIER "I64" -# endif /* __BORLANDC__ */ +# define TCL_LL_MODIFIER "I64" +# if defined(_WIN64) +# define TCL_Z_MODIFIER "I" +# endif # elif defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# define TCL_LL_MODIFIER "ll" +# define TCL_Z_MODIFIER "z" # else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ # include <limits.h> -# if (INT_MAX < LONG_MAX) +# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) # define TCL_WIDE_INT_IS_LONG 1 -# else -# define TCL_WIDE_INT_TYPE long long # endif # endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ -#ifdef TCL_WIDE_INT_IS_LONG -# undef TCL_WIDE_INT_TYPE -# define TCL_WIDE_INT_TYPE long -#endif /* TCL_WIDE_INT_IS_LONG */ + +#ifndef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long long +#endif /* !TCL_WIDE_INT_TYPE */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; -#ifdef TCL_WIDE_INT_IS_LONG -# define Tcl_WideAsLong(val) ((long)(val)) -# define Tcl_LongAsWide(val) ((long)(val)) -# define Tcl_WideAsDouble(val) ((double)((long)(val))) -# define Tcl_DoubleAsWide(val) ((long)((double)(val))) -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "l" -# endif /* !TCL_LL_MODIFIER */ -#else /* TCL_WIDE_INT_IS_LONG */ -/* - * The next short section of defines are only done when not running on Windows - * or some other strange platform. - */ -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" -# endif /* !TCL_LL_MODIFIER */ -# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) -# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) -# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) -# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#endif /* TCL_WIDE_INT_IS_LONG */ +#ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "ll" +#endif /* !TCL_LL_MODIFIER */ +#ifndef TCL_Z_MODIFIER +# if defined(__GNUC__) && !defined(_WIN32) +# define TCL_Z_MODIFIER "z" +# else +# define TCL_Z_MODIFIER "" +# endif +#endif /* !TCL_Z_MODIFIER */ +#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) +#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) +#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) +#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if defined(_WIN32) # ifdef __BORLANDC__ @@ -495,37 +461,15 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; */ typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 { /* TIP #330: Strongly discourage extensions from using the string * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else char *resultDontUse; /* Don't use in extensions! */ void (*freeProcDontUse) (char *); /* Don't use in extensions! */ -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else int errorLineDontUse; /* Don't use in extensions! */ -#endif } -#endif /* TCL_NO_DEPRECATED */ +#endif /* !TCL_NO_DEPRECATED */ Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; @@ -675,7 +619,9 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_RESULT_SIZE 200 +#endif /* *---------------------------------------------------------------------------- @@ -691,6 +637,7 @@ typedef struct stat *Tcl_OldStat_; * Argument descriptors for math function callbacks in expressions: */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; @@ -702,6 +649,10 @@ typedef struct Tcl_Value { double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; +#else +#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */ +#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */ +#endif /* * Forward declaration of Tcl_Obj to prevent an error when the forward @@ -722,10 +673,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); typedef void (Tcl_CloseProc) (ClientData data); typedef void (Tcl_CmdDeleteProc) (ClientData clientData); typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); + int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, CONST84 char *argv[]); + ClientData cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); @@ -762,7 +713,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, - CONST84 char *part1, CONST84 char *part2, int flags); + const char *part1, const char *part2, int flags); typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, @@ -800,6 +751,29 @@ typedef struct Tcl_ObjType { } Tcl_ObjType; /* + * The following structure stores an internal representation (intrep) for + * a Tcl value. An intrep is associated with an Tcl_ObjType when both + * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern + * the handling of the intrep. + */ + +typedef union Tcl_ObjIntRep { /* The internal representation: */ + long longValue; /* - an long integer value. */ + double doubleValue; /* - a double-precision floating value. */ + void *otherValuePtr; /* - another, type-specific value, */ + /* not used internally any more. */ + Tcl_WideInt wideValue; /* - an integer value >= 64bits */ + struct { /* - internal rep as two pointers. */ + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { /* - internal rep as a pointer and a long, */ + void *ptr; /* not used internally any more. */ + unsigned long value; + } ptrAndLongRep; +} Tcl_ObjIntRep; + +/* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. @@ -824,26 +798,7 @@ typedef struct Tcl_Obj { * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - union { /* The internal representation: */ - long longValue; /* - an long integer value. */ - double doubleValue; /* - a double-precision floating value. */ - void *otherValuePtr; /* - another, type-specific value, - not used internally any more. */ - Tcl_WideInt wideValue; /* - a long long value. */ - struct { /* - internal rep as two pointers. - * the main use of which is a bignum's - * tightly packed fields, where the alloc, - * used and signum flags are packed into - * ptr2 with everything else hung off ptr1. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, - not used internally any more. */ - void *ptr; - unsigned long value; - } ptrAndLongRep; - } internalRep; + Tcl_ObjIntRep internalRep; /* The internal representation: */ } Tcl_Obj; /* @@ -872,7 +827,7 @@ typedef struct Tcl_SavedResult { char *appendResult; int appendAvl; int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; + char resultSpace[200+1]; } Tcl_SavedResult; /* @@ -998,7 +953,9 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#define Tcl_DStringTrunc Tcl_DStringSetLength +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define Tcl_DStringTrunc Tcl_DStringSetLength +#endif /* !TCL_NO_DEPRECATED */ /* * Definitions for the maximum number of digits of precision that may be @@ -1124,9 +1081,9 @@ typedef struct Tcl_DString { * give the flag) */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_PARSE_PART1 0x400 -#endif +#endif /* !TCL_NO_DEPRECATED */ /* * Types for linked variables: @@ -1142,8 +1099,13 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 +#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) +#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) +#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) +#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 +#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 @@ -1153,29 +1115,21 @@ typedef struct Tcl_DString { * Forward declarations of Tcl_HashTable and related types. */ +#ifndef TCL_HASH_TYPE +# define TCL_HASH_TYPE unsigned +#endif + typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); /* - * This flag controls whether the hash table stores the hash of a key, or - * recalculates it. There should be no reason for turning this flag off as it - * is completely binary and source compatible unless you directly access the - * bucketPtr member of the Tcl_HashTableEntry structure. This member has been - * removed and the space used to store the hash value. - */ - -#ifndef TCL_HASH_KEY_STORE_HASH -# define TCL_HASH_KEY_STORE_HASH 1 -#endif - -/* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ @@ -1184,15 +1138,9 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ -#if TCL_HASH_KEY_STORE_HASH void *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ -#else - Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first - * entry in this entry's chain: used for - * deleting the entry. */ -#endif ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ @@ -1352,8 +1300,8 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1486,14 +1434,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (ClientData instanceData, - CONST84 char *buf, int toWrite, int *errorCodePtr); + const char *buf, int toWrite, int *errorCodePtr); typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, - Tcl_Interp *interp, CONST84 char *optionName, + Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, @@ -2200,16 +2148,16 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values should be 3, 4 or 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or - * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values are 4 and 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, + * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode * is the default and recommended mode. UCS-4 is experimental and not * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* @@ -2271,6 +2219,8 @@ typedef struct mp_int mp_int; #define MP_INT_DECLARED typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED +typedef unsigned TCL_WIDE_INT_TYPE mp_word; +#define MP_WORD_DECLARED /* *---------------------------------------------------------------------------- @@ -2381,6 +2331,20 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, /* *---------------------------------------------------------------------------- + * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] + */ +#define TCL_TCPSERVER_REUSEADDR (1<<0) +#define TCL_TCPSERVER_REUSEPORT (1<<1) + +/* + * Constants for special int-typed values, see TIP #494 + */ + +#define TCL_IO_FAILURE (-1) +#define TCL_AUTO_LENGTH (-1) + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ @@ -2390,13 +2354,10 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the - * stubs tables. - * - * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different - * value since the stubs tables don't match. + * stubs tables. If TCL_UTF_MAX>4 use a different value. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF + (TCL_UTF_MAX>4)) /* * The following function is required to be defined in all stubs aware @@ -2406,22 +2367,38 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact); + int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); - -/* - * When not using stubs, make it a macro. - */ - -#ifndef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, exact) +#if defined(_WIN32) + TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); +#else +# define Tcl_ConsolePanic ((Tcl_PanicProc *)0) #endif -/* - * TODO - tommath stubs export goes here! - */ +#ifdef USE_TCL_STUBS +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#else +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif +#endif /* * Public functions that are not accessible via the stubs table. @@ -2429,12 +2406,15 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_CreateInterp)())) + (((Tcl_SetPanicProc)(Tcl_ConsolePanic), Tcl_CreateInterp)())) EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +#ifndef _WIN32 +EXTERN int TclZipfs_AppHook(int *argc, char ***argv); +#endif /* *---------------------------------------------------------------------------- @@ -2541,22 +2521,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # undef Tcl_NewBooleanObj # define Tcl_NewBooleanObj(val) \ - Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) + Tcl_DbNewLongObj((val)!=0, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# undef Tcl_NewIntObj -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) -# undef Tcl_NewLongObj -# define Tcl_NewLongObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) @@ -2595,31 +2569,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); /* *---------------------------------------------------------------------------- - * Macros that eliminate the overhead of the thread synchronization functions - * when compiling without thread support. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#define Tcl_MutexLock(mutexPtr) -#undef Tcl_MutexUnlock -#define Tcl_MutexUnlock(mutexPtr) -#undef Tcl_MutexFinalize -#define Tcl_MutexFinalize(mutexPtr) -#undef Tcl_ConditionNotify -#define Tcl_ConditionNotify(condPtr) -#undef Tcl_ConditionWait -#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) -#undef Tcl_ConditionFinalize -#define Tcl_ConditionFinalize(condPtr) -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibility. @@ -2634,7 +2587,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define panic Tcl_Panic #endif # define panicVA Tcl_PanicVA -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------------- @@ -2645,6 +2597,8 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); extern Tcl_AppInitProc Tcl_AppInit; +#endif /* !TCL_NO_DEPRECATED */ + #endif /* RC_INVOKED */ /* diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index cda1f38..df1718b 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -22,7 +22,7 @@ */ #include "tclInt.h" -#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) +#if !TCL_THREADS || !defined(USE_THREAD_ALLOC) #if USE_TCLALLOC @@ -32,7 +32,7 @@ */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; +typedef size_t caddr_t; #endif /* @@ -56,7 +56,7 @@ union overhead { unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ + size_t size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; @@ -121,7 +121,7 @@ static struct block bigBlocks={ /* Big blocks aren't suballocated. */ * variable. */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; @@ -133,7 +133,7 @@ static int allocInit = 0; * a given block size. */ -static unsigned int numMallocs[NBUCKETS+1]; +static size_t numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) @@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore(int bucket); +static void MoreCore(size_t bucket); /* *------------------------------------------------------------------------- @@ -171,7 +171,7 @@ TclInitAlloc(void) { if (!allocInit) { allocInit = 1; -#ifdef TCL_THREADS +#if TCL_THREADS allocMutexPtr = Tcl_GetAllocMutex(); #endif } @@ -254,7 +254,7 @@ TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; - register long bucket; + register size_t bucket; register unsigned amount; struct block *bigBlockPtr = NULL; @@ -385,12 +385,12 @@ TclpAlloc( static void MoreCore( - int bucket) /* What bucket to allocat to. */ + size_t bucket) /* What bucket to allocate to. */ { register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ + register size_t size; /* size of desired block */ + size_t amount; /* amount to allocate */ + size_t numBlocks; /* how many blocks we get */ struct block *blockPtr; /* @@ -398,14 +398,14 @@ MoreCore( * VAX, I think) or for a negative arg. */ - size = 1 << (bucket + 3); + size = ((size_t)1) << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -448,7 +448,7 @@ void TclpFree( char *oldPtr) /* Pointer to memory to free. */ { - register long size; + register size_t size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -518,7 +518,7 @@ TclpRealloc( union overhead *overPtr; struct block *bigBlockPtr; int expensive; - unsigned long maxSize; + size_t maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); @@ -645,29 +645,29 @@ void mstats( char *s) /* Where to write info. */ { - register int i, j; + register unsigned int i, j; register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + size_t totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); + fprintf(stderr, " %u", j); } - totalFree += j * (1 << (i + 3)); + totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); + fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 120fd9a..5ac9a55 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -32,6 +32,7 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" +#include <assert.h> /* * Structure that represents a range of instructions in the bytecode. @@ -271,15 +272,12 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); @@ -318,6 +316,9 @@ static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, * Tcl_ObjType that describes bytecode emitted by the assembler. */ +static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; +static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; + static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ @@ -847,15 +848,15 @@ CompileAssembleObj( const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &assembleCodeType) { + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + + if (codePtr) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) @@ -869,7 +870,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - FreeAssembleCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); } /* @@ -894,15 +895,13 @@ CompileAssembleObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &assembleCodeType; + codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1304,8 +1303,8 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1470,8 +1469,8 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); /* * Assumes that PUSH is the first slot! @@ -1565,7 +1564,7 @@ AssembleOneLine( * Add the (label_name, address) pair to the hash table. */ - if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { + if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { goto cleanup; } break; @@ -1744,7 +1743,7 @@ AssembleOneLine( default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - Tcl_GetString(instNameObj)); + TclGetString(instNameObj)); } status = TCL_OK; @@ -2007,15 +2006,15 @@ CreateMirrorJumpTable( DEBUG_PRINT("jump table {\n"); for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), - Tcl_GetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), + DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), + TclGetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", - Tcl_GetString(objv[i]))); + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; @@ -2248,23 +2247,24 @@ GetListIndexOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ + Tcl_Obj *value; + int status; - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + /* General operand validity check */ + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { return TCL_ERROR; } + /* Convert to an integer, advance to the next token and return. */ /* - * Convert to an integer, advance to the next token and return. + * NOTE: Indexing a list with an index before it yields the + * same result as indexing after it, and might be more easily portable + * when list size limits grow. */ + status = TclIndexEncode(interp, value, + TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); - status = TclGetIntForIndex(interp, intObj, -2, result); - Tcl_DecrRefCount(intObj); + Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); return status; } @@ -2310,7 +2310,7 @@ FindLocalVar( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; @@ -2823,7 +2823,7 @@ CalculateJumpRelocations( if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); if (entry == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, bbPtr->jumpTarget); @@ -2904,10 +2904,10 @@ CheckJumpTableLabels( symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); + TclGetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), (valEntryPtr != NULL)); + TclGetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; @@ -2945,9 +2945,9 @@ ReportUndefinedLabel( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", Tcl_GetString(jumpTarget))); + "undefined label \"%s\"", TclGetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - Tcl_GetString(jumpTarget), NULL); + TclGetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -3030,7 +3030,7 @@ FillInJumpOffsets( bbPtr = bbPtr->successor1) { if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; @@ -3102,17 +3102,17 @@ ResolveJumpTableTargets( symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); + DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); + TclGetString(symbolObj)); jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), jumpTargetBBPtr, + TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); Tcl_SetHashValue(realJumpEntryPtr, @@ -3484,7 +3484,7 @@ StackCheckBasicBlock( if (result == TCL_OK && blockPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(blockPtr->jumpTarget)); + TclGetString(blockPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3501,7 +3501,7 @@ StackCheckBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); + TclGetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3563,7 +3563,7 @@ StackCheckExit( * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); + litIndex = TclRegisterLiteral(envPtr, "", 0, 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. @@ -3806,7 +3806,7 @@ ProcessCatchesInBasicBlock( } if (result == TCL_OK && bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -3822,7 +3822,7 @@ ProcessCatchesInBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); + TclGetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -4126,7 +4126,7 @@ StackFreshCatches( range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(catch->jumpTarget)); + TclGetString(catch->jumpTarget)); if (entryPtr == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); @@ -4268,7 +4268,7 @@ AddBasicBlockRangeToErrorInfo( Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); + TclSetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); @@ -4333,13 +4333,12 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e2319d2..75c467b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -71,7 +71,18 @@ typedef struct { } CancelInfo; static Tcl_HashTable cancelTable; static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(cancelLock) +TCL_DECLARE_MUTEX(cancelLock); + +/* + * Table used to map command implementation functions to a human-readable type + * name, for [info type]. The keys in the table are function addresses, and + * the values in the table are static char* containing strings in Tcl's + * internal encoding (almost UTF-8). + */ + +static Tcl_HashTable commandTypeTable; +static int commandTypeInit = 0; +TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts @@ -94,6 +105,7 @@ TCL_DECLARE_MUTEX(cancelLock) * Static functions in this file: */ +static Tcl_ObjCmdProc BadEnsembleSubcommand; static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, const char *oldName, const char *newName, int flags); @@ -114,10 +126,11 @@ static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; static Tcl_ObjCmdProc ExprDoubleFunc; -static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; @@ -130,8 +143,10 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; +#if !defined(TCL_NO_DEPRECATED) static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); +#endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); @@ -192,6 +207,24 @@ typedef struct { * it for it. Defined in tclInt.h. */ /* + * The following struct states that the command it talks about (a subcommand + * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an + * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these + * structs.) Alas, we can't sensibly just store the information directly in + * the commands. + */ + +typedef struct { + const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for + * the end of the list of commands to hide. */ + const char *commandName; /* The name of the command within the + * ensemble. If this is NULL, we want to also + * make the overall command be hidden, an ugly + * hack because it is expected by security + * policies in the wild. */ +} UnsafeEnsembleInfo; + +/* * The built-in commands, and the functions that implement them: */ @@ -203,7 +236,7 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, @@ -292,6 +325,68 @@ static const CmdInfo builtInCmds[] = { }; /* + * Information about which pieces of ensembles to hide when making an + * interpreter safe: + */ + +static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { + /* [encoding] has two unsafe commands. Assumed by older security policies + * to be overall unsafe; it isn't but... */ + {"encoding", NULL}, + {"encoding", "dirs"}, + {"encoding", "system"}, + /* [file] has MANY unsafe commands! Assumed by older security policies to + * be overall unsafe; it isn't but... */ + {"file", NULL}, + {"file", "atime"}, + {"file", "attributes"}, + {"file", "copy"}, + {"file", "delete"}, + {"file", "dirname"}, + {"file", "executable"}, + {"file", "exists"}, + {"file", "extension"}, + {"file", "isdirectory"}, + {"file", "isfile"}, + {"file", "link"}, + {"file", "lstat"}, + {"file", "mtime"}, + {"file", "mkdir"}, + {"file", "nativename"}, + {"file", "normalize"}, + {"file", "owned"}, + {"file", "readable"}, + {"file", "readlink"}, + {"file", "rename"}, + {"file", "rootname"}, + {"file", "size"}, + {"file", "stat"}, + {"file", "tail"}, + {"file", "tempfile"}, + {"file", "type"}, + {"file", "volumes"}, + {"file", "writable"}, + /* [info] has two unsafe commands */ + {"info", "cmdtype"}, + {"info", "nameofexecutable"}, + /* [tcl::process] has ONLY unsafe commands! */ + {"process", "list"}, + {"process", "status"}, + {"process", "purge"}, + {"process", "autopurge"}, + /* [zipfs] has MANY unsafe commands! */ + {"zipfs", "lmkimg"}, + {"zipfs", "lmkzip"}, + {"zipfs", "mkimg"}, + {"zipfs", "mkkey"}, + {"zipfs", "mkzip"}, + {"zipfs", "mount"}, + {"zipfs", "mount_data"}, + {"zipfs", "unmount"}, + {NULL, NULL} +}; + +/* * Math functions. All are safe. */ @@ -312,7 +407,7 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "cos", ExprUnaryFunc, (ClientData) cos }, { "cosh", ExprUnaryFunc, (ClientData) cosh }, { "double", ExprDoubleFunc, NULL }, - { "entier", ExprEntierFunc, NULL }, + { "entier", ExprIntFunc, NULL }, { "exp", ExprUnaryFunc, (ClientData) exp }, { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, @@ -321,6 +416,8 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, @@ -425,6 +522,13 @@ TclFinalizeEvaluation(void) cancelTableInitialized = 0; } Tcl_MutexUnlock(&cancelLock); + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_DeleteHashTable(&commandTypeTable); + commandTypeInit = 0; + } + Tcl_MutexUnlock(&commandTypeLock); } /* @@ -498,9 +602,23 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); cancelTableInitialized = 1; } + Tcl_MutexUnlock(&cancelLock); } + if (commandTypeInit == 0) { + TclRegisterCommandTypeName(TclObjInterpProc, "proc"); + TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); + TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclSlaveObjCmd, "slave"); + TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); + TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); + TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); + TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); + TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); + } + /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl @@ -510,7 +628,11 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else iPtr->result = iPtr->resultSpace; +#endif iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); @@ -570,23 +692,26 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; +#ifndef TCL_NO_DEPRECATED iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; +#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ +#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else { + } else +#endif iPtr->packagePrefer = PKG_PREFER_LATEST; - } iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 0; + iPtr->compileEpoch = 1; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -601,7 +726,9 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -734,7 +861,7 @@ Tcl_CreateInterp(void) * cache was already initialised by the call to alloc the interp struct. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; @@ -804,6 +931,7 @@ Tcl_CreateInterp(void) TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through @@ -939,14 +1067,16 @@ Tcl_CreateInterp(void) * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); +#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads @@ -965,11 +1095,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } /* @@ -979,6 +1109,9 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + } + if (TclZipfs_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -997,6 +1130,71 @@ DeleteOpCmdClientData( } /* + * --------------------------------------------------------------------- + * + * TclRegisterCommandTypeName, TclGetCommandTypeName -- + * + * Command type registration and lookup mechanism. Everything is keyed by + * the Tcl_ObjCmdProc for the command, and that is used as the *key* into + * the hash table that maps to constant strings that are names. (It is + * recommended that those names be ASCII.) + * + * --------------------------------------------------------------------- + */ + +void +TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr) +{ + Tcl_HashEntry *hPtr; + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit == 0) { + Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); + commandTypeInit = 1; + } + if (nameStr != NULL) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&commandTypeTable, + (void *) implementationProc, &isNew); + Tcl_SetHashValue(hPtr, (void *) nameStr); + } else { + hPtr = Tcl_FindHashEntry(&commandTypeTable, + (void *) implementationProc); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); +} + +const char * +TclGetCommandTypeName( + Tcl_Command command) +{ + Command *cmdPtr = (Command *) command; + void *procPtr = cmdPtr->objProc; + const char *name = "native"; + + if (procPtr == NULL) { + procPtr = cmdPtr->nreProc; + } + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); + + if (hPtr && Tcl_GetHashValue(hPtr)) { + name = (const char *) Tcl_GetHashValue(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); + + return name; +} + +/* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- @@ -1017,6 +1215,7 @@ TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { register const CmdInfo *cmdInfoPtr; + register const UnsafeEnsembleInfo *unsafePtr; if (interp == NULL) { return TCL_ERROR; @@ -1026,12 +1225,83 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } - TclMakeEncodingCommandSafe(interp); /* Ugh! */ - TclMakeFileCommandSafe(interp); /* Ugh! */ + + for (unsafePtr = unsafeEnsembleCommands; + unsafePtr->ensembleNsName; unsafePtr++) { + if (unsafePtr->commandName) { + /* + * Hide an ensemble subcommand. + */ + + Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", + unsafePtr->ensembleNsName, unsafePtr->commandName); + Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", + unsafePtr->ensembleNsName, unsafePtr->commandName); + + if (TclRenameCommand(interp, TclGetString(cmdName), + "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", + TclGetString(hideName)) != TCL_OK) { + Tcl_Panic("problem making '%s %s' safe: %s", + unsafePtr->ensembleNsName, unsafePtr->commandName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, TclGetString(cmdName), + BadEnsembleSubcommand, (ClientData) unsafePtr, NULL); + TclDecrRefCount(cmdName); + TclDecrRefCount(hideName); + } else { + /* + * Hide an ensemble main command (for compatibility). + */ + + if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName, + unsafePtr->ensembleNsName) != TCL_OK) { + Tcl_Panic("problem making '%s' safe: %s", + unsafePtr->ensembleNsName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + } + } + return TCL_OK; } /* + *---------------------------------------------------------------------- + * + * BadEnsembleSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * ensembles are unsafe (the real implementations of the subcommands are + * hidden). The clientData is description of what was hidden. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadEnsembleSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const UnsafeEnsembleInfo *infoPtr = clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of %s", + infoPtr->commandName, infoPtr->ensembleNsName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} + +/* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- @@ -1062,7 +1332,7 @@ Tcl_CallWhenDeleted( Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); + Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = ckalloc(sizeof(AssocData)); @@ -1534,10 +1804,12 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } +#ifndef TCL_NO_DEPRECATED if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } +#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -1635,7 +1907,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); + ckfree(iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2087,13 +2359,13 @@ Tcl_CreateCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); @@ -2234,74 +2506,97 @@ Tcl_CreateObjCommand( * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ +) { Interp *iPtr = (Interp *) interp; - ImportRef *oldRefPtr = NULL; Namespace *nsPtr; - Command *cmdPtr; - Tcl_HashEntry *hPtr; const char *tail; - int isNew = 0, deleted = 0; - ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; } /* - * If the command name we seek to create already exists, we need to - * delete that first. That can be tricky in the presence of traces. - * Loop until we no longer find an existing command in the way, or - * until we've deleted one command and that didn't finish the job. + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. */ - while (1) { - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. - */ + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; - if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; - } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + proc, clientData, deleteProc); +} - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); +Tcl_Command +TclCreateObjCommandInNs( + Tcl_Interp *interp, + const char *cmdName, /* Name of command, without any namespace + * components. */ + Tcl_Namespace *namespace, /* The namespace to create the command in */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + int deleted = 0, isNew = 0; + Command *cmdPtr; + ImportRef *oldRefPtr = NULL; + ImportedCmdData *dataPtr; + Tcl_HashEntry *hPtr; + Namespace *nsPtr = (Namespace *) namespace; + + /* + * If the command name we seek to create already exists, we need to delete + * that first. That can be tricky in the presence of traces. Loop until we + * no longer find an existing command in the way, or until we've deleted + * one command and that didn't finish the job. + */ - if (isNew || deleted) { + while (1) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } + + /* + * An existing command conflicts. Try to delete it. + */ - /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); /* - * [***] 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. + * [***] 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 @@ -2325,7 +2620,16 @@ Tcl_CreateObjCommand( cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } + /* + * Make sure namespace doesn't get deallocated. + */ + + cmdPtr->nsPtr->refCount++; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + nsPtr = (Namespace *) TclEnsureNamespace(interp, + (Tcl_Namespace *) cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; @@ -2334,12 +2638,11 @@ Tcl_CreateObjCommand( TclCleanupCommandMacro(cmdPtr); deleted = 1; } - if (!isNew) { /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). */ ckfree(Tcl_GetHashValue(hPtr)); @@ -2356,7 +2659,7 @@ Tcl_CreateObjCommand( * commands. */ - TclInvalidateCmdLiteral(interp, tail, nsPtr); + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); /* * The list of command exported from the namespace might have changed. @@ -2394,6 +2697,7 @@ Tcl_CreateObjCommand( cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; @@ -2445,7 +2749,7 @@ TclInvokeStringCommand( TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2586,10 +2890,6 @@ TclRenameCommand( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -2598,10 +2898,14 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - result = TCL_OK; - goto done; + return TCL_OK; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically @@ -2699,7 +3003,7 @@ TclRenameCommand( } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -3066,13 +3370,6 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - - /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such @@ -3094,13 +3391,21 @@ Tcl_DeleteCommandFromToken( Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + return 0; } /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and - * delete procs may try to delete the command themsevles. This flag + * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ @@ -3113,6 +3418,7 @@ Tcl_DeleteCommandFromToken( */ cmdPtr->nsPtr->refCount++; + if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); @@ -3198,6 +3504,13 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; } /* @@ -3444,8 +3757,7 @@ TclCleanupCommand( register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - cmdPtr->refCount--; - if (cmdPtr->refCount <= 0) { + if (cmdPtr->refCount-- <= 1) { ckfree(cmdPtr); } } @@ -3472,6 +3784,7 @@ TclCleanupCommand( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be @@ -3522,7 +3835,7 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - ClientData clientData, /* Ponter to OldMathFuncData describing the + ClientData clientData, /* Pointer to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ @@ -3554,9 +3867,14 @@ OldMathFuncProc( valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN - if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { - d = valuePtr->internalRep.doubleValue; - result = TCL_OK; + if (result != TCL_OK) { + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(valuePtr, &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + result = TCL_OK; + } } #endif if (result != TCL_OK) { @@ -3567,7 +3885,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } @@ -3635,7 +3953,7 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); + TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { @@ -3803,6 +4121,7 @@ Tcl_ListMathFuncs( return result; } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -3987,7 +4306,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4086,7 +4405,7 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ @@ -4410,7 +4729,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Interp *iPtr = (Interp *) interp; +#endif /* !defined(TCL_NO_DEPRECATED) */ NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; @@ -4424,9 +4745,11 @@ TclNRRunCallbacks( * are for NR function calls, and those are Tcl_Obj based. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* This is the trampoline. */ @@ -4600,7 +4923,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + cmdString = TclGetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4744,9 +5067,9 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4798,7 +5121,7 @@ TEOV_RunLeaveTraces( Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ @@ -4887,6 +5210,7 @@ Tcl_EvalTokensStandard( NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -4934,6 +5258,7 @@ Tcl_EvalTokens( Tcl_ResetResult(interp); return resPtr; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5624,8 +5949,7 @@ TclArgumentRelease( } cfwPtr = Tcl_GetHashValue(hPtr); - cfwPtr->refCount--; - if (cfwPtr->refCount > 0) { + if (cfwPtr->refCount-- > 1) { continue; } @@ -5832,7 +6156,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { + if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { return; } @@ -5890,6 +6214,7 @@ TclArgumentGet( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_Eval int Tcl_Eval( @@ -5942,6 +6267,7 @@ Tcl_GlobalEvalObj( { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6095,7 +6421,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - ListObjGetElements(listPtr, objc, objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -6163,7 +6489,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6194,7 +6520,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6451,8 +6777,7 @@ Tcl_ExprLongObj( resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } - case TCL_NUMBER_LONG: - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; @@ -6742,11 +7067,10 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + const char *message = TclGetString(objPtr); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); + Tcl_AddObjErrorInfo(interp, message, objPtr->length); Tcl_DecrRefCount(objPtr); } @@ -6769,6 +7093,7 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( @@ -6778,6 +7103,7 @@ Tcl_AddErrorInfo( { Tcl_AddObjErrorInfo(interp, message, -1); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6818,7 +7144,8 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + if (*(iPtr->result) != 0) { /* * The interp's string result is set, apparently by some extension * making a deprecated direct write to it. That extension may @@ -6828,9 +7155,9 @@ Tcl_AddObjErrorInfo( */ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { + } else +#endif /* !defined(TCL_NO_DEPRECATED) */ iPtr->errorInfo = iPtr->objResultPtr; - } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6893,7 +7220,7 @@ Tcl_VarEvalVA( Tcl_DStringAppend(&buf, string, -1); } - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); Tcl_DStringFree(&buf); return result; } @@ -6950,6 +7277,7 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GlobalEval int Tcl_GlobalEval( @@ -6963,10 +7291,11 @@ Tcl_GlobalEval( savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_Eval(interp, command); + result = Tcl_EvalEx(interp, command, -1, 0); iPtr->varFramePtr = savedVarFramePtr; return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -7104,9 +7433,13 @@ ExprCeilFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7140,9 +7473,13 @@ ExprFloorFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7276,9 +7613,13 @@ ExprSqrtFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7319,10 +7660,14 @@ ExprUnaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7379,10 +7724,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d1 = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d1 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7390,10 +7739,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { - d2 = objv[2]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d2 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7424,28 +7777,30 @@ ExprAbsFunc( return TCL_ERROR; } - if (type == TCL_NUMBER_LONG) { - long l = *((const long *) ptr); + if (type == TCL_NUMBER_INT) { + Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - if (l > (long)0) { + if (l > (Tcl_WideInt)0) { goto unChanged; - } else if (l == (long)0) { - const char *string = objv[1]->bytes; - if (string) { - while (*string != '0') { - if (*string == '-') { + } else if (l == (Tcl_WideInt)0) { + if (TclHasStringRep(objv[1])) { + int numBytes; + const char *bytes = TclGetStringFromObj(objv[1], &numBytes); + + while (numBytes) { + if (*bytes == '-') { Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } - string++; + bytes++; numBytes--; } } goto unChanged; - } else if (l == LONG_MIN) { - TclBNInitBignumFromLong(&big, l); + } else if (l == WIDE_MIN) { + TclInitBignumFromWideInt(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } @@ -7469,24 +7824,8 @@ ExprAbsFunc( return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - - if (w >= (Tcl_WideInt)0) { - goto unChanged; - } - if (w == LLONG_MIN) { - TclBNInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - return TCL_OK; - } -#endif - if (type == TCL_NUMBER_BIG) { - if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); @@ -7549,7 +7888,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (objv[1]->typePtr == &tclDoubleType) { + if (Tcl_FetchIntRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } @@ -7561,7 +7900,7 @@ ExprDoubleFunc( } static int -ExprEntierFunc( +ExprIntFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ @@ -7582,7 +7921,7 @@ ExprEntierFunc( if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { + if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { @@ -7592,9 +7931,9 @@ ExprEntierFunc( Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - long result = (long) d; + Tcl_WideInt result = (Tcl_WideInt) d; - Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } } @@ -7617,71 +7956,89 @@ ExprEntierFunc( } static int -ExprIntFunc( +ExprWideFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - long iResult; - Tcl_Obj *objPtr; - if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - objPtr = Tcl_GetObjResult(interp); - if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { - /* - * Truncate the bignum; keep only bits in long range. - */ - - mp_int big; + Tcl_WideInt wResult; - Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &iResult); - Tcl_DecrRefCount(objPtr); + if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } +/* + * Common implmentation of max() and min(). + */ static int -ExprWideFunc( +ExprMaxMinFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ { - Tcl_WideInt wResult; - Tcl_Obj *objPtr; + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; - if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - objPtr = Tcl_GetObjResult(interp); - if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { - /* - * Truncate the bignum; keep only bits in wide int range. - */ - - mp_int big; + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ - Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetWideIntFromObj(NULL, objPtr, &wResult); - Tcl_DecrRefCount(objPtr); + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + + Tcl_SetObjResult(interp, res); return TCL_OK; } static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} + +static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7704,8 +8061,8 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) + * To ensure different seeds in different threads (bug #416643), + * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -7714,7 +8071,7 @@ ExprRandFunc( * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= (unsigned long) 0x7fffffff; + iPtr->randSeed &= 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -7858,7 +8215,7 @@ ExprSrandFunc( Tcl_Obj *const *objv) /* Parameter vector. */ { Interp *iPtr = (Interp *) interp; - long i = 0; /* Initialized to avoid compiler warning. */ + Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. @@ -7869,20 +8226,8 @@ ExprSrandFunc( return TCL_ERROR; } - if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { - Tcl_Obj *objPtr; - mp_int big; - - if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { - /* TODO: more ::errorInfo here? or in caller? */ - return TCL_ERROR; - } - - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &i); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { + return TCL_ERROR; } /* @@ -7891,8 +8236,7 @@ ExprSrandFunc( */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = i; - iPtr->randSeed &= (unsigned long) 0x7fffffff; + iPtr->randSeed = (long) w & 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -7930,7 +8274,7 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = Tcl_GetString(objv[0]); + const char *name = TclGetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { @@ -8164,7 +8508,26 @@ Tcl_NRCreateCommand( * this command is deleted. */ { Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + Tcl_CreateObjCommand(interp, cmdName, proc, clientData, + deleteProc); + + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +Tcl_Command +TclNRCreateCommandInNs( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) +{ + Command *cmdPtr = (Command *) + TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8268,7 +8631,6 @@ TclPushTailcallPoint( TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); ((Interp *) interp)->numLevels++; } - /* *---------------------------------------------------------------------- @@ -8304,7 +8666,6 @@ TclSetTailcall( } runPtr->data[1] = listPtr; } - /* *---------------------------------------------------------------------- @@ -8362,25 +8723,18 @@ TclNRTailcallObjCmd( if (objc > 1) { Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; /* The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); - } + listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } - /* *---------------------------------------------------------------------- @@ -8448,7 +8802,6 @@ TclNRReleaseValues( } return result; } - void Tcl_NRAddCallback( @@ -8893,7 +9246,7 @@ TclNRInterpCoroutine( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", - Tcl_GetString(objv[0]))); + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } @@ -8954,9 +9307,9 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { @@ -8964,34 +9317,21 @@ TclNRCoroutineObjCmd( return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -9003,16 +9343,9 @@ TclNRCoroutineObjCmd( corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; @@ -9073,7 +9406,7 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* insure that the command is looked up in the correct namespace */ + /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bb918f2..96adff0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -15,6 +15,7 @@ #include "tommath.h" #include <math.h> +#include <assert.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -56,9 +57,12 @@ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); +static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, @@ -155,35 +159,108 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object type represents an array of bytes. An array of bytes - * is not equivalent to an internationalized string. Conceptually, a string is - * an array of 16-bit quantities organized as a sequence of properly formed - * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. - * Accessor functions are provided to convert a ByteArray to a String or a - * String to a ByteArray. Two or more consecutive bytes in an array of bytes - * may look like a single UTF-8 character if the array is casually treated as - * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one map - * between bytes and characters. - * - * Converting a ByteArray to a String proceeds by casting each byte in the - * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. For - * ByteArrays consisting entirely of values 1..127, the corresponding String - * representation is the same as the ByteArray representation. - * - * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a byte by - * truncating the upper 8 bits, and then storing the byte in the ByteArray. - * Converting from ByteArray to String and back to ByteArray is not lossy, but - * converting an arbitrary String to a ByteArray may be. + * The following object types represent an array of bytes. The intent is + * to allow arbitrary binary data to pass through Tcl as a Tcl value + * without loss or damage. Such values are useful for things like + * encoded strings or Tk images to name just two. + * + * It's strange to have two Tcl_ObjTypes in place for this task when + * one would do, so a bit of detail and history how we got to this point + * and where we might go from here. + * + * A bytearray is an ordered sequence of bytes. Each byte is an integer + * value in the range [0-255]. To be a Tcl value type, we need a way to + * encode each value in the value set as a Tcl string. The simplest + * encoding is to represent each byte value as the same codepoint value. + * A bytearray of N bytes is encoded into a Tcl string of N characters + * where the codepoint of each character is the value of corresponding byte. + * This approach creates a one-to-one map between all bytearray values + * and a subset of Tcl string values. + * + * When converting a Tcl string value to the bytearray internal rep, the + * question arises what to do with strings outside that subset? That is, + * those Tcl strings containing at least one codepoint greater than 255? + * The obviously correct answer is to raise an error! That string value + * does not represent any valid bytearray value. Full Stop. The + * setFromAnyProc signature has a completion code return value for just + * this reason, to reject invalid inputs. + * + * Unfortunately this was not the path taken by the authors of the + * original tclByteArrayType. They chose to accept all Tcl string values + * as acceptable string encodings of the bytearray values that result + * from masking away the high bits of any codepoint value at all. This + * meant that every bytearray value had multiple accepted string + * representations. + * + * The implications of this choice are truly ugly. When a Tcl value has + * a string representation, we are required to accept that as the true + * value. Bytearray values that possess a string representation cannot + * be processed as bytearrays because we cannot know which true value + * that bytearray represents. The consequence is that we drag around + * an internal rep that we cannot make any use of. This painful price + * is extracted at any point after a string rep happens to be generated + * for the value. This happens even when the troublesome codepoints + * outside the byte range never show up. This happens rather routinely + * in normal Tcl operations unless we burden the script writer with the + * cognitive burden of avoiding it. The price is also paid by callers + * of the C interface. The routine + * + * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) + * + * has a guarantee to always return a non-NULL value, but that value + * points to a byte sequence that cannot be used by the caller to + * process the Tcl value absent some sideband testing that objPtr + * is "pure". Tcl offers no public interface to perform this test, + * so callers either break encapsulation or are unavoidably buggy. Tcl + * has defined a public interface that cannot be used correctly. The + * Tcl source code itself suffers the same problem, and has been buggy, + * but progressively less so as more and more portions of the code have + * been retrofitted with the required "purity testing". The set of values + * able to pass the purity test can be increased via the introduction of + * a "canonical" flag marker, but the only way the broken interface itself + * can be discarded is to start over and define the Tcl_ObjType properly. + * Bytearrays should simply be usable as bytearrays without a kabuki + * dance of testing. + * + * The Tcl_ObjType "properByteArrayType" is (nearly) a correct + * implementation of bytearrays. Any Tcl value with the type + * properByteArrayType can have its bytearray value fetched and + * used with confidence that acting on that value is equivalent to + * acting on the true Tcl string value. This still implies a side + * testing burden -- past mistakes will not let us avoid that + * immediately, but it is at least a conventional test of type, and + * can be implemented entirely by examining the objPtr fields, with + * no need to query the intrep, as a canonical flag would require. + * + * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can + * be revised to admit the possibility of returning NULL when the true + * value is not a valid bytearray, we need a mechanism to retain + * compatibility with the deployed callers of the broken interface. + * That's what the retained "tclByteArrayType" provides. In those + * unusual circumstances where we convert an invalid bytearray value + * to a bytearray type, it is to this legacy type. Essentially any + * time this legacy type gets used, it's a signal of a bug being ignored. + * A TIP should be drafted to remove this connection to the broken past + * so that Tcl 9 will no longer have any trace of it. Prescribing a + * migration path will be the key element of that work. The internal + * changes now in place are the limit of what can be done short of + * interface repair. They provide a great expansion of the histories + * over which bytearray values can be useful in the meanwhile. */ +static const Tcl_ObjType properByteArrayType = { + "bytearray", + FreeProperByteArrayInternalRep, + DupProperByteArrayInternalRep, + UpdateStringOfByteArray, + NULL +}; + const Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - UpdateStringOfByteArray, + NULL, SetByteArrayFromAny }; @@ -195,9 +272,9 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - int used; /* The number of bytes used in the byte + unsigned int used; /* The number of bytes used in the byte * array. */ - int allocated; /* The amount of space actually allocated + unsigned int allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field @@ -206,11 +283,16 @@ typedef struct ByteArray { #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) -#define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) +#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) +#define SET_BYTEARRAY(irPtr, baPtr) \ + (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) +int +TclIsPureByteArray( + Tcl_Obj * objPtr) +{ + return (NULL != Tcl_FetchIntRep(objPtr, &properByteArrayType)); +} /* *---------------------------------------------------------------------- @@ -324,11 +406,11 @@ Tcl_SetByteArrayObj( be >= 0. */ { ByteArray *byteArrayPtr; + Tcl_ObjIntRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } - TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); if (length < 0) { @@ -341,8 +423,9 @@ Tcl_SetByteArrayObj( if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + + Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); } /* @@ -370,16 +453,24 @@ Tcl_GetByteArrayFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - baPtr = GET_BYTEARRAY(objPtr); + baPtr = GET_BYTEARRAY(irPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } - return (unsigned char *) baPtr->bytes; + return baPtr->bytes; } /* @@ -410,22 +501,36 @@ Tcl_SetByteArrayLength( int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; + unsigned newLength; + Tcl_ObjIntRep *irPtr; + + assert(length >= 0); + newLength = (unsigned int)length; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); + if (newLength > byteArrayPtr->allocated) { + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); + byteArrayPtr->allocated = newLength; + SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } @@ -450,29 +555,38 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length; + size_t length; + int improper = 0; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; - Tcl_UniChar ch = 0; - - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; + Tcl_ObjIntRep ir; - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } + if (Tcl_FetchIntRep(objPtr, &properByteArrayType)) { + return TCL_OK; + } + if (Tcl_FetchIntRep(objPtr, &tclByteArrayType)) { + return TCL_OK; + } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + src = TclGetString(objPtr); + length = objPtr->length; + srcEnd = src + length; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + Tcl_UniChar ch = 0; + src += TclUtfToUniChar(src, &ch); + improper = improper || (ch > 255); + *dst++ = UCHAR(ch); } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, + improper ? &tclByteArrayType : &properByteArrayType, &ir); return TCL_OK; } @@ -497,8 +611,14 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(objPtr)); - objPtr->typePtr = NULL; + ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &tclByteArrayType))); +} + +static void +FreeProperByteArrayInternalRep( + Tcl_Obj *objPtr) /* Object with internal rep to free. */ +{ + ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &properByteArrayType))); } /* @@ -523,19 +643,41 @@ DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - int length; + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; - srcArrayPtr = GET_BYTEARRAY(srcPtr); + srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &tclByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); - SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); +} + +static void +DupProperByteArrayInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +{ + unsigned int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; + + srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &properByteArrayType)); + length = srcArrayPtr->used; + + copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); + + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir); } /* @@ -543,9 +685,7 @@ DupByteArrayInternalRep( * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. Note: - * This procedure does not invalidate an existing old string rep so - * storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. * * Results: * None. @@ -554,9 +694,6 @@ DupByteArrayInternalRep( * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is discarded - * and the typePtr becomes NULL. - * *---------------------------------------------------------------------- */ @@ -565,41 +702,35 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - int i, length, size; - unsigned char *src; - char *dst; - ByteArray *byteArrayPtr; - - byteArrayPtr = GET_BYTEARRAY(objPtr); - src = byteArrayPtr->bytes; - length = byteArrayPtr->used; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); + unsigned char *src = byteArrayPtr->bytes; + unsigned int i, length = byteArrayPtr->used; + unsigned int size = length; /* * How much space will string rep need? */ - size = length; - for (i = 0; i < length && size >= 0; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size < 0) { + if (size > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = ckalloc(size + 1); - objPtr->bytes = dst; - objPtr->length = size; - if (size == length) { - memcpy(dst, src, (size_t) size); - dst[size] = '\0'; + char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); + TclOOM(dst, size); } else { + char *dst = Tcl_InitStringRep(objPtr, NULL, size); + TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - *dst = '\0'; + (void)Tcl_InitStringRep(objPtr, NULL, size); } } @@ -629,7 +760,8 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; - int needed; + unsigned int length, needed; + Tcl_ObjIntRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -642,23 +774,34 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + + length = (unsigned int)len; + + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); - if (len > INT_MAX - byteArrayPtr->used) { + if (length > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - needed = byteArrayPtr->used + len; + needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - int attempt; + unsigned int attempt; if (needed <= INT_MAX/2) { /* Try to allocate double the total space that is needed. */ @@ -668,7 +811,7 @@ TclAppendBytesToByteArray( 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; + unsigned int extra = length + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; @@ -681,13 +824,13 @@ TclAppendBytesToByteArray( } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(irPtr, byteArrayPtr); } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); } - byteArrayPtr->used += len; + byteArrayPtr->used += length; TclInvalidateStringRep(objPtr); } @@ -1873,7 +2016,6 @@ FormatNumber( Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { - long value; double dvalue; Tcl_WideInt wvalue; float fvalue; @@ -1889,10 +2031,11 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); @@ -1908,10 +2051,11 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } /* @@ -1935,7 +2079,7 @@ FormatNumber( case 'w': case 'W': case 'm': - if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { @@ -1965,19 +2109,19 @@ FormatNumber( case 'i': case 'I': case 'n': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 24); + *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue >> 16); + *(*cursorPtr)++ = UCHAR(wvalue >> 24); } else { - *(*cursorPtr)++ = UCHAR(value >> 24); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue >> 24); + *(*cursorPtr)++ = UCHAR(wvalue >> 16); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; @@ -1987,15 +2131,15 @@ FormatNumber( case 's': case 'S': case 't': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); } else { - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; @@ -2003,10 +2147,10 @@ FormatNumber( * 8-bit integer values. */ case 'c': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue); return TCL_OK; default: @@ -2194,7 +2338,7 @@ ScanNumber( Tcl_Obj *bigObj = NULL; mp_int big; - TclBNInitBignumFromWideUInt(&big, uwvalue); + TclInitBignumFromWideUInt(&big, uwvalue); bigObj = Tcl_NewBignumObj(&big); return bigObj; } @@ -2394,8 +2538,8 @@ BinaryDecodeHex( } c = *data++; - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { + if (!isxdigit(UCHAR(c))) { + if (strict || !TclIsSpaceProc(c)) { goto badChar; } i--; @@ -2508,7 +2652,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } @@ -2742,7 +2886,7 @@ BinaryDecodeUu( if (lineLen < 0) { c = *data++; if (c < 32 || c > 96) { - if (strict || !isspace(c)) { + if (strict || !TclIsSpaceProc(c)) { goto badUu; } i--; @@ -2760,7 +2904,7 @@ BinaryDecodeUu( d[i] = c = *data++; if (c < 32 || c > 96) { if (strict) { - if (!isspace(c)) { + if (!TclIsSpaceProc(c)) { goto badUu; } else if (c == '\n') { goto shortUu; @@ -2804,7 +2948,7 @@ BinaryDecodeUu( } else if (c >= 32 && c <= 96) { data--; break; - } else if (strict || !isspace(c)) { + } else if (strict || !TclIsSpaceProc(c)) { goto badUu; } } while (data < dataend); @@ -2929,7 +3073,7 @@ BinaryDecode64( if (c == '=' && i > 1) { value <<= 6; cut++; - } else if (!strict && isspace(c)) { + } else if (!strict && TclIsSpaceProc(c)) { i--; } else { goto bad64; @@ -2947,7 +3091,7 @@ BinaryDecode64( } else if (c == '=') { value <<= 6; cut++; - } else if (strict || !isspace(c)) { + } else if (strict || !TclIsSpaceProc(c)) { goto bad64; } else { i--; @@ -2968,7 +3112,7 @@ BinaryDecode64( goto bad64; } for (; data < dataend; data++) { - if (!isspace(*data)) { + if (!TclIsSpaceProc(*data)) { goto bad64; } } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 70e64f0..e3fb98e 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -34,14 +34,14 @@ */ typedef struct MemTag { - int refCount; /* Number of mem_headers referencing this + size_t refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) +#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -52,14 +52,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ const char *file; - long length; + size_t length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static int total_mallocs = 0; -static int total_frees = 0; +static unsigned int total_mallocs = 0; +static unsigned int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static int current_malloc_packets = 0; -static int maximum_malloc_packets = 0; -static int break_on_malloc = 0; -static int trace_on_at_malloc = 0; +static unsigned int current_malloc_packets = 0; +static unsigned int maximum_malloc_packets = 0; +static unsigned int break_on_malloc = 0; +static unsigned int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -156,7 +156,7 @@ TclInitDbCkalloc(void) if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); -#ifndef TCL_THREADS +#if !TCL_THREADS /* Silence compiler warning */ (void)ckallocMutexPtr; #endif @@ -184,18 +184,18 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10d\n" - "total frees %10d\n" - "current packets allocated %10d\n" - "current bytes allocated %10lu\n" - "maximum packets allocated %10d\n" - "maximum bytes allocated %10lu\n", + "total mallocs %10u\n" + "total frees %10u\n" + "current packets allocated %10u\n" + "current bytes allocated %10" TCL_Z_MODIFIER "u\n" + "maximum packets allocated %10u\n" + "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", total_mallocs, total_frees, current_malloc_packets, - (unsigned long)current_bytes_malloced, + current_bytes_malloced, maximum_malloc_packets, - (unsigned long)maximum_bytes_malloced); + maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { @@ -251,10 +251,10 @@ ValidateMemory( } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "low guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -273,10 +273,10 @@ ValidateMemory( if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "high guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); @@ -359,9 +359,8 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", - (long unsigned) address, - (long unsigned) address + memScanP->length - 1, + fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", + address, address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); @@ -450,7 +449,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -458,14 +457,14 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%u)", total_mallocs); } current_malloc_packets++; @@ -547,8 +546,8 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -612,8 +611,8 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", - (long unsigned int) memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", + memp->body, memp->length, file, line); } if (validate_memory) { @@ -623,7 +622,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, (size_t) memp->length); + memset(ptr, GUARD_VALUE, memp->length); } total_frees++; @@ -631,8 +630,7 @@ Tcl_DbCkfree( current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - memp->tagPtr->refCount--; - if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } @@ -675,7 +673,7 @@ Tcl_DbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -689,7 +687,7 @@ Tcl_DbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); @@ -706,7 +704,7 @@ Tcl_AttemptDbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -720,7 +718,7 @@ Tcl_AttemptDbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); @@ -849,22 +847,24 @@ MemoryCmd( return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", + "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, - "current bytes allocated", (unsigned long)current_bytes_malloced, + "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); + "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1], "init") == 0) { @@ -935,12 +935,14 @@ MemoryCmd( } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + trace_on_at_malloc = value; return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { diff --git a/generic/tclClock.c b/generic/tclClock.c index bbfc83b..7f4f592 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -452,7 +452,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (objv[1]->typePtr == &tclBignumType) { + if (Tcl_FetchIntRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a48dfc7..334121f 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -46,9 +46,6 @@ struct ForeachState { static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); -static int BadEncodingSubcommand(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static int EncodingConvertfromObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -84,7 +81,6 @@ static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; -static Tcl_ObjCmdProc BadFileSubcommand; static Tcl_ObjCmdProc FileAttrAccessTimeCmd; static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; static Tcl_ObjCmdProc FileAttrIsExecutableCmd; @@ -164,7 +160,7 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ - +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( @@ -282,6 +278,7 @@ Tcl_CaseObjCmd( return TCL_OK; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -513,63 +510,6 @@ Tcl_ContinueObjCmd( } /* - *---------------------------------------------------------------------- - * - * Tcl_EncodingObjCmd -- - * - * This command manipulates encodings. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EncodingObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int index; - - static const char *const optionStrings[] = { - "convertfrom", "convertto", "dirs", "names", "system", - NULL - }; - enum options { - ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum options) index) { - case ENC_CONVERTTO: - return EncodingConverttoObjCmd(dummy, interp, objc, objv); - case ENC_CONVERTFROM: - return EncodingConvertfromObjCmd(dummy, interp, objc, objv); - case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc, objv); - case ENC_NAMES: - return EncodingNamesObjCmd(dummy, interp, objc, objv); - case ENC_SYSTEM: - return EncodingSystemObjCmd(dummy, interp, objc, objv); - } - return TCL_OK; -} - -/* *----------------------------------------------------------------------------- * * TclInitEncodingCmd -- @@ -592,9 +532,9 @@ TclInitEncodingCmd( static const EnsembleImplMap encodingImplMap[] = { {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -602,113 +542,6 @@ TclInitEncodingCmd( } /* - *----------------------------------------------------------------------------- - * - * TclMakeEncodingCommandSafe -- - * - * This function hides the unsafe 'dirs' and 'system' subcommands of - * the "encoding" Tcl command ensemble. It must be called only from - * TclHideUnsafeCommands. - * - * Results: - * A standard Tcl result - * - * Side effects: - * Adds commands to the table of hidden commands. - * - *----------------------------------------------------------------------------- - */ - -int -TclMakeEncodingCommandSafe( - Tcl_Interp* interp) /* Tcl interpreter */ -{ - static const struct { - const char *cmdName; - int unsafe; - } unsafeInfo[] = { - {"convertfrom", 0}, - {"convertto", 0}, - {"dirs", 1}, - {"names", 0}, - {"system", 0}, - {NULL, 0} - }; - - int i; - Tcl_DString oldBuf, newBuf; - - Tcl_DStringInit(&oldBuf); - TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::"); - Tcl_DStringInit(&newBuf); - TclDStringAppendLiteral(&newBuf, "tcl:encoding:"); - for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { - if (unsafeInfo[i].unsafe) { - const char *oldName, *newName; - - Tcl_DStringSetLength(&oldBuf, 17); - oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); - Tcl_DStringSetLength(&newBuf, 13); - newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); - if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK - || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { - Tcl_Panic("problem making 'encoding %s' safe: %s", - unsafeInfo[i].cmdName, - Tcl_GetString(Tcl_GetObjResult(interp))); - } - Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand, - (ClientData) unsafeInfo[i].cmdName, NULL); - } - } - Tcl_DStringFree(&oldBuf); - Tcl_DStringFree(&newBuf); - - /* - * Ugh. The [encoding] command is now actually safe, but it is assumed by - * scripts that it is not, which messes up security policies. - */ - - if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) { - Tcl_Panic("problem making 'encoding' safe: %s", - Tcl_GetString(Tcl_GetObjResult(interp))); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BadEncodingSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * "encoding" are unsafe (the real implementations of the subcommands are - * hidden). The clientData is always the full official subcommand name. - * - * Results: - * A standard Tcl result (always a TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -BadEncodingSubcommand( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *subcommandName = (const char *) clientData; - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "not allowed to invoke subcommand %s of encoding", subcommandName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); - return TCL_ERROR; -} - -/* *---------------------------------------------------------------------- * * EncodingConvertfromObjCmd -- @@ -1230,40 +1063,40 @@ TclInitFileCmd( */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1}, {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, - {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1}, + {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1}, + {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, + {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, + {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, - {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1}, + {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, - {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, + {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); @@ -1272,141 +1105,6 @@ TclInitFileCmd( /* *---------------------------------------------------------------------- * - * TclMakeFileCommandSafe -- - * - * This function hides the unsafe subcommands of the "file" Tcl command - * ensemble. It must only be called from TclHideUnsafeCommands. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Adds commands to the table of hidden commands. - * - *---------------------------------------------------------------------- - */ - -int -TclMakeFileCommandSafe( - Tcl_Interp *interp) -{ - static const struct { - const char *cmdName; - int unsafe; - } unsafeInfo[] = { - {"atime", 1}, - {"attributes", 1}, - {"channels", 0}, - {"copy", 1}, - {"delete", 1}, - {"dirname", 1}, - {"executable", 1}, - {"exists", 1}, - {"extension", 1}, - {"isdirectory", 1}, - {"isfile", 1}, - {"join", 0}, - {"link", 1}, - {"lstat", 1}, - {"mtime", 1}, - {"mkdir", 1}, - {"nativename", 1}, - {"normalize", 1}, - {"owned", 1}, - {"pathtype", 0}, - {"readable", 1}, - {"readlink", 1}, - {"rename", 1}, - {"rootname", 1}, - {"separator", 0}, - {"size", 1}, - {"split", 0}, - {"stat", 1}, - {"system", 0}, - {"tail", 1}, - {"tempfile", 1}, - {"type", 1}, - {"volumes", 1}, - {"writable", 1}, - {NULL, 0} - }; - int i; - Tcl_DString oldBuf, newBuf; - - Tcl_DStringInit(&oldBuf); - TclDStringAppendLiteral(&oldBuf, "::tcl::file::"); - Tcl_DStringInit(&newBuf); - TclDStringAppendLiteral(&newBuf, "tcl:file:"); - for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { - if (unsafeInfo[i].unsafe) { - const char *oldName, *newName; - - Tcl_DStringSetLength(&oldBuf, 13); - oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); - Tcl_DStringSetLength(&newBuf, 9); - newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); - if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK - || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { - Tcl_Panic("problem making 'file %s' safe: %s", - unsafeInfo[i].cmdName, - Tcl_GetString(Tcl_GetObjResult(interp))); - } - Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand, - (ClientData) unsafeInfo[i].cmdName, NULL); - } - } - Tcl_DStringFree(&oldBuf); - Tcl_DStringFree(&newBuf); - - /* - * Ugh. The [file] command is now actually safe, but it is assumed by - * scripts that it is not, which messes up security policies. [Bug - * 3211758] - */ - - if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) { - Tcl_Panic("problem making 'file' safe: %s", - Tcl_GetString(Tcl_GetObjResult(interp))); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BadFileSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * "file" are unsafe (the real implementations of the subcommands are - * hidden). The clientData is always the full official subcommand name. - * - * Results: - * A standard Tcl result (always a TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -BadFileSubcommand( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *subcommandName = (const char *) clientData; - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "not allowed to invoke subcommand %s of file", subcommandName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * FileAttrAccessTimeCmd -- * * This function is invoked to process the "file atime" Tcl command. See @@ -1454,9 +1152,9 @@ FileAttrAccessTimeCmd( * platforms. [Bug 698146] */ - long newTime; + Tcl_WideInt newTime; - if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } @@ -1535,9 +1233,9 @@ FileAttrModifyTimeCmd( * platforms. [Bug 698146] */ - long newTime; + Tcl_WideInt newTime; - if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e3c5f10..ac2288e 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -64,8 +64,9 @@ typedef struct SortInfo { * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this - * holds the indexes contained in the list - * supplied as an argument to that option. + * holds an encoding of the indexes contained + * in the list supplied as an argument to + * that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ @@ -93,14 +94,6 @@ typedef struct SortInfo { #define SORTMODE_ASCII_NC 8 /* - * Magic values for the index field of the SortInfo structure. Note that the - * index "end-1" will be translated to SORTIDX_END-1, etc. - */ - -#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ -#define SORTIDX_END -2 /* Indexed from end. */ - -/* * Forward declarations for procedures defined in this file: */ @@ -145,6 +138,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, @@ -163,6 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -177,7 +173,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, @@ -543,9 +539,9 @@ InfoBodyCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - const char *name; + const char *name, *bytes; Proc *procPtr; - Tcl_Obj *bodyPtr, *resultPtr; + int numBytes; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); @@ -570,18 +566,8 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bodyPtr = procPtr->bodyPtr; - if (bodyPtr->bytes == NULL) { - /* - * The string rep might not be valid if the procedure has never been - * run before. [Bug #545644] - */ - - TclGetString(bodyPtr); - } - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - - Tcl_SetObjResult(interp, resultPtr); + bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); + Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } @@ -1677,7 +1663,7 @@ InfoLibraryCmd( return TCL_ERROR; } - libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; @@ -1717,19 +1703,24 @@ InfoLoadedCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName; + const char *interpName, *packageName; - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); return TCL_ERROR; } - if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + if (objc < 2) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - return TclGetLoadedPackages(interp, interpName); + if (objc < 3) { /* Get loaded files in all packages. */ + packageName = NULL; + } else { /* Get pkgs just in specified interp. */ + packageName = TclGetString(objv[2]); + } + return TclGetLoadedPackagesEx(interp, interpName, packageName); } /* @@ -1803,7 +1794,7 @@ InfoPatchLevelCmd( return TCL_ERROR; } - patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", + patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); @@ -2134,6 +2125,60 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * + * InfoCmdTypeCmd -- + * + * Called to implement the "info cmdtype" command that returns the type + * of a given command. Handles the following syntax: + * + * info cmdtype cmdName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a type name. If there is an error, the result is an error + * message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCmdTypeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Command command; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "commandName"); + return TCL_ERROR; + } + command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + TCL_LEAVE_ERR_MSG); + if (command == NULL) { + return TCL_ERROR; + } + + /* + * There's one special case: safe slave interpreters can't see aliases as + * aliases as they're part of the security mechanisms. + */ + + if (Tcl_IsSafe(interp) + && (((Command *) command)->objProc == TclAliasObjCmd)) { + Tcl_AppendResult(interp, "native", NULL); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the @@ -2155,8 +2200,8 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int listLen, i; - Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; + int length, listLen; + Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); @@ -2173,27 +2218,47 @@ Tcl_JoinObjCmd( return TCL_ERROR; } + if (listLen == 0) { + /* No elements to join; default empty result is correct. */ + return TCL_OK; + } + if (listLen == 1) { + /* One element; return it */ + Tcl_SetObjResult(interp, elemPtrs[0]); + return TCL_OK; + } + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - resObjPtr = Tcl_NewObj(); - for (i = 0; i < listLen; i++) { - if (i > 0) { + (void) Tcl_GetStringFromObj(joinObjPtr, &length); + if (length == 0) { + resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); + } else { + int i; - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; + if (resObjPtr) { + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; + } + return TCL_ERROR; } /* @@ -2518,7 +2583,6 @@ Tcl_LrangeObjCmd( register Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj **elemPtrs; int listLen, first, last, result; if (objc != 4) { @@ -2536,55 +2600,14 @@ Tcl_LrangeObjCmd( if (result != TCL_OK) { return result; } - if (first < 0) { - first = 0; - } result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } - if (last >= listLen) { - last = listLen - 1; - } - - if (first > last) { - /* - * Returning an empty list is easy. - */ - - return TCL_OK; - } - - result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - if (Tcl_IsShared(objv[1]) || - ((ListRepPtr(objv[1])->refCount > 1))) { - Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, - &elemPtrs[first])); - } else { - /* - * In-place is possible. - */ - - if (last < (listLen - 1)) { - Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, - 0, NULL); - } - - /* - * This one is not conditioned on (first > 0) in order to preserve the - * string-canonizing effect of [lrange 0 end]. - */ - - Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); - Tcl_SetObjResult(interp, objv[1]); - } + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); return TCL_OK; } @@ -2754,21 +2777,10 @@ Tcl_LreplaceObjCmd( if (first < 0) { first = 0; } - - /* - * Complain if the user asked for a start element that is greater than the - * list length. This won't ever trigger for the "end-*" case as that will - * be properly constrained by TclGetIntForIndex because we use listLen-1 - * (to allow for replacing the last elem). - */ - - if ((first > listLen) && (listLen > 0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list doesn't contain element %s", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", - NULL); - return TCL_ERROR; + if (first > listLen) { + first = listLen; } + if (last >= listLen) { last = listLen - 1; } @@ -2913,20 +2925,21 @@ Tcl_LsearchObjCmd( Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; - int i, match, index, result, listc, length, elemLen, bisect; - int dataType, isIncreasing, lower, upper, offset; + int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; + int allocatedIndexVector = 0; + int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset; Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", + "-real", "-regexp", "-sorted", "-start", "-stride", "-subindices", NULL }; enum options { @@ -2934,7 +2947,7 @@ Tcl_LsearchObjCmd( LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, - LSEARCH_START, LSEARCH_SUBINDICES + LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -2954,7 +2967,9 @@ Tcl_LsearchObjCmd( bisect = 0; listPtr = NULL; startPtr = NULL; - offset = 0; + groupSize = 1; + groupOffset = 0; + start = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; @@ -2972,9 +2987,6 @@ Tcl_LsearchObjCmd( for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3039,6 +3051,7 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); + startPtr = NULL; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -3059,25 +3072,47 @@ Tcl_LsearchObjCmd( startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; - Tcl_IncrRefCount(startPtr); } + Tcl_IncrRefCount(startPtr); + break; + case LSEARCH_STRIDE: /* -stride */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + result = TCL_ERROR; + goto done; + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (groupSize < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); + result = TCL_ERROR; + goto done; + } + i++; break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; - if (sortInfo.indexc > 1) { + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); + allocatedIndexVector = 0; } if (i > objc-4) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } /* @@ -3089,10 +3124,8 @@ Tcl_LsearchObjCmd( i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } switch (sortInfo.indexc) { case 0: @@ -3104,6 +3137,8 @@ Tcl_LsearchObjCmd( default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ } /* @@ -3113,13 +3148,26 @@ Tcl_LsearchObjCmd( */ for (j=0 ; j<sortInfo.indexc ; j++) { - if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + int encoded = 0; + if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE, + TCL_INDEX_AFTER, &encoded) != TCL_OK) { + result = TCL_ERROR; + } + if ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indices[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); - result = TCL_ERROR; goto done; } + sortInfo.indexv[j] = encoded; } break; } @@ -3131,14 +3179,12 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && sortInfo.indexc==0) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "-subindices cannot be used without -index option", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (bisect && (allMatches || negatedMatch)) { @@ -3146,7 +3192,8 @@ Tcl_LsearchObjCmd( "-bisect is not compatible with -all or -not", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (mode == REGEXP) { @@ -3172,9 +3219,6 @@ Tcl_LsearchObjCmd( } if (regexp == NULL) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3187,24 +3231,64 @@ Tcl_LsearchObjCmd( result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } goto done; } /* + * Check for sanity when grouping elements of the overall list together + * because of the -stride option. [TIP #351] + */ + + if (groupSize > 1) { + if (listc % groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", + NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc > 0) { + /* + * Use the first value in the list supplied to -index as the + * offset of the element within each group by which to sort. + */ + + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); + if (groupOffset < 0 || groupOffset >= groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BADINDEX", NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc == 1) { + sortInfo.indexc = 0; + sortInfo.indexv = NULL; + } else { + sortInfo.indexc--; + + for (i = 0; i < sortInfo.indexc; i++) { + sortInfo.indexv[i] = sortInfo.indexv[i+1]; + } + } + } + } + + /* * Get the user-specified start offset. */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); - Tcl_DecrRefCount(startPtr); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); if (result != TCL_OK) { goto done; } - if (offset < 0) { - offset = 0; + if (start < 0) { + start = 0; } /* @@ -3212,16 +3296,21 @@ Tcl_LsearchObjCmd( * "did not match anything at all" result straight away. [Bug 1374778] */ - if (offset > listc-1) { - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } + if (start > listc-1) { if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } - return TCL_OK; + goto done; + } + + /* + * If start points within a group, it points to the start of the group. + */ + + if (groupSize > 1) { + start -= (start % groupSize); } } @@ -3280,18 +3369,23 @@ Tcl_LsearchObjCmd( * sense in doing this when the match sense is inverted. */ - lower = offset - 1; + /* + * With -stride, lower, upper and i are kept as multiples of groupSize. + */ + + lower = start - groupSize; upper = listc; - while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { + while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; + i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { result = sortInfo.resultCode; goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3380,10 +3474,10 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = offset; i < listc; i++) { + for (i = start; i < listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); @@ -3392,7 +3486,7 @@ Tcl_LsearchObjCmd( goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch (mode) { @@ -3482,18 +3576,23 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], + &sortInfo); + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else if (groupSize > 1) { + Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, + groupSize, &listv[i]); } else { itemPtr = listv[i]; + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(i); + itemPtr = Tcl_NewIntObj(i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { @@ -3512,10 +3611,10 @@ Tcl_LsearchObjCmd( if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(index); + itemPtr = Tcl_NewIntObj(index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_SetObjResult(interp, itemPtr); } else { @@ -3529,7 +3628,14 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewObj()); } else { - Tcl_SetObjResult(interp, listv[index]); + if (returnSubindices) { + Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], + &sortInfo)); + } else if (groupSize > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); + } else { + Tcl_SetObjResult(interp, listv[index]); + } } result = TCL_OK; @@ -3538,7 +3644,10 @@ Tcl_LsearchObjCmd( */ done: - if (sortInfo.indexc > 1) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } return result; @@ -3732,7 +3841,7 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc, dummy; + int indexc; Tcl_Obj **indexv; if (i == objc-2) { @@ -3758,8 +3867,20 @@ Tcl_LsortObjCmd( */ for (j=0 ; j<indexc ; j++) { - if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &dummy) != TCL_OK) { + int encoded = 0; + int result = TclIndexEncode(interp, indexv[j], + TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded); + + if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER))) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indexv[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; @@ -3839,8 +3960,8 @@ Tcl_LsortObjCmd( * might be decreased by 1 later. */ } for (j=0 ; j<sortInfo.indexc ; j++) { - TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]); + /* Prescreened values, no errors or out of range possible */ + TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]); } } @@ -3911,10 +4032,7 @@ Tcl_LsortObjCmd( * offset of the element within each group by which to sort. */ - groupOffset = sortInfo.indexv[0]; - if (groupOffset <= SORTIDX_END) { - groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; - } + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" @@ -3933,6 +4051,9 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] + * + * TODO: Consider a pointer increment to replace this + * array shift. */ for (i = 0; i < sortInfo.indexc; i++) { @@ -4238,7 +4359,7 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, @@ -4501,15 +4622,8 @@ SelectObjFromSublist( infoPtr->resultCode = TCL_ERROR; return NULL; } - index = infoPtr->indexv[i]; - - /* - * Adjust for end-based indexing. - */ - if (index < SORTIDX_NONE) { - index += listLen + 1; - } + index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5f19d28..a70bfbd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -258,7 +258,7 @@ Tcl_RegexpObjCmd( stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; @@ -323,7 +323,7 @@ Tcl_RegexpObjCmd( if (match == 0) { /* - * We want to set the value of the intepreter result only when + * We want to set the value of the interpreter result only when * this is the first time through the loop. */ @@ -487,26 +487,27 @@ Tcl_RegsubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; - int start, end, subStart, subEnd, match; + int start, end, subStart, subEnd, match, command, numParts; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; static const char *const options[] = { - "-all", "-nocase", "-expanded", - "-line", "-linestop", "-lineanchor", "-start", + "-all", "-command", "-expanded", "-line", + "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; enum options { - REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, - REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, + REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, + REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; + command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { @@ -528,6 +529,9 @@ Tcl_RegsubObjCmd( case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; + case REGSUB_COMMAND: + command = 1; + break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; @@ -578,14 +582,14 @@ Tcl_RegsubObjCmd( if (startIndex) { int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; } } - if (all && (offset == 0) + if (all && (offset == 0) && (command == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* @@ -593,9 +597,9 @@ Tcl_RegsubObjCmd( * slightly modified version of the one pair STR_MAP code. */ - int slen, nocase; + int slen, nocase, wsrclc; int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); - Tcl_UniChar *p, wsrclc; + Tcl_UniChar *p; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); @@ -661,6 +665,28 @@ Tcl_RegsubObjCmd( return TCL_ERROR; } + if (command) { + /* + * In command-prefix mode, we require that the third non-option + * argument be a list, so we enforce that here. Afterwards, we fetch + * the RE compilation again in case objv[0] and objv[2] are the same + * object. (If they aren't, that's cheap to do.) + */ + + if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { + return TCL_ERROR; + } + if (numParts < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command prefix must be a list of at least one element", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", + "CMDEMPTY", NULL); + return TCL_ERROR; + } + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + } + /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. @@ -678,7 +704,9 @@ Tcl_RegsubObjCmd( } else { subPtr = objv[2]; } - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + if (!command) { + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + } result = TCL_OK; @@ -737,6 +765,90 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* + * In command-prefix mode, the substitutions are added as quoted + * arguments to the subSpec to form a command, that is then executed + * and the result used as the string to substitute in. Actually, + * everything is passed through Tcl_EvalObjv, as that's much faster. + */ + + if (command) { + Tcl_Obj **args = NULL, **parts; + int numArgs; + + Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); + numArgs = numParts + info.nsubs + 1; + args = ckalloc(sizeof(Tcl_Obj*) * numArgs); + memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); + + for (idx = 0 ; idx <= info.nsubs ; idx++) { + subStart = info.matches[idx].start; + subEnd = info.matches[idx].end; + if ((subStart >= 0) && (subEnd >= 0)) { + args[idx + numParts] = Tcl_NewUnicodeObj( + wstring + offset + subStart, subEnd - subStart); + } else { + args[idx + numParts] = Tcl_NewObj(); + } + Tcl_IncrRefCount(args[idx + numParts]); + } + + /* + * At this point, we're locally holding the references to the + * argument words we added for this time round the loop, and the + * subPtr is holding the references to the words that the user + * supplied directly. None are zero-refcount, which is important + * because Tcl_EvalObjv is "hairy monster" in terms of refcount + * handling, being able to optionally add references to any of its + * argument words. We'll drop the local refs immediately + * afterwards; subPtr is handled in the main exit stanza. + */ + + result = Tcl_EvalObjv(interp, numArgs, args, 0); + for (idx = 0 ; idx <= info.nsubs ; idx++) { + TclDecrRefCount(args[idx + numParts]); + } + ckfree(args); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s substitution computation script)", + options[REGSUB_COMMAND])); + } + goto done; + } + + Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + + /* + * Refetch the unicode, in case the representation was smashed by + * the user code. + */ + + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + + offset += end; + if (end == 0 || start == end) { + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops, even when we + * technically matched the empty string; we must not match + * again at the same spot. + */ + + if (offset < wlen) { + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + } + offset++; + } + if (all) { + continue; + } else { + break; + } + } + + /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in @@ -989,8 +1101,11 @@ TclNRSourceObjCmd( { const char *encodingName = NULL; Tcl_Obj *fileName; + int result; + void **pkgFiles = NULL; + void *names = NULL; - if (objc != 2 && objc !=4) { + if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1008,9 +1123,30 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } + } else if (objc == 3) { + /* Handle undocumented -nopkg option. This should only be + * used by the internal ::tcl::Pkg::source utility function. */ + static const char *const nopkgoptions[] = { + "-nopkg", NULL + }; + int index; - return TclNREvalFile(interp, fileName, encodingName); + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, + "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + /* Make sure that during the following TclNREvalFile no filenames + * are recorded for inclusion in the "package files" command */ + names = *pkgFiles; + *pkgFiles = NULL; + } + result = TclNREvalFile(interp, fileName, encodingName); + if (pkgFiles) { + /* restore "tclPkgFiles" assocdata to how it was. */ + *pkgFiles = names; + } + return result; } /* @@ -1084,7 +1220,7 @@ Tcl_SplitObjCmd( len = TclUtfToUniChar(stringPtr, &ch); fullchar = ch; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if (!len) { len += TclUtfToUniChar(stringPtr, &ch); fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; @@ -1185,8 +1321,7 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr; - int match, start, needleLen, haystackLen; + int start = 0; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1194,82 +1329,15 @@ StringFirstCmd( return TCL_ERROR; } - /* - * We are searching haystackStr for the sequence needleStr. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to fast forward to that - * point in the string before we think about a match. - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start >= haystackLen) { - goto str_first_done; - } else if (start > 0) { - haystackStr += start; - haystackLen -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; Bug #423581 - */ - - start = 0; - } } - - /* - * If the length of the needle is more than the length of the haystack, it - * cannot be contained in there so we can avoid searching. [Bug 2960021] - */ - - if (needleLen > 0 && needleLen <= haystackLen) { - register Tcl_UniChar *p, *end; - - end = haystackStr + haystackLen - needleLen + 1; - for (p = haystackStr; p < end; p++) { - /* - * Scan forward to find the first character. - */ - - if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, - (unsigned long) needleLen) == 0)) { - match = p - haystackStr; - break; - } - } - } - - /* - * Compute the character index of the matching string by counting the - * number of characters before the match. - */ - - if ((match != -1) && (objc == 4)) { - match += start; - } - - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFirst(objv[1], + objv[2], start))); return TCL_OK; } @@ -1298,76 +1366,23 @@ StringLastCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr, *p; - int match, start, needleLen, haystackLen; + int last = INT_MAX - 1; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?startIndex?"); + "needleString haystackString ?lastIndex?"); return TCL_ERROR; } - /* - * We are searching haystackString for the sequence needleString. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to restrict the string - * range to that char index in the string - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start < 0) { - goto str_last_done; - } else if (start < haystackLen) { - p = haystackStr + start + 1 - needleLen; - } else { - p = haystackStr + haystackLen - needleLen; - } - } else { - p = haystackStr + haystackLen - needleLen; } - - /* - * If the length of the needle is more than the length of the haystack, it - * cannot be contained in there so we can avoid searching. [Bug 2960021] - */ - - if (needleLen > 0 && needleLen <= haystackLen) { - for (; p >= haystackStr; p--) { - /* - * Scan backwards to find the first character. - */ - - if ((*p == *needleStr) && !memcmp(needleStr, p, - sizeof(Tcl_UniChar) * (size_t)needleLen)) { - match = p - haystackStr; - break; - } - } - } - - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1], + objv[2], last))); return TCL_OK; } @@ -1404,7 +1419,7 @@ StringIndexCmd( } /* - * Get the char length to calulate what 'end' means. + * Get the char length to calculate what 'end' means. */ length = Tcl_GetCharLength(objv[1]); @@ -1413,7 +1428,11 @@ StringIndexCmd( } if ((index >= 0) && (index < length)) { - Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index); + int ch = Tcl_GetUniChar(objv[1], index); + + if (ch == -1) { + return TCL_OK; + } /* * If we have a ByteArray object, we're careful to generate a new @@ -1425,9 +1444,12 @@ StringIndexCmd( Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); } else { - char buf[TCL_UTF_MAX]; + char buf[4]; length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } @@ -1557,11 +1579,11 @@ StringIsCmd( string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if (((index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) - || ((index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { - result = 0; + } else if (index != STR_IS_BOOL) { + TclGetBooleanFromObj(NULL, objPtr, &i); + if ((index == STR_IS_TRUE) ^ i) { + result = 0; + } } break; case STR_IS_CONTROL: @@ -1578,13 +1600,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - /* TODO */ - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif - (objPtr->typePtr == &tclBignumType)) { + if (Tcl_FetchIntRep(objPtr, &tclDoubleType) || + Tcl_FetchIntRep(objPtr, &tclIntType) || + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1612,16 +1630,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: - if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { - break; - } - goto failedIntParse; case STR_IS_ENTIER: - if ((objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif - (objPtr->typePtr == &tclBignumType)) { + if (Tcl_FetchIntRep(objPtr, &tclIntType) || + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1666,7 +1677,6 @@ StringIsCmd( break; } - failedIntParse: string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1802,7 +1812,7 @@ StringIsCmd( int fullchar; length2 = TclUtfToUniChar(string1, &ch); fullchar = ch; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if (!length2) { length2 = TclUtfToUniChar(string1, &ch); fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; @@ -1841,7 +1851,7 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(character); + return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); } /* @@ -1897,10 +1907,11 @@ StringMapCmd( /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20 for illustration why!) + * inconsistencies (see test string-10.20.1 for illustration why!) */ - if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + if (!TclHasStringRep(objv[objc-2]) + && Tcl_FetchIntRep(objv[objc-2], &tclDictType)){ int i, done; Tcl_DictSearch search; @@ -1996,8 +2007,8 @@ StringMapCmd( * larger strings. */ - int mapLen; - Tcl_UniChar *mapString, u2lc; + int mapLen, u2lc; + Tcl_UniChar *mapString; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; @@ -2028,8 +2039,8 @@ StringMapCmd( } } } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; + Tcl_UniChar **mapStrings; + int *mapLens, *u2lc = NULL; /* * Precompute pointers to the unicode string and length. This saves us @@ -2041,7 +2052,7 @@ StringMapCmd( mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); + u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -2247,9 +2258,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *string1; - char *string2; - int count, index, length1, length2; + int count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2267,71 +2276,17 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - goto done; + return TCL_OK; } else if (count < 1) { - goto done; - } - string1 = TclGetStringFromObj(objv[1], &length1); - if (length1 <= 0) { - goto done; - } - - /* - * Only build up a string that has data. Instead of building it up with - * repeated appends, we just allocate the necessary space once and copy - * the string value in. - * - * We have to worry about overflow [Bugs 714106, 2561746]. - * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. - * We need to keep 2 <= length2 <= INT_MAX. - */ - - if (count > INT_MAX/length1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "result exceeds max size for a Tcl value (%d bytes)", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; + return TCL_OK; } - length2 = length1 * count; - /* - * Include space for the NUL. - */ - - string2 = attemptckalloc((unsigned) length2 + 1); - if (string2 == NULL) { - /* - * Alloc failed. Note that in this case we try to do an error message - * since this is a case that's most likely when the alloc is large and - * that's easy to do with this API. Note that if we fail allocating a - * short string, this will likely keel over too (and fatally). - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow, out of memory allocating %u bytes", - length2 + 1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); + resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); + if (resultPtr) { + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - string2[length2] = '\0'; - - /* - * We have to directly assign this instead of using Tcl_SetStringObj (and - * indirectly TclInitStringRep) because that makes another copy of the - * data. - */ - - TclNewObj(resultPtr); - resultPtr->bytes = string2; - resultPtr->length = length2; - Tcl_SetObjResult(interp, resultPtr); - - done: - return TCL_OK; + return TCL_ERROR; } /* @@ -2359,42 +2314,50 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + length = Tcl_GetCharLength(objv[1]); + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * The following test screens out most empty substrings as + * candidates for replacement. When they are detected, no + * replacement is done, and the result is the original string, + */ + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ + + /* + * BUT!!! when (end < 0) -- an empty original string -- we can + * have (first <= end < 0 <= last) and an empty string is permitted + * to be replaced. + */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; - if (first < 0) { first = 0; } - - resultPtr = Tcl_NewUnicodeObj(ustring, first); - if (objc == 5) { - Tcl_AppendObjToObj(resultPtr, objv[4]); - } - if (last < length) { - Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + if (last > end) { + last = end; } + + resultPtr = TclStringReplace(interp, objv[1], first, + last + 1 - first, (objc == 5) ? objv[4] : NULL, + TCL_STRING_IN_PLACE); + Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; @@ -2430,7 +2393,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); return TCL_OK; } @@ -2589,10 +2552,8 @@ StringEqualCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - int length1, length2, i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); - strCmpFn_t strCmpFn; + const char *string2; + int length, i, match, nocase = 0, reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: @@ -2602,11 +2563,11 @@ StringEqualCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + string2 = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string2, "-nocase", (size_t)length)) { nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { + } else if ((length > 1) + && !strncmp(string2, "-length", (size_t)length)) { if (i+1 >= objc-2) { goto str_cmp_args; } @@ -2631,78 +2592,7 @@ StringEqualCmd( objv += objc-2; - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Always match at 0 chars of if it is the same obj. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; - } - - if (!nocase && TclIsPureByteArray(objv[0]) && - TclIsPureByteArray(objv[1])) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of String - * type. In benchmark testing this proved the most efficient check - * between the unicode and string comparison operations. - */ - - string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); - } else { - /* - * As a catch-all we will work with UTF-8. We cannot use memcmp() as - * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's - * utf rep). We can use the more efficient TclpUtfNcmp2 if we are - * case-sensitive and no specific length was requested. - */ - - string1 = (char *) TclGetStringFromObj(objv[0], &length1); - string2 = (char *) TclGetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - - if ((reqlength < 0) && (length1 != length2)) { - match = 1; /* This will be reversed below. */ - } else { - length = (length1 < length2) ? length1 : length2; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by setting it - * to length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } - - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } - } + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; @@ -2739,11 +2629,31 @@ StringCmpCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - int length1, length2, i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); - strCmpFn_t strCmpFn; + int match, nocase, reqlength, status; + + status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength); + if (status != TCL_OK) { + return status; + } + objv += objc-2; + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +int TclStringCmpOpts( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Argument objects. */ + int *nocase, + int *reqlength) +{ + int i, length; + const char *string; + + *reqlength = -1; + *nocase = 0; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, @@ -2752,106 +2662,27 @@ StringCmpCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { - nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { + string = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string, "-nocase", (size_t)length)) { + *nocase = 1; + } else if ((length > 1) + && !strncmp(string, "-length", (size_t)length)) { if (i+1 >= objc-2) { goto str_cmp_args; } i++; - if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase or -length", - string2)); + string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + string, NULL); return TCL_ERROR; } } - - /* - * From now on, we only access the two objects at the end of the argument - * array. - */ - - objv += objc-2; - - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Always match at 0 chars of if it is the same obj. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; - } - - if (!nocase && TclIsPureByteArray(objv[0]) && - TclIsPureByteArray(objv[1])) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of String - * type. In benchmark testing this proved the most efficient check - * between the unicode and string comparison operations. - */ - - string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); - } else { - /* - * As a catch-all we will work with UTF-8. We cannot use memcmp() as - * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's - * utf rep). We can use the more efficient TclpUtfNcmp2 if we are - * case-sensitive and no specific length was requested. - */ - - string1 = (char *) TclGetStringFromObj(objv[0], &length1); - string2 = (char *) TclGetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - - length = (length1 < length2) ? length1 : length2; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by setting it to - * length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } - - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } - - Tcl_SetObjResult(interp, - Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); return TCL_OK; } @@ -2879,7 +2710,6 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i; Tcl_Obj *objResultPtr; if (objc < 2) { @@ -2889,23 +2719,15 @@ StringCatCmd( */ return TCL_OK; } - if (objc == 2) { - /* - * Other trivial case, single arg, just return it. - */ - Tcl_SetObjResult(interp, objv[1]); + + objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); + + if (objResultPtr) { + Tcl_SetObjResult(interp, objResultPtr); return TCL_OK; } - objResultPtr = objv[1]; - if (Tcl_IsShared(objResultPtr)) { - objResultPtr = Tcl_DuplicateObj(objResultPtr); - } - for(i = 2;i < objc;i++) { - Tcl_AppendObjToObj(objResultPtr, objv[i]); - } - Tcl_SetObjResult(interp, objResultPtr); - return TCL_OK; + return TCL_ERROR; } /* @@ -2926,7 +2748,6 @@ StringCatCmd( * *---------------------------------------------------------------------- */ - static int StringBytesCmd( ClientData dummy, /* Not used. */ @@ -3274,8 +3095,7 @@ StringTrimCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - triml = TclTrimLeft(string1, length1, string2, length2); - trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); + triml = TclTrim(string1, length1, string2, length2, &trimr); Tcl_SetObjResult(interp, Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); @@ -3580,7 +3400,7 @@ TclNRSwitchObjCmd( OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c2b4bdb..3a162cc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -322,11 +322,22 @@ TclCompileArraySetCmd( */ if (isDataValid && !isDataEven) { + /* Abandon custom compile and let invocation raise the error */ + code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto done; + + /* + * We used to compile to the bytecode that would throw the error, + * but that was wrong because it would not invoke the array trace + * on the variable. + * PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; + * + */ } /* @@ -404,6 +415,10 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + CompileWord(envPtr, dataTokenPtr, interp, 2); if (!isDataLiteral || !isDataValid) { /* @@ -428,9 +443,6 @@ TclCompileArraySetCmd( TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } - 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); @@ -900,7 +912,7 @@ TclCompileConcatCmd( Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = Tcl_GetStringFromObj(objPtr, &len); + bytes = TclGetStringFromObj(objPtr, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; @@ -1308,7 +1320,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = Tcl_GetStringFromObj(dictObj, &len); + bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -2749,7 +2761,7 @@ CompileEachloopCmd( int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + bytes = TclGetStringFromObj(varNameObj, &numBytes); varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; @@ -3186,7 +3198,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3257,7 +3269,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); + char *b = TclGetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3291,7 +3303,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ffe39ba..f9cf3d8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,57 +27,39 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); - -#define INDEX_END (-2) /* *---------------------------------------------------------------------- * - * GetIndexFromToken -- + * TclGetIndexFromToken -- * - * 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'. + * Parse a token to determine if an index value is known at + * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: - * Sets *index to the index value if successful. + * When TCL_OK is returned, the encoded index value is written + * to *index. * *---------------------------------------------------------------------- */ -static inline int -GetIndexFromToken( +int +TclGetIndexFromToken( Tcl_Token *tokenPtr, - int *index) + int before, + int after, + int *indexPtr) { Tcl_Obj *tmpObj = Tcl_NewObj(); - int result, idx; + int result = TCL_ERROR; - 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; - } + if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } Tcl_DecrRefCount(tmpObj); - - if (result == TCL_OK) { - *index = idx; - } - return result; } @@ -144,9 +126,12 @@ TclCompileGlobalCmd( return TCL_ERROR; } - /* TODO: Consider what value can pass throug the - * IndexTailVarIfKnown() screen. Full CompileWord() - * likely does not apply here. Push known value instead. */ + /* + * TODO: Consider what value can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() likely does not + * apply here. Push known value instead. + */ + CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } @@ -287,7 +272,7 @@ TclCompileIfCmd( jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); + jumpFalseFixupArray.fixup + jumpIndex); } code = TCL_OK; } @@ -334,7 +319,7 @@ TclCompileIfCmd( } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); + jumpEndFixupArray.fixup + jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 @@ -346,7 +331,7 @@ TclCompileIfCmd( TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { + jumpFalseFixupArray.fixup + jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. @@ -429,7 +414,7 @@ TclCompileIfCmd( for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { + jumpEndFixupArray.fixup + jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. @@ -937,7 +922,7 @@ TclCompileLappendCmd( CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); @@ -1014,7 +999,7 @@ TclCompileLassignCmd( */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &isScalar, idx+2); + &isScalar, idx + 2); /* * Emit instructions to get the idx'th item out of the list value on @@ -1053,7 +1038,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1104,14 +1089,14 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) { + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, + &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. + * The idxTokenPtr parsed as a valid index value and was + * encoded as expected by INST_LIST_INDEX_IMM. + * + * NOTE: that we rely on indexing before a list producing the + * same result as indexing after a list. */ CompileWord(envPtr, valTokenPtr, interp, 1); @@ -1258,7 +1243,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1332,21 +1317,25 @@ TclCompileLrangeCmd( } 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) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } + /* + * Token was an index value, and we treat all "first" indices + * before the list same as the start of the list. + */ tokenPtr = TokenAfter(tokenPtr); - if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } + /* + * Token was an index value, and we treat all "last" indices + * after the list same as the end of the list. + */ /* * Issue instructions. It's not safe to skip doing the LIST_RANGE, as @@ -1396,21 +1385,30 @@ TclCompileLinsertCmd( */ tokenPtr = TokenAfter(listTokenPtr); - if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) { + + /* + * NOTE: This command treats all inserts at indices before the list + * the same as inserts at the start of the list, and all inserts + * after the list the same as inserts at the end of the list. We + * make that transformation here so we can use the optimized bytecode + * as much as possible. + */ + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, + &idx) != TCL_OK) { return TCL_ERROR; } /* * There are four main cases. If there are no values to insert, this is * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== INDEX_END), this is an append. Otherwise, + * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, * this is a splice (== split, insert values as list, concat-3). */ CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1418,23 +1416,35 @@ TclCompileLinsertCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4( INST_LIST, i-3, envPtr); + TclEmitInstInt4( INST_LIST, i - 3, envPtr); - if (idx == 0 /*start*/) { + if (idx == TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == INDEX_END /*end*/) { + } else if (idx == TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { - if (idx < 0) { + /* + * Here we handle two ranges for idx. First when idx > 0, we + * want the first half of the split to end at index idx-1 and + * the second half to start at index idx. + * Second when idx < TCL_INDEX_END, indicating "end-N" indexing, + * we want the first half of the split to end at index end-N and + * the second half to start at index end-N+1. We accomplish this + * with a pre-adjustment of the end-N value. + * The root of this is that the commands [lrange] and [linsert] + * differ in their interpretation of the "end" index. + */ + + if (idx < TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx-1, envPtr); + TclEmitInt4( idx - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1464,250 +1474,116 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, i, offset, offset2; + int idx1, idx2, i; + int emptyPrefix=1, suffixStart = 0; 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) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } /* - * idx1, idx2 are now in canonical form: + * General structure of the [lreplace] result is + * prefix replacement suffix + * In a few cases we can predict various parts will be empty and + * take advantage. * - * - integer: [0,len+1] - * - end index: INDEX_END - * - -ive offset: INDEX_END-[len-1,0] - * - +ive offset: INDEX_END+1 - */ - - /* - * Compilation fails when one index is end-based but the other isn't. - * Fixing this will require more bytecodes, but this is a workaround for - * now. [Bug 47ac84309b] - */ - - if ((idx1 <= INDEX_END) != (idx2 <= INDEX_END)) { + * The proper suffix begins with the greater of indices idx1 or + * idx2 + 1. If we cannot tell at compile time which is greater, + * we must defer to direct evaluation. + */ + + if (idx1 == TCL_INDEX_AFTER) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_BEFORE) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_END) { + suffixStart = TCL_INDEX_AFTER; + } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) + || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; + } else { return TCL_ERROR; } - if (idx2 != INDEX_END && idx2 >= 0 && idx2 < idx1) { - idx2 = idx1 - 1; - } + /* All paths start with computing/pushing the original value. */ + CompileWord(envPtr, listTokenPtr, interp, 1); /* - * Work out what this [lreplace] is actually doing. + * Push all the replacement values next so any errors raised in + * creating them get raised first. */ - - 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 (idx2 < idx1) { - idx2 = idx1 - 1; - } - 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); + if (parsePtr->numWords > 4) { + /* Push the replacement arguments */ 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 (idx2 < idx1) { - idx2 = idx1 - 1; - } - if (idx1 > 0) { - tmpObj = Tcl_NewIntObj(idx1); - Tcl_IncrRefCount(tmpObj); + for (i=4 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); } - 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: /* This just ensures the arg is a list. */ - 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) { - /* - * Emit bytecode to check the list length. - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GE, envPtr); - offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - - /* - * Emit an error if we've been given an empty list. - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 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); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, - envPtr->codeStart + offset2 + 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; + /* Make a list of them... */ + TclEmitInstInt4( INST_LIST, i - 4, envPtr); - 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) { - /* - * Emit bytecode to check the list length. - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); + emptyPrefix = 0; + } + if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* - * Check the list length vs idx1. + * This is a "no-op". Example: [lreplace {a b c} 2 0] + * We still do a list operation to get list-verification + * and canonicalization side effects. */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + return TCL_OK; + } - TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GE, envPtr); - offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - - /* - * Emit an error if we've been given an empty list. - */ + if (idx1 != TCL_INDEX_START) { + /* Prefix may not be empty; generate bytecode to push it */ + if (emptyPrefix) { + TclEmitOpcode( INST_DUP, envPtr); + } else { + TclEmitInstInt4( INST_OVER, 1, envPtr); + } + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + emptyPrefix = 0; + } - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 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); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, - envPtr->codeStart + offset2 + 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. - */ + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + } - done: - if (tmpObj != NULL) { - Tcl_DecrRefCount(tmpObj); + if (suffixStart == TCL_INDEX_AFTER) { + TclEmitOpcode( INST_POP, envPtr); + if (emptyPrefix) { + PushStringLiteral(envPtr, ""); + } + } else { + /* Suffix may not be empty; generate bytecode to push it */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + if (!emptyPrefix) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } } + return TCL_OK; } @@ -2309,7 +2185,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2317,7 +2193,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2451,7 +2327,7 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = Tcl_GetStringFromObj(patternObj, &len); + bytes = TclGetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; @@ -2499,9 +2375,9 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); + bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2630,7 +2506,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { /* * No explict result argument, so default result is empty string. @@ -2708,7 +2584,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { PushStringLiteral(envPtr, ""); } @@ -2761,7 +2637,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); @@ -2933,18 +2809,18 @@ TclCompileVariableCmd( return TCL_ERROR; } - /* TODO: Consider what value can pass throug the + /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - if (i+1 < numWords) { + if (i + 1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i+1); + CompileWord(envPtr, valueTokenPtr, interp, i + 1); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -3020,7 +2896,7 @@ IndexTailVarIfKnown( tailName = TclGetStringFromObj(tailPtr, &len); if (len) { - if (*(tailName+len-1) == ')') { + if (*(tailName + len - 1) == ')') { /* * Possible array: bail out */ @@ -3034,7 +2910,7 @@ IndexTailVarIfKnown( */ for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { + if ((*p == ':') && (*(p - 1) == ':')) { p++; break; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b5676cb..8b54a99 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -107,58 +107,6 @@ const AuxDataType tclJumptableInfoType = { #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; -} /* *---------------------------------------------------------------------- @@ -312,7 +260,7 @@ TclCompileStringCatCmd( Tcl_DecrRefCount(obj); if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -330,7 +278,7 @@ TclCompileStringCatCmd( } if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -743,14 +691,11 @@ TclCompileStringIsCmd( } switch (t) { - case STR_IS_INT: - PUSH( "1"); - OP( EQ); - break; case STR_IS_WIDE: PUSH( "2"); OP( LE); break; + case STR_IS_INT: case STR_IS_ENTIER: PUSH( "3"); OP( LE); @@ -960,12 +905,12 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = Tcl_GetStringFromObj(objv[0], &len); + bytes = TclGetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(objv[1], &len); + bytes = TclGetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); @@ -994,22 +939,48 @@ TclCompileStringRangeCmd( fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); + /* Every path must push the string argument */ + CompileWord(envPtr, stringTokenPtr, interp, 1); + /* * Parse the two indices. */ - if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { goto nonConstantIndices; } - if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { + /* + * Token parsed as an index expression. We treat all indices before + * the string the same as the start of the string. + */ + + if (idx1 == TCL_INDEX_AFTER) { + /* [string range $s end+1 $last] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; + } + + if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { goto nonConstantIndices; } + /* + * Token parsed as an index expression. We treat all indices after + * the string the same as the end of the string. + */ + if (idx2 == TCL_INDEX_BEFORE) { + /* [string range $s $first -1] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; + } /* * Push the operand onto the stack and then the substring operation. */ - CompileWord(envPtr, stringTokenPtr, interp, 1); OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; @@ -1018,7 +989,6 @@ TclCompileStringRangeCmd( */ nonConstantIndices: - CompileWord(envPtr, stringTokenPtr, interp, 1); CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); OP( STR_RANGE); @@ -1034,124 +1004,197 @@ TclCompileStringReplaceCmd( * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + Tcl_Token *tokenPtr, *valueTokenPtr; DefineLineInformation; /* TIP #280 */ - int idx1, idx2; + int first, last; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } + + /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(valueTokenPtr); - tokenPtr = TokenAfter(tokenPtr); - replacementTokenPtr = TokenAfter(tokenPtr); - } + CompileWord(envPtr, valueTokenPtr, interp, 1); /* - * 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. + * Check for first index known and useful at compile time. */ - tokenPtr = TokenAfter(valueTokenPtr); - if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &first) != TCL_OK) { goto genericReplace; } + /* + * Check for last index known and useful at compile time. + */ tokenPtr = TokenAfter(tokenPtr); - if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &last) != 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. + * [string replace] is an odd bird. For many arguments it is + * a conventional substring replacer. However it also goes out + * of its way to become a no-op for many cases where it would be + * replacing an empty substring. Precisely, it is a no-op when + * + * (last < first) OR + * (last < 0) OR + * (end < first) + * + * For some compile-time values we can detect these cases, and + * compile direct to bytecode implementing the no-op. */ - if (idx1 == 0 && idx2 == 0) { - int notEq, end; + if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ + || (first == TCL_INDEX_AFTER) /* Know (first > end) */ /* - * Just working with the first character. + * Tricky to determine when runtime (last < first) can be + * certainly known based on the encoded values. Consider the + * cases... + * + * (first <= TCL_INDEX_END) && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX END) && (last < first) => ACCEPT + * else => cannot tell REJECT */ - - CompileWord(envPtr, valueTokenPtr, interp, 1); - if (replacementTokenPtr == NULL) { - /* Drop first */ - OP44( STR_RANGE_IMM, 1, INDEX_END); - return TCL_OK; + || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + && (last < first)) /* Know (last < first) */ + /* + * (first == TCL_INDEX_BEFORE) && + * (last == TCL_INDEX_AFTER) => (first < last) REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else => (first < last) REJECT + * + * else [[first >= TCL_INDEX_START]] && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT + */ + || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + && (last < first))) { /* Know (last < first) */ + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP( POP); /* Pop newString */ } - /* 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); + /* Original string argument now on TOS as result */ return TCL_OK; + } - } else if (idx1 == INDEX_END && idx2 == INDEX_END) { - int notEq, end; - - /* - * Just working with the last character. - */ + if (parsePtr->numWords == 5) { + /* + * When we have a string replacement, we have to take care about + * not replacing empty substrings that [string replace] promises + * not to replace + * + * The remaining index values might be suitable for conventional + * string replacement, but only if they cannot possibly meet the + * conditions described above at runtime. If there's a chance they + * might, we would have to emit bytecode to check and at that point + * we're paying more in bytecode execution time than would make + * things worthwhile. Trouble is we are very limited in + * how much we can detect that at compile time. After decoding, + * we need, first: + * + * (first <= end) + * + * The encoded indices (first <= TCL_INDEX END) and + * (first == TCL_INDEX_BEFORE) always meets this condition, but + * any other encoded first index has some list for which it fails. + * + * We also need, second: + * + * (last >= 0) + * + * The encoded indices (last >= TCL_INDEX_START) and + * (last == TCL_INDEX_AFTER) always meet this condition but any + * other encoded last index has some list for which it fails. + * + * Finally we need, third: + * + * (first <= last) + * + * Considered in combination with the constraints we already have, + * we see that we can proceed when (first == TCL_INDEX_BEFORE) + * or (last == TCL_INDEX_AFTER). These also permit simplification + * of the prefix|replace|suffix construction. The other constraints, + * though, interfere with getting a guarantee that first <= last. + */ - 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); + if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { + /* empty prefix */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); OP4( REVERSE, 2); + if (last == TCL_INDEX_AFTER) { + OP( POP); /* Pop original */ + } else { + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + } + return TCL_OK; + } + + if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { + OP44( STR_RANGE_IMM, 0, first-1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); - FIXJUMP1(end); return TCL_OK; + } + + /* FLOW THROUGH TO genericReplace */ } 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. + * When we have no replacement string to worry about, we may + * have more luck, because the forbidden empty string replacements + * are harmless when they are replaced by another empty string. */ + if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { + /* empty prefix - build suffix only */ + + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix too => empty result */ + OP( POP); /* Pop original */ + PUSH ( ""); + return TCL_OK; + } + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + return TCL_OK; + } else { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix - build prefix only */ + OP44( STR_RANGE_IMM, 0, first-1); + return TCL_OK; + } + OP( DUP); + OP44( STR_RANGE_IMM, 0, first-1); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } + } + genericReplace: - 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); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); } else { PUSH( ""); } OP( STR_REPLACE); return TCL_OK; - } } int @@ -1319,7 +1362,7 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(character); + return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); } StringClassDesc const tclStringClassTable[] = { @@ -1468,8 +1511,8 @@ TclSubstCompile( switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); + literal = TclRegisterLiteral(envPtr, + tokenPtr->start, tokenPtr->size, 0); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); @@ -1478,7 +1521,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); + literal = TclRegisterLiteral(envPtr, buf, length, 0); TclEmitPush(literal, envPtr); count++; continue; @@ -1914,10 +1957,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); + ckfree(bodyToken); + ckfree(bodyTokenArray); + ckfree(bodyLines); + ckfree(bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -2837,7 +2880,7 @@ TclCompileTryCmd( } if (objc > 0) { int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); + const char *varname = TclGetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2849,7 +2892,7 @@ TclCompileTryCmd( } if (objc == 2) { int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); + const char *varname = TclGetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -3052,7 +3095,7 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3263,7 +3306,7 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3591,7 +3634,7 @@ TclCompileUnsetCmd( const char *bytes; int len; - bytes = Tcl_GetStringFromObj(leadingWord, &len); + bytes = TclGetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 9c7ab8d..e96e264 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1759,7 +1759,7 @@ ConvertTreeToTokens( /* * All the Tcl_Tokens allocated and filled belong to - * this subexpresion. The first token is the leading + * this subexpression. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ @@ -2181,7 +2181,6 @@ ExecConstantExprTree( CompileEnv *envPtr; ByteCode *byteCodePtr; int code; - Tcl_Obj *byteCodeObj = Tcl_NewObj(); NRE_callback *rootPtr = TOP_CB(interp); /* @@ -2195,14 +2194,12 @@ ExecConstantExprTree( CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); - Tcl_IncrRefCount(byteCodeObj); - TclInitByteCodeObj(byteCodeObj, envPtr); + byteCodePtr = TclInitByteCode(envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - Tcl_DecrRefCount(byteCodeObj); + TclReleaseByteCode(byteCodePtr); return code; } @@ -2270,9 +2267,9 @@ CompileExprTree( p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterNewCmdLiteral(envPtr, + TclEmitPush(TclRegisterLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); Tcl_DStringFree(&cmdName); /* @@ -2379,8 +2376,8 @@ CompileExprTree( pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); @@ -2389,8 +2386,8 @@ CompileExprTree( if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; @@ -2424,7 +2421,7 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterNewLiteral(envPtr, bytes, length); + int index = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { @@ -2479,11 +2476,13 @@ CompileExprTree( * already, then use it to share via the literal table. */ - if (objPtr->bytes) { + if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; + int numBytes; + const char *bytes + = Tcl_GetStringFromObj(objPtr, &numBytes); - index = TclRegisterNewLiteral(envPtr, objPtr->bytes, - objPtr->length); + index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f716195..f6e6b81 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -666,6 +666,7 @@ InstructionDesc const tclInstructionTable[] = { * Prototypes for procedures defined later in this file: */ +static void CleanupByteCode(ByteCode *codePtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, @@ -681,6 +682,7 @@ static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); +static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ @@ -723,13 +725,14 @@ static const Tcl_ObjType substCodeType = { NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; +#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 /* * Helper macros. */ #define TclIncrUInt4AtPtr(ptr, delta) \ - TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)) /* *---------------------------------------------------------------------- @@ -768,7 +771,8 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - int length, result = TCL_OK; + size_t length; + int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; @@ -783,7 +787,8 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetStringFromObj(objPtr, &length); + stringPtr = TclGetString(objPtr); + length = objPtr->length; /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and @@ -871,7 +876,7 @@ TclSetByteCodeFromAny( #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - TclInitByteCodeObj(objPtr, &compEnv); + (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); @@ -970,18 +975,18 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } /* *---------------------------------------------------------------------- * - * TclCleanupByteCode -- + * TclReleaseByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's @@ -998,7 +1003,26 @@ FreeByteCodeInternalRep( */ void -TclCleanupByteCode( +TclPreserveByteCode( + register ByteCode *codePtr) +{ + codePtr->refCount++; +} + +void +TclReleaseByteCode( + register ByteCode *codePtr) +{ + if (codePtr->refCount-- > 1) { + return; + } + + /* Just dropped to refcount==0. Clean up. */ + CleanupByteCode(codePtr); +} + +static void +CleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; @@ -1265,8 +1289,6 @@ Tcl_NRSubstObj( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. * * Side effects: * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the @@ -1286,24 +1308,26 @@ CompileSubstObj( Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - if (objPtr->typePtr == &substCodeType) { + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + + if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) + if (flags != PTR2INT(SubstFlags(objPtr)) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeSubstCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &substCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &substCodeType) { + if (codePtr == NULL) { CompileEnv compEnv; int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1311,13 +1335,10 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &substCodeType; + codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); + SubstFlags(objPtr) = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1356,12 +1377,12 @@ static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + register ByteCode *codePtr; - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } static void @@ -1374,14 +1395,14 @@ ReleaseCmdWordData( Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree((char *) eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree((char *) eclPtr->loc); + ckfree(eclPtr->loc); } - ckfree((char *) eclPtr); + ckfree(eclPtr); } /* @@ -1795,8 +1816,8 @@ CompileCmdLiteral( extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags); + bytes = TclGetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1831,8 +1852,8 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1881,8 +1902,8 @@ CompileExpanded( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -2710,11 +2731,40 @@ TclCompileNoOp( *---------------------------------------------------------------------- */ -void -TclInitByteCodeObj( - Tcl_Obj *objPtr, /* Points object that should be initialized, - * and whose string rep contains the source - * code. */ +static void +PreventCycle( + Tcl_Obj *objPtr, + CompileEnv *envPtr) +{ + int i; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + if (objPtr == TclFetchLiteral(envPtr, i)) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes; + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); + + Tcl_IncrRefCount(copyPtr); + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); + + envPtr->literalArrayPtr[i].objPtr = copyPtr; + } + } +} + +ByteCode * +TclInitByteCode( register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { @@ -2765,7 +2815,8 @@ TclInitByteCodeObj( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 1; + codePtr->refCount = 0; + TclPreserveByteCode(codePtr); if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { @@ -2791,29 +2842,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); - - if (objPtr == fetched) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); - - codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); - Tcl_IncrRefCount(codePtr->objArrayPtr[i]); - TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); - } else { - codePtr->objArrayPtr[i] = fetched; - } + codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ @@ -2856,15 +2885,6 @@ TclInitByteCodeObj( #endif /* TCL_COMPILE_STATS */ /* - * Free the old internal rep then convert the object to a bytecode object - * by making its internal rep point to the just compiled ByteCode. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->typePtr = &tclByteCodeType; - - /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ @@ -2877,6 +2897,31 @@ TclInitByteCodeObj( envPtr->iPtr = NULL; codePtr->localCachePtr = NULL; + return codePtr; +} + +ByteCode * +TclInitByteCodeObj( + Tcl_Obj *objPtr, /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ + const Tcl_ObjType *typePtr, + register CompileEnv *envPtr)/* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ +{ + ByteCode *codePtr; + + PreventCycle(objPtr, envPtr); + + codePtr = TclInitByteCode(envPtr); + + /* + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. + */ + + ByteCodeSetIntRep(objPtr, typePtr, codePtr); + return codePtr; } /* @@ -2944,7 +2989,8 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = Tcl_GetStringFromObj(*varNamePtr, &len); + localName = TclGetString(*varNamePtr); + len = (*varNamePtr)->length; if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c04fc0e..3e349b2 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - int compileEpoch; /* Value of iPtr->compileEpoch when this + unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 + unsigned int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -514,6 +514,23 @@ typedef struct ByteCode { * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; + +#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (codePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ + } while (0) + + + +#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), (typePtr)); \ + (codePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * Opcodes for the Tcl bytecode instructions. These must correspond to the @@ -1069,7 +1086,6 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); -MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, @@ -1098,7 +1114,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData, MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); @@ -1121,8 +1137,11 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, - CompileEnv *envPtr); +MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, + int before, int after, int *indexPtr); +MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); +MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); @@ -1159,6 +1178,8 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); +MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); @@ -1213,29 +1234,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define LITERAL_UNSHARED 0x04 /* - * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to - * cast away constness, and it is cleanest to do that here, all in one place. - * - * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) - -/* - * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it - * is safe to cast away constness, and it is cleanest to do that here, all in - * one place. - * - * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) - -/* * Macro used to manually adjust the stack requirements; used in cases where * the stack effect cannot be computed from the opcode and its operands, but * is still known at compile time. @@ -1492,7 +1490,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #endif #define TclGetInt4AtPtr(p) \ - (((int) TclGetInt1AtPtr(p) << 24) | \ + (((int) (TclGetUInt1AtPtr(p) << 24)) | \ (*((p)+1) << 16) | \ (*((p)+2) << 8) | \ (*((p)+3))) @@ -1550,9 +1548,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) + PushLiteral(envPtr, string, (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 2fb3e92..eb6807c 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -232,7 +232,7 @@ QueryConfigObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - Tcl_GetString(pkgName), NULL); + TclGetString(pkgName), NULL); return TCL_ERROR; } @@ -247,7 +247,7 @@ QueryConfigObjCmd( || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - Tcl_GetString(objv[2]), NULL); + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -333,9 +333,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - ckfree((char *)cdPtr->encoding); + ckfree(cdPtr->encoding); } - ckfree((char *)cdPtr); + ckfree(cdPtr); } /* diff --git a/generic/tclDate.c b/generic/tclDate.c index e4dd000..f720325 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1,14 +1,13 @@ -/* A Bison parser, made by GNU Bison 2.3. */ +/* A Bison parser, made by GNU Bison 3.1. */ -/* Skeleton implementation for Bison's Yacc-like parsers in C +/* Bison implementation for Yacc-like parsers in C - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 - Free Software Foundation, Inc. + Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc. - This program is free software; you can redistribute it and/or modify + This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -16,9 +15,7 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. */ + along with this program. If not, see <http://www.gnu.org/licenses/>. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work @@ -47,7 +44,7 @@ #define YYBISON 1 /* Bison version. */ -#define YYBISON_VERSION "2.3" +#define YYBISON_VERSION "3.1" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" @@ -55,64 +52,19 @@ /* Pure parsers. */ #define YYPURE 1 -/* Using locations. */ -#define YYLSP_NEEDED 1 +/* Push parsers. */ +#define YYPUSH 0 -/* Substitute the variable and function names. */ -#define yyparse TclDateparse -#define yylex TclDatelex -#define yyerror TclDateerror -#define yylval TclDatelval -#define yychar TclDatechar -#define yydebug TclDatedebug -#define yynerrs TclDatenerrs -#define yylloc TclDatelloc - -/* Tokens. */ -#ifndef YYTOKENTYPE -# define YYTOKENTYPE - /* Put the tokens into the symbol table, so that GDB and other debuggers - know about them. */ - enum yytokentype { - tAGO = 258, - tDAY = 259, - tDAYZONE = 260, - tID = 261, - tMERIDIAN = 262, - tMONTH = 263, - tMONTH_UNIT = 264, - tSTARDATE = 265, - tSEC_UNIT = 266, - tSNUMBER = 267, - tUNUMBER = 268, - tZONE = 269, - tEPOCH = 270, - tDST = 271, - tISOBASE = 272, - tDAY_UNIT = 273, - tNEXT = 274 - }; -#endif -/* Tokens. */ -#define tAGO 258 -#define tDAY 259 -#define tDAYZONE 260 -#define tID 261 -#define tMERIDIAN 262 -#define tMONTH 263 -#define tMONTH_UNIT 264 -#define tSTARDATE 265 -#define tSEC_UNIT 266 -#define tSNUMBER 267 -#define tUNUMBER 268 -#define tZONE 269 -#define tEPOCH 270 -#define tDST 271 -#define tISOBASE 272 -#define tDAY_UNIT 273 -#define tNEXT 274 +/* Pull parsers. */ +#define YYPULL 1 +/* Substitute the variable and function names. */ +#define yyparse TclDateparse +#define yylex TclDatelex +#define yyerror TclDateerror +#define yydebug TclDatedebug +#define yynerrs TclDatenerrs /* Copy the first part of user declarations. */ @@ -129,6 +81,7 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * */ #include "tclInt.h" @@ -256,10 +209,14 @@ typedef enum _MERIDIAN { -/* Enabling traces. */ -#ifndef YYDEBUG -# define YYDEBUG 0 -#endif + +# ifndef YY_NULLPTR +# if defined __cplusplus && 201103L <= __cplusplus +# define YY_NULLPTR nullptr +# else +# define YY_NULLPTR 0 +# endif +# endif /* Enabling verbose error messages. */ #ifdef YYERROR_VERBOSE @@ -269,40 +226,78 @@ typedef enum _MERIDIAN { # define YYERROR_VERBOSE 0 #endif -/* Enabling the token table. */ -#ifndef YYTOKEN_TABLE -# define YYTOKEN_TABLE 0 + +/* Debug traces. */ +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif +#if YYDEBUG +extern int TclDatedebug; #endif +/* Token type. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + enum yytokentype + { + tAGO = 258, + tDAY = 259, + tDAYZONE = 260, + tID = 261, + tMERIDIAN = 262, + tMONTH = 263, + tMONTH_UNIT = 264, + tSTARDATE = 265, + tSEC_UNIT = 266, + tSNUMBER = 267, + tUNUMBER = 268, + tZONE = 269, + tEPOCH = 270, + tDST = 271, + tISOBASE = 272, + tDAY_UNIT = 273, + tNEXT = 274 + }; +#endif + +/* Value type. */ #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED -typedef union YYSTYPE +union YYSTYPE { + + time_t Number; enum _MERIDIAN Meridian; -} -/* Line 187 of yacc.c. */ - YYSTYPE; -# define yystype YYSTYPE /* obsolescent; will be withdrawn */ -# define YYSTYPE_IS_DECLARED 1 + +}; + +typedef union YYSTYPE YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 +# define YYSTYPE_IS_DECLARED 1 #endif +/* Location type. */ #if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED -typedef struct YYLTYPE +typedef struct YYLTYPE YYLTYPE; +struct YYLTYPE { int first_line; int first_column; int last_line; int last_column; -} YYLTYPE; -# define yyltype YYLTYPE /* obsolescent; will be withdrawn */ +}; # define YYLTYPE_IS_DECLARED 1 # define YYLTYPE_IS_TRIVIAL 1 #endif + +int TclDateparse (DateInfo* info); + + + /* Copy the second part of user declarations. */ @@ -322,8 +317,6 @@ MODULE_SCOPE int yyparse(DateInfo*); -/* Line 216 of yacc.c. */ - #ifdef short # undef short @@ -337,72 +330,103 @@ typedef unsigned char yytype_uint8; #ifdef YYTYPE_INT8 typedef YYTYPE_INT8 yytype_int8; -#elif (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -typedef signed char yytype_int8; #else -typedef short int yytype_int8; +typedef signed char yytype_int8; #endif #ifdef YYTYPE_UINT16 typedef YYTYPE_UINT16 yytype_uint16; #else -typedef unsigned short int yytype_uint16; +typedef unsigned short yytype_uint16; #endif #ifdef YYTYPE_INT16 typedef YYTYPE_INT16 yytype_int16; #else -typedef short int yytype_int16; +typedef short yytype_int16; #endif #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ -# else +# elif defined size_t # define YYSIZE_T size_t +# elif ! defined YYSIZE_T +# include <stddef.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned # endif #endif #define YYSIZE_MAXIMUM ((YYSIZE_T) -1) #ifndef YY_ -# if YYENABLE_NLS +# if defined YYENABLE_NLS && YYENABLE_NLS # if ENABLE_NLS # include <libintl.h> /* INFRINGES ON USER NAME SPACE */ -# define YY_(msgid) dgettext ("bison-runtime", msgid) +# define YY_(Msgid) dgettext ("bison-runtime", Msgid) # endif # endif # ifndef YY_ -# define YY_(msgid) msgid +# define YY_(Msgid) Msgid +# endif +#endif + +#ifndef YY_ATTRIBUTE +# if (defined __GNUC__ \ + && (2 < __GNUC__ || (__GNUC__ == 2 && 96 <= __GNUC_MINOR__))) \ + || defined __SUNPRO_C && 0x5110 <= __SUNPRO_C +# define YY_ATTRIBUTE(Spec) __attribute__(Spec) +# else +# define YY_ATTRIBUTE(Spec) /* empty */ +# endif +#endif + +#ifndef YY_ATTRIBUTE_PURE +# define YY_ATTRIBUTE_PURE YY_ATTRIBUTE ((__pure__)) +#endif + +#ifndef YY_ATTRIBUTE_UNUSED +# define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__)) +#endif + +#if !defined _Noreturn \ + && (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112) +# if defined _MSC_VER && 1200 <= _MSC_VER +# define _Noreturn __declspec (noreturn) +# else +# define _Noreturn YY_ATTRIBUTE ((__noreturn__)) # endif #endif /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ -# define YYUSE(e) ((void) (e)) +# define YYUSE(E) ((void) (E)) #else -# define YYUSE(e) /* empty */ +# define YYUSE(E) /* empty */ #endif -/* Identity function, used to suppress warnings about constant conditions. */ -#ifndef lint -# define YYID(n) (n) -#else -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -static int -YYID (int i) +#if defined __GNUC__ && ! defined __ICC && 407 <= __GNUC__ * 100 + __GNUC_MINOR__ +/* Suppress an incorrect diagnostic about yylval being uninitialized. */ +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \ + _Pragma ("GCC diagnostic push") \ + _Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")\ + _Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"") +# define YY_IGNORE_MAYBE_UNINITIALIZED_END \ + _Pragma ("GCC diagnostic pop") #else -static int -YYID (i) - int i; +# define YY_INITIAL_VALUE(Value) Value #endif -{ - return i; -} +#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_END +#endif +#ifndef YY_INITIAL_VALUE +# define YY_INITIAL_VALUE(Value) /* Nothing. */ #endif + #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ @@ -420,11 +444,11 @@ YYID (i) # define alloca _alloca # else # define YYSTACK_ALLOC alloca -# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ -# ifndef _STDLIB_H -# define _STDLIB_H 1 + /* Use EXIT_SUCCESS as a witness for stdlib.h. */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 # endif # endif # endif @@ -432,8 +456,8 @@ YYID (i) # endif # ifdef YYSTACK_ALLOC - /* Pacify GCC's `empty if-body' warning. */ -# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) + /* Pacify GCC's 'empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) # ifndef YYSTACK_ALLOC_MAXIMUM /* The OS might guarantee only one guard page at the bottom of the stack, and a page size can be as small as 4096 bytes. So we cannot safely @@ -447,25 +471,23 @@ YYID (i) # ifndef YYSTACK_ALLOC_MAXIMUM # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM # endif -# if (defined __cplusplus && ! defined _STDLIB_H \ +# if (defined __cplusplus && ! defined EXIT_SUCCESS \ && ! ((defined YYMALLOC || defined malloc) \ - && (defined YYFREE || defined free))) + && (defined YYFREE || defined free))) # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ -# ifndef _STDLIB_H -# define _STDLIB_H 1 +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 # endif # endif # ifndef YYMALLOC # define YYMALLOC malloc -# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined malloc && ! defined EXIT_SUCCESS void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ # endif # endif # ifndef YYFREE # define YYFREE free -# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined free && ! defined EXIT_SUCCESS void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif @@ -475,15 +497,15 @@ void free (void *); /* INFRINGES ON USER NAME SPACE */ #if (! defined yyoverflow \ && (! defined __cplusplus \ - || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ - && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ + && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { - yytype_int16 yyss; - YYSTYPE yyvs; - YYLTYPE yyls; + yytype_int16 yyss_alloc; + YYSTYPE yyvs_alloc; + YYLTYPE yyls_alloc; }; /* The size of the maximum gap between one aligned stack and the next. */ @@ -495,42 +517,46 @@ union yyalloc ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \ + 2 * YYSTACK_GAP_MAXIMUM) -/* Copy COUNT objects from FROM to TO. The source and destination do - not overlap. */ -# ifndef YYCOPY -# if defined __GNUC__ && 1 < __GNUC__ -# define YYCOPY(To, From, Count) \ - __builtin_memcpy (To, From, (Count) * sizeof (*(From))) -# else -# define YYCOPY(To, From, Count) \ - do \ - { \ - YYSIZE_T yyi; \ - for (yyi = 0; yyi < (Count); yyi++) \ - (To)[yyi] = (From)[yyi]; \ - } \ - while (YYID (0)) -# endif -# endif +# define YYCOPY_NEEDED 1 /* Relocate STACK from its old location to the new one. The local variables YYSIZE and YYSTACKSIZE give the old and new number of elements in the stack, and YYPTR gives the new location of the stack. Advance YYPTR to a properly aligned location for the next stack. */ -# define YYSTACK_RELOCATE(Stack) \ - do \ - { \ - YYSIZE_T yynewbytes; \ - YYCOPY (&yyptr->Stack, Stack, yysize); \ - Stack = &yyptr->Stack; \ - yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ - yyptr += yynewbytes / sizeof (*yyptr); \ - } \ - while (YYID (0)) +# define YYSTACK_RELOCATE(Stack_alloc, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ + Stack = &yyptr->Stack_alloc; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (0) #endif +#if defined YYCOPY_NEEDED && YYCOPY_NEEDED +/* Copy COUNT objects from SRC to DST. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(Dst, Src, Count) \ + __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) +# else +# define YYCOPY(Dst, Src, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (Dst)[yyi] = (Src)[yyi]; \ + } \ + while (0) +# endif +# endif +#endif /* !YYCOPY_NEEDED */ + /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ @@ -542,17 +568,19 @@ union yyalloc #define YYNNTS 16 /* YYNRULES -- Number of rules. */ #define YYNRULES 56 -/* YYNRULES -- Number of states. */ +/* YYNSTATES -- Number of states. */ #define YYNSTATES 83 -/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ +/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned + by yylex, with out-of-bounds checking. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 274 -#define YYTRANSLATE(YYX) \ - ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) +#define YYTRANSLATE(YYX) \ + ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) -/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ +/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM + as returned by yylex, without out-of-bounds checking. */ static const yytype_uint8 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -586,54 +614,19 @@ static const yytype_uint8 yytranslate[] = }; #if YYDEBUG -/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in - YYRHS. */ -static const yytype_uint8 yyprhs[] = -{ - 0, 0, 3, 4, 7, 9, 11, 13, 15, 17, - 19, 21, 23, 25, 28, 33, 39, 46, 54, 57, - 59, 61, 63, 66, 69, 73, 76, 80, 86, 88, - 94, 100, 103, 108, 111, 113, 117, 120, 124, 128, - 136, 139, 144, 147, 149, 153, 156, 159, 163, 165, - 167, 169, 171, 173, 175, 177, 178 -}; - -/* YYRHS -- A `-1'-separated list of the rules' RHS. */ -static const yytype_int8 yyrhs[] = -{ - 27, 0, -1, -1, 27, 28, -1, 29, -1, 30, - -1, 32, -1, 33, -1, 31, -1, 36, -1, 34, - -1, 35, -1, 40, -1, 13, 7, -1, 13, 20, - 13, 41, -1, 13, 20, 13, 21, 13, -1, 13, - 20, 13, 20, 13, 41, -1, 13, 20, 13, 20, - 13, 21, 13, -1, 14, 16, -1, 14, -1, 5, - -1, 4, -1, 4, 22, -1, 13, 4, -1, 38, - 13, 4, -1, 19, 4, -1, 13, 23, 13, -1, - 13, 23, 13, 23, 13, -1, 17, -1, 13, 21, - 8, 21, 13, -1, 13, 21, 13, 21, 13, -1, - 8, 13, -1, 8, 13, 22, 13, -1, 13, 8, - -1, 15, -1, 13, 8, 13, -1, 19, 8, -1, - 19, 13, 8, -1, 17, 14, 17, -1, 17, 14, - 13, 20, 13, 20, 13, -1, 17, 17, -1, 10, - 13, 24, 13, -1, 37, 3, -1, 37, -1, 38, - 13, 39, -1, 13, 39, -1, 19, 39, -1, 19, - 13, 39, -1, 39, -1, 21, -1, 25, -1, 11, - -1, 18, -1, 9, -1, 13, -1, -1, 7, -1 -}; - -/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ + /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 225, 225, 226, 229, 232, 235, 238, 241, 244, - 247, 251, 256, 259, 265, 271, 279, 285, 296, 300, - 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, - 351, 356, 360, 365, 369, 374, 381, 385, 391, 400, - 409, 419, 433, 438, 441, 444, 447, 450, 453, 458, - 461, 466, 470, 474, 480, 498, 501 + 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, + 245, 249, 254, 257, 263, 269, 277, 283, 294, 298, + 302, 308, 312, 316, 320, 324, 330, 334, 339, 344, + 349, 354, 358, 363, 367, 372, 379, 383, 389, 398, + 407, 417, 431, 436, 439, 442, 445, 448, 451, 456, + 459, 464, 468, 472, 478, 496, 499 }; #endif -#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE +#if YYDEBUG || YYERROR_VERBOSE || 0 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = @@ -644,13 +637,13 @@ static const char *const yytname[] = "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", - "o_merid", 0 + "o_merid", YY_NULLPTR }; #endif # ifdef YYPRINT -/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to - token YYLEX-NUM. */ +/* YYTOKNUM[NUM] -- (External) token number corresponding to the + (internal) symbol number NUM (which must be that of a token). */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, @@ -659,54 +652,18 @@ static const yytype_uint16 yytoknum[] = }; # endif -/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ -static const yytype_uint8 yyr1[] = -{ - 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, - 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, - 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, - 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, - 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, - 38, 39, 39, 39, 40, 41, 41 -}; +#define YYPACT_NINF -22 -/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ -static const yytype_uint8 yyr2[] = -{ - 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, - 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, - 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, - 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, - 1, 1, 1, 1, 1, 0, 1 -}; +#define yypact_value_is_default(Yystate) \ + (!!((Yystate) == (-22))) -/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state - STATE-NUM when YYTABLE doesn't specify something else to do. Zero - means the default is an error. */ -static const yytype_uint8 yydefact[] = -{ - 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, - 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, - 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, - 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, - 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, - 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, - 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, - 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, - 0, 17, 39 -}; +#define YYTABLE_NINF -1 -/* YYDEFGOTO[NTERM-NUM]. */ -static const yytype_int8 yydefgoto[] = -{ - -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 67 -}; +#define yytable_value_is_error(Yytable_value) \ + 0 -/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing - STATE-NUM. */ -#define YYPACT_NINF -22 + /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ static const yytype_int8 yypact[] = { -22, 2, -22, -21, -22, -4, -22, 1, -22, 22, @@ -720,18 +677,39 @@ static const yytype_int8 yypact[] = 64, -22, -22 }; -/* YYPGOTO[NTERM-NUM]. */ + /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. + Performed when YYTABLE does not specify something else to do. Zero + means the default is an error. */ +static const yytype_uint8 yydefact[] = +{ + 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, + 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, + 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, + 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, + 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, + 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, + 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, + 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, + 0, 17, 39 +}; + + /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -9, -22, 6 }; -/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If - positive, shift that token. If negative, reduce the rule which - number is the opposite. If zero, do what YYDEFACT says. - If YYTABLE_NINF, syntax error. */ -#define YYTABLE_NINF -1 + /* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int8 yydefgoto[] = +{ + -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 28, 29, 67 +}; + + /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule whose + number is the opposite. If YYTABLE_NINF, syntax error. */ static const yytype_uint8 yytable[] = { 39, 30, 2, 53, 64, 46, 3, 4, 54, 31, @@ -756,8 +734,8 @@ static const yytype_uint8 yycheck[] = 13, 13, 20, 13, 13, 13, 13, 13, 72, 20 }; -/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing - symbol of state STATE-NUM. */ + /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { 0, 27, 0, 4, 5, 8, 9, 10, 11, 13, @@ -771,156 +749,179 @@ static const yytype_uint8 yystos[] = 20, 13, 13 }; -#define yyerrok (yyerrstatus = 0) -#define yyclearin (yychar = YYEMPTY) -#define YYEMPTY (-2) -#define YYEOF 0 + /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, + 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, + 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, + 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, + 38, 39, 39, 39, 40, 41, 41 +}; + + /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, + 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, + 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, + 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, + 1, 1, 1, 1, 1, 0, 1 +}; -#define YYACCEPT goto yyacceptlab -#define YYABORT goto yyabortlab -#define YYERROR goto yyerrorlab +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 -/* Like YYERROR except do call yyerror. This remains here temporarily - to ease the transition to the new meaning of YYERROR, for GCC. - Once GCC version 2 has supplanted version 1, this can go. */ +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab -#define YYFAIL goto yyerrlab #define YYRECOVERING() (!!yyerrstatus) -#define YYBACKUP(Token, Value) \ -do \ - if (yychar == YYEMPTY && yylen == 1) \ - { \ - yychar = (Token); \ - yylval = (Value); \ - yytoken = YYTRANSLATE (yychar); \ - YYPOPSTACK (1); \ - goto yybackup; \ - } \ - else \ - { \ +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + YYPOPSTACK (yylen); \ + yystate = *yyssp; \ + goto yybackup; \ + } \ + else \ + { \ yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \ - YYERROR; \ - } \ -while (YYID (0)) + YYERROR; \ + } \ +while (0) - -#define YYTERROR 1 -#define YYERRCODE 256 +/* Error token number */ +#define YYTERROR 1 +#define YYERRCODE 256 /* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. If N is 0, then set CURRENT to the empty location which ends the previous symbol: RHS[0] (always defined). */ -#define YYRHSLOC(Rhs, K) ((Rhs)[K]) #ifndef YYLLOC_DEFAULT -# define YYLLOC_DEFAULT(Current, Rhs, N) \ - do \ - if (YYID (N)) \ - { \ - (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ - (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ - (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ - (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ - } \ - else \ - { \ - (Current).first_line = (Current).last_line = \ - YYRHSLOC (Rhs, 0).last_line; \ - (Current).first_column = (Current).last_column = \ - YYRHSLOC (Rhs, 0).last_column; \ - } \ - while (YYID (0)) +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + do \ + if (N) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = \ + YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = (Current).last_column = \ + YYRHSLOC (Rhs, 0).last_column; \ + } \ + while (0) #endif +#define YYRHSLOC(Rhs, K) ((Rhs)[K]) + + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) + /* YY_LOCATION_PRINT -- Print the location on the stream. This macro was not mandated originally: define only if we know we won't break user code: when these are the locations we know. */ #ifndef YY_LOCATION_PRINT -# if YYLTYPE_IS_TRIVIAL -# define YY_LOCATION_PRINT(File, Loc) \ - fprintf (File, "%d.%d-%d.%d", \ - (Loc).first_line, (Loc).first_column, \ - (Loc).last_line, (Loc).last_column) -# else -# define YY_LOCATION_PRINT(File, Loc) ((void) 0) -# endif -#endif - +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL -/* YYLEX -- calling `yylex' with the right arguments. */ +/* Print *YYLOCP on YYO. Private, do not rely on its existence. */ -#ifdef YYLEX_PARAM -# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM) -#else -# define YYLEX yylex (&yylval, &yylloc, info) -#endif +YY_ATTRIBUTE_UNUSED +static unsigned +yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp) +{ + unsigned res = 0; + int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0; + if (0 <= yylocp->first_line) + { + res += YYFPRINTF (yyo, "%d", yylocp->first_line); + if (0 <= yylocp->first_column) + res += YYFPRINTF (yyo, ".%d", yylocp->first_column); + } + if (0 <= yylocp->last_line) + { + if (yylocp->first_line < yylocp->last_line) + { + res += YYFPRINTF (yyo, "-%d", yylocp->last_line); + if (0 <= end_col) + res += YYFPRINTF (yyo, ".%d", end_col); + } + else if (0 <= end_col && yylocp->first_column < end_col) + res += YYFPRINTF (yyo, "-%d", end_col); + } + return res; + } -/* Enable debugging if requested. */ -#if YYDEBUG +# define YY_LOCATION_PRINT(File, Loc) \ + yy_location_print_ (File, &(Loc)) -# ifndef YYFPRINTF -# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ -# define YYFPRINTF fprintf +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) # endif +#endif -# define YYDPRINTF(Args) \ -do { \ - if (yydebug) \ - YYFPRINTF Args; \ -} while (YYID (0)) -# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ -do { \ - if (yydebug) \ - { \ - YYFPRINTF (stderr, "%s ", Title); \ - yy_symbol_print (stderr, \ - Type, Value, Location, info); \ - YYFPRINTF (stderr, "\n"); \ - } \ -} while (YYID (0)) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value, Location, info); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (0) -/*--------------------------------. -| Print this symbol on YYOUTPUT. | -`--------------------------------*/ +/*----------------------------------------. +| Print this symbol's value on YYOUTPUT. | +`----------------------------------------*/ -/*ARGSUSED*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) -#else -static void -yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info) - FILE *yyoutput; - int yytype; - YYSTYPE const * const yyvaluep; - YYLTYPE const * const yylocationp; - DateInfo* info; -#endif { - if (!yyvaluep) - return; + FILE *yyo = yyoutput; + YYUSE (yyo); YYUSE (yylocationp); YYUSE (info); + if (!yyvaluep) + return; # ifdef YYPRINT if (yytype < YYNTOKENS) YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); -# else - YYUSE (yyoutput); # endif - switch (yytype) - { - default: - break; - } + YYUSE (yytype); } @@ -928,24 +929,11 @@ yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info) | Print this symbol on YYOUTPUT. | `--------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) -#else -static void -yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info) - FILE *yyoutput; - int yytype; - YYSTYPE const * const yyvaluep; - YYLTYPE const * const yylocationp; - DateInfo* info; -#endif { - if (yytype < YYNTOKENS) - YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); - else - YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "%s %s (", + yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]); YY_LOCATION_PRINT (yyoutput, *yylocationp); YYFPRINTF (yyoutput, ": "); @@ -958,68 +946,54 @@ yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info) | TOP (included). | `------------------------------------------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -static void -yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) -#else static void -yy_stack_print (bottom, top) - yytype_int16 *bottom; - yytype_int16 *top; -#endif +yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) { YYFPRINTF (stderr, "Stack now"); - for (; bottom <= top; ++bottom) - YYFPRINTF (stderr, " %d", *bottom); + for (; yybottom <= yytop; yybottom++) + { + int yybot = *yybottom; + YYFPRINTF (stderr, " %d", yybot); + } YYFPRINTF (stderr, "\n"); } -# define YY_STACK_PRINT(Bottom, Top) \ -do { \ - if (yydebug) \ - yy_stack_print ((Bottom), (Top)); \ -} while (YYID (0)) +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (0) /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void -yy_reduce_print (YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) -#else -static void -yy_reduce_print (yyvsp, yylsp, yyrule, info) - YYSTYPE *yyvsp; - YYLTYPE *yylsp; - int yyrule; - DateInfo* info; -#endif +yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) { + unsigned long yylno = yyrline[yyrule]; int yynrhs = yyr2[yyrule]; int yyi; - unsigned long int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", - yyrule - 1, yylno); + yyrule - 1, yylno); /* The symbols being reduced. */ for (yyi = 0; yyi < yynrhs; yyi++) { - fprintf (stderr, " $%d = ", yyi + 1); - yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], - &(yyvsp[(yyi + 1) - (yynrhs)]) - , &(yylsp[(yyi + 1) - (yynrhs)]) , info); - fprintf (stderr, "\n"); + YYFPRINTF (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, + yystos[yyssp[yyi + 1 - yynrhs]], + &(yyvsp[(yyi + 1) - (yynrhs)]) + , &(yylsp[(yyi + 1) - (yynrhs)]) , info); + YYFPRINTF (stderr, "\n"); } } -# define YY_REDUCE_PRINT(Rule) \ -do { \ - if (yydebug) \ - yy_reduce_print (yyvsp, yylsp, Rule, info); \ -} while (YYID (0)) +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \ +} while (0) /* Nonzero means print parse trace. It is left uninitialized so that multiple parsers can coexist. */ @@ -1033,7 +1007,7 @@ int yydebug; /* YYINITDEPTH -- initial size of the parser's stacks. */ -#ifndef YYINITDEPTH +#ifndef YYINITDEPTH # define YYINITDEPTH 200 #endif @@ -1048,7 +1022,6 @@ int yydebug; # define YYMAXDEPTH 10000 #endif - #if YYERROR_VERBOSE @@ -1057,15 +1030,8 @@ int yydebug; # define yystrlen strlen # else /* Return the length of YYSTR. */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static YYSIZE_T yystrlen (const char *yystr) -#else -static YYSIZE_T -yystrlen (yystr) - const char *yystr; -#endif { YYSIZE_T yylen; for (yylen = 0; yystr[yylen]; yylen++) @@ -1081,16 +1047,8 @@ yystrlen (yystr) # else /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in YYDEST. */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static char * yystpcpy (char *yydest, const char *yysrc) -#else -static char * -yystpcpy (yydest, yysrc) - char *yydest; - const char *yysrc; -#endif { char *yyd = yydest; const char *yys = yysrc; @@ -1120,27 +1078,27 @@ yytnamerr (char *yyres, const char *yystr) char const *yyp = yystr; for (;;) - switch (*++yyp) - { - case '\'': - case ',': - goto do_not_strip_quotes; - - case '\\': - if (*++yyp != '\\') - goto do_not_strip_quotes; - /* Fall through. */ - default: - if (yyres) - yyres[yyn] = *yyp; - yyn++; - break; - - case '"': - if (yyres) - yyres[yyn] = '\0'; - return yyn; - } + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } do_not_strip_quotes: ; } @@ -1151,169 +1109,161 @@ yytnamerr (char *yyres, const char *yystr) } # endif -/* Copy into YYRESULT an error message about the unexpected token - YYCHAR while in state YYSTATE. Return the number of bytes copied, - including the terminating null byte. If YYRESULT is null, do not - copy anything; just return the number of bytes that would be - copied. As a special case, return 0 if an ordinary "syntax error" - message will do. Return YYSIZE_MAXIMUM if overflow occurs during - size calculation. */ -static YYSIZE_T -yysyntax_error (char *yyresult, int yystate, int yychar) +/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message + about the unexpected token YYTOKEN for the state stack whose top is + YYSSP. + + Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is + not large enough to hold the message. In that case, also set + *YYMSG_ALLOC to the required number of bytes. Return 2 if the + required number of bytes is too large to store. */ +static int +yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, + yytype_int16 *yyssp, int yytoken) { - int yyn = yypact[yystate]; + YYSIZE_T yysize0 = yytnamerr (YY_NULLPTR, yytname[yytoken]); + YYSIZE_T yysize = yysize0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + /* Internationalized format string. */ + const char *yyformat = YY_NULLPTR; + /* Arguments of yyformat. */ + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + /* Number of reported tokens (one for the "unexpected", one per + "expected"). */ + int yycount = 0; + + /* There are many possibilities here to consider: + - If this state is a consistent state with a default action, then + the only way this function was invoked is if the default action + is an error action. In that case, don't check for expected + tokens because there are none. + - The only way there can be no lookahead present (in yychar) is if + this state is a consistent state with a default action. Thus, + detecting the absence of a lookahead is sufficient to determine + that there is no unexpected or expected token to report. In that + case, just report a simple "syntax error". + - Don't assume there isn't a lookahead just because this state is a + consistent state with a default action. There might have been a + previous inconsistent state, consistent state with a non-default + action, or user semantic action that manipulated yychar. + - Of course, the expected token list depends on states to have + correct lookahead information, and it depends on the parser not + to perform extra reductions after fetching a lookahead from the + scanner and before detecting a syntax error. Thus, state merging + (from LALR or IELR) and default reductions corrupt the expected + token list. However, the list is correct for canonical LR with + one exception: it will still contain any token that will not be + accepted due to an error action in a later state. + */ + if (yytoken != YYEMPTY) + { + int yyn = yypact[*yyssp]; + yyarg[yycount++] = yytname[yytoken]; + if (!yypact_value_is_default (yyn)) + { + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. In other words, skip the first -YYN actions for + this state because they are default actions. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yyx; + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR + && !yytable_value_is_error (yytable[yyx + yyn])) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + break; + } + yyarg[yycount++] = yytname[yyx]; + { + YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]); + if (! (yysize <= yysize1 + && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + } + } + } - if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) - return 0; - else + switch (yycount) + { +# define YYCASE_(N, S) \ + case N: \ + yyformat = S; \ + break + default: /* Avoid compiler warnings. */ + YYCASE_(0, YY_("syntax error")); + YYCASE_(1, YY_("syntax error, unexpected %s")); + YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); + YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); + YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); + YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); +# undef YYCASE_ + } + + { + YYSIZE_T yysize1 = yysize + yystrlen (yyformat); + if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + + if (*yymsg_alloc < yysize) { - int yytype = YYTRANSLATE (yychar); - YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); - YYSIZE_T yysize = yysize0; - YYSIZE_T yysize1; - int yysize_overflow = 0; - enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; - char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; - int yyx; - -# if 0 - /* This is so xgettext sees the translatable formats that are - constructed on the fly. */ - YY_("syntax error, unexpected %s"); - YY_("syntax error, unexpected %s, expecting %s"); - YY_("syntax error, unexpected %s, expecting %s or %s"); - YY_("syntax error, unexpected %s, expecting %s or %s or %s"); - YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); -# endif - char *yyfmt; - char const *yyf; - static char const yyunexpected[] = "syntax error, unexpected %s"; - static char const yyexpecting[] = ", expecting %s"; - static char const yyor[] = " or %s"; - char yyformat[sizeof yyunexpected - + sizeof yyexpecting - 1 - + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) - * (sizeof yyor - 1))]; - char const *yyprefix = yyexpecting; - - /* Start YYX at -YYN if negative to avoid negative indexes in - YYCHECK. */ - int yyxbegin = yyn < 0 ? -yyn : 0; - - /* Stay within bounds of both yycheck and yytname. */ - int yychecklim = YYLAST - yyn + 1; - int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; - int yycount = 1; - - yyarg[0] = yytname[yytype]; - yyfmt = yystpcpy (yyformat, yyunexpected); - - for (yyx = yyxbegin; yyx < yyxend; ++yyx) - if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) - { - if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) - { - yycount = 1; - yysize = yysize0; - yyformat[sizeof yyunexpected - 1] = '\0'; - break; - } - yyarg[yycount++] = yytname[yyx]; - yysize1 = yysize + yytnamerr (0, yytname[yyx]); - yysize_overflow |= (yysize1 < yysize); - yysize = yysize1; - yyfmt = yystpcpy (yyfmt, yyprefix); - yyprefix = yyor; - } - - yyf = YY_(yyformat); - yysize1 = yysize + yystrlen (yyf); - yysize_overflow |= (yysize1 < yysize); - yysize = yysize1; - - if (yysize_overflow) - return YYSIZE_MAXIMUM; - - if (yyresult) - { - /* Avoid sprintf, as that infringes on the user's name space. - Don't have undefined behavior even if the translation - produced a string with the wrong number of "%s"s. */ - char *yyp = yyresult; - int yyi = 0; - while ((*yyp = *yyf) != '\0') - { - if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) - { - yyp += yytnamerr (yyp, yyarg[yyi++]); - yyf += 2; - } - else - { - yyp++; - yyf++; - } - } - } - return yysize; + *yymsg_alloc = 2 * yysize; + if (! (yysize <= *yymsg_alloc + && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) + *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; + return 1; } + + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + { + char *yyp = *yymsg; + int yyi = 0; + while ((*yyp = *yyformat) != '\0') + if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyformat += 2; + } + else + { + yyp++; + yyformat++; + } + } + return 0; } #endif /* YYERROR_VERBOSE */ - /*-----------------------------------------------. | Release the memory associated to this symbol. | `-----------------------------------------------*/ -/*ARGSUSED*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info) -#else -static void -yydestruct (yymsg, yytype, yyvaluep, yylocationp, info) - const char *yymsg; - int yytype; - YYSTYPE *yyvaluep; - YYLTYPE *yylocationp; - DateInfo* info; -#endif { YYUSE (yyvaluep); YYUSE (yylocationp); YYUSE (info); - if (!yymsg) yymsg = "Deleting"; YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); - switch (yytype) - { - - default: - break; - } + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + YYUSE (yytype); + YY_IGNORE_MAYBE_UNINITIALIZED_END } - - -/* Prevent warnings from -Wmissing-prototypes. */ - -#ifdef YYPARSE_PARAM -#if defined __STDC__ || defined __cplusplus -int yyparse (void *YYPARSE_PARAM); -#else -int yyparse (); -#endif -#else /* ! YYPARSE_PARAM */ -#if defined __STDC__ || defined __cplusplus -int yyparse (DateInfo* info); -#else -int yyparse (); -#endif -#endif /* ! YYPARSE_PARAM */ - - @@ -1322,112 +1272,96 @@ int yyparse (); | yyparse. | `----------*/ -#ifdef YYPARSE_PARAM -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -int -yyparse (void *YYPARSE_PARAM) -#else -int -yyparse (YYPARSE_PARAM) - void *YYPARSE_PARAM; -#endif -#else /* ! YYPARSE_PARAM */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) int yyparse (DateInfo* info) -#else -int -yyparse (info) - DateInfo* info; -#endif -#endif { - /* The look-ahead symbol. */ +/* The lookahead symbol. */ int yychar; -/* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval; -/* Number of syntax errors so far. */ -int yynerrs; -/* Location data for the look-ahead symbol. */ -YYLTYPE yylloc; +/* The semantic value of the lookahead symbol. */ +/* Default value used for initialization, for pacifying older GCCs + or non-GCC compilers. */ +YY_INITIAL_VALUE (static YYSTYPE yyval_default;) +YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default); - int yystate; - int yyn; - int yyresult; - /* Number of tokens to shift before error messages enabled. */ - int yyerrstatus; - /* Look-ahead token as an internal (translated) token number. */ - int yytoken = 0; -#if YYERROR_VERBOSE - /* Buffer for error messages, and its allocated size. */ - char yymsgbuf[128]; - char *yymsg = yymsgbuf; - YYSIZE_T yymsg_alloc = sizeof yymsgbuf; -#endif +/* Location data for the lookahead symbol. */ +static YYLTYPE yyloc_default +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL + = { 1, 1, 1, 1 } +# endif +; +YYLTYPE yylloc = yyloc_default; - /* Three stacks and their tools: - `yyss': related to states, - `yyvs': related to semantic values, - `yyls': related to locations. + /* Number of syntax errors so far. */ + int yynerrs; - Refer to the stacks thru separate pointers, to allow yyoverflow - to reallocate them elsewhere. */ + int yystate; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; - /* The state stack. */ - yytype_int16 yyssa[YYINITDEPTH]; - yytype_int16 *yyss = yyssa; - yytype_int16 *yyssp; + /* The stacks and their tools: + 'yyss': related to states. + 'yyvs': related to semantic values. + 'yyls': related to locations. - /* The semantic value stack. */ - YYSTYPE yyvsa[YYINITDEPTH]; - YYSTYPE *yyvs = yyvsa; - YYSTYPE *yyvsp; + Refer to the stacks through separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ - /* The location stack. */ - YYLTYPE yylsa[YYINITDEPTH]; - YYLTYPE *yyls = yylsa; - YYLTYPE *yylsp; - /* The locations where the error started and ended. */ - YYLTYPE yyerror_range[2]; + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss; + yytype_int16 *yyssp; -#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N)) + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs; + YYSTYPE *yyvsp; - YYSIZE_T yystacksize = YYINITDEPTH; + /* The location stack. */ + YYLTYPE yylsa[YYINITDEPTH]; + YYLTYPE *yyls; + YYLTYPE *yylsp; + /* The locations where the error started and ended. */ + YYLTYPE yyerror_range[3]; + + YYSIZE_T yystacksize; + + int yyn; + int yyresult; + /* Lookahead token as an internal (translated) token number. */ + int yytoken = 0; /* The variables used to return semantic value and location from the action routines. */ YYSTYPE yyval; YYLTYPE yyloc; +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N)) + /* The number of symbols on the RHS of the reduced rule. Keep to zero when no symbol should be popped. */ int yylen = 0; + yyssp = yyss = yyssa; + yyvsp = yyvs = yyvsa; + yylsp = yyls = yylsa; + yystacksize = YYINITDEPTH; + YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ - - /* Initialize stack pointers. - Waste one element of value and location stack - so that they stay on the same level as the state stack. - The wasted elements are never initialized. */ - - yyssp = yyss; - yyvsp = yyvs; - yylsp = yyls; -#if YYLTYPE_IS_TRIVIAL - /* Initialize the default location before parsing starts. */ - yylloc.first_line = yylloc.last_line = 1; - yylloc.first_column = yylloc.last_column = 0; -#endif - + yychar = YYEMPTY; /* Cause a token to be read. */ + yylsp[0] = yylloc; goto yysetstate; /*------------------------------------------------------------. @@ -1448,25 +1382,26 @@ YYLTYPE yylloc; #ifdef yyoverflow { - /* Give user a chance to reallocate the stack. Use copies of - these so that the &'s don't force the real ones into - memory. */ - YYSTYPE *yyvs1 = yyvs; - yytype_int16 *yyss1 = yyss; - YYLTYPE *yyls1 = yyls; - - /* Each stack pointer address is followed by the size of the - data in use in that stack, in bytes. This used to be a - conditional around just the two extra args, but that might - be undefined if yyoverflow is a macro. */ - yyoverflow (YY_("memory exhausted"), - &yyss1, yysize * sizeof (*yyssp), - &yyvs1, yysize * sizeof (*yyvsp), - &yyls1, yysize * sizeof (*yylsp), - &yystacksize); - yyls = yyls1; - yyss = yyss1; - yyvs = yyvs1; + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + YYLTYPE *yyls1 = yyls; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yyls1, yysize * sizeof (*yylsp), + &yystacksize); + + yyls = yyls1; + yyss = yyss1; + yyvs = yyvs1; } #else /* no yyoverflow */ # ifndef YYSTACK_RELOCATE @@ -1474,23 +1409,23 @@ YYLTYPE yylloc; # else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) - goto yyexhaustedlab; + goto yyexhaustedlab; yystacksize *= 2; if (YYMAXDEPTH < yystacksize) - yystacksize = YYMAXDEPTH; + yystacksize = YYMAXDEPTH; { - yytype_int16 *yyss1 = yyss; - union yyalloc *yyptr = - (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); - if (! yyptr) - goto yyexhaustedlab; - YYSTACK_RELOCATE (yyss); - YYSTACK_RELOCATE (yyvs); - YYSTACK_RELOCATE (yyls); + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss_alloc, yyss); + YYSTACK_RELOCATE (yyvs_alloc, yyvs); + YYSTACK_RELOCATE (yyls_alloc, yyls); # undef YYSTACK_RELOCATE - if (yyss1 != yyssa) - YYSTACK_FREE (yyss1); + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); } # endif #endif /* no yyoverflow */ @@ -1500,14 +1435,17 @@ YYLTYPE yylloc; yylsp = yyls + yysize - 1; YYDPRINTF ((stderr, "Stack size increased to %lu\n", - (unsigned long int) yystacksize)); + (unsigned long) yystacksize)); if (yyss + yystacksize - 1 <= yyssp) - YYABORT; + YYABORT; } YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + if (yystate == YYFINAL) + YYACCEPT; + goto yybackup; /*-----------. @@ -1516,20 +1454,20 @@ YYLTYPE yylloc; yybackup: /* Do appropriate processing given the current state. Read a - look-ahead token if we need one and don't already have one. */ + lookahead token if we need one and don't already have one. */ - /* First try to decide what to do without reference to look-ahead token. */ + /* First try to decide what to do without reference to lookahead token. */ yyn = yypact[yystate]; - if (yyn == YYPACT_NINF) + if (yypact_value_is_default (yyn)) goto yydefault; - /* Not known => get a look-ahead token if don't already have one. */ + /* Not known => get a lookahead token if don't already have one. */ - /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ + /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); - yychar = YYLEX; + yychar = yylex (&yylval, &yylloc, info); } if (yychar <= YYEOF) @@ -1551,29 +1489,27 @@ yybackup: yyn = yytable[yyn]; if (yyn <= 0) { - if (yyn == 0 || yyn == YYTABLE_NINF) - goto yyerrlab; + if (yytable_value_is_error (yyn)) + goto yyerrlab; yyn = -yyn; goto yyreduce; } - if (yyn == YYFINAL) - YYACCEPT; - /* Count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; - /* Shift the look-ahead token. */ + /* Shift the lookahead token. */ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); - /* Discard the shifted token unless it is eof. */ - if (yychar != YYEOF) - yychar = YYEMPTY; + /* Discard the shifted token. */ + yychar = YYEMPTY; yystate = yyn; + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END *++yylsp = yylloc; goto yynewstate; @@ -1596,7 +1532,7 @@ yyreduce: yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: - `$$ = $1'. + '$$ = $1'. Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison @@ -1605,8 +1541,9 @@ yyreduce: GCC warning that YYVAL may be used uninitialized. */ yyval = yyvsp[1-yylen]; - /* Default location. */ + /* Default location. */ YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen); + yyerror_range[1] = yyloc; YY_REDUCE_PRINT (yyn); switch (yyn) { @@ -1614,42 +1551,48 @@ yyreduce: { yyHaveTime++; - ;} + } + break; case 5: { yyHaveZone++; - ;} + } + break; case 6: { yyHaveDate++; - ;} + } + break; case 7: { yyHaveOrdinalMonth++; - ;} + } + break; case 8: { yyHaveDay++; - ;} + } + break; case 9: { yyHaveRel++; - ;} + } + break; case 10: @@ -1657,7 +1600,8 @@ yyreduce: { yyHaveTime++; yyHaveDate++; - ;} + } + break; case 11: @@ -1666,195 +1610,217 @@ yyreduce: yyHaveTime++; yyHaveDate++; yyHaveRel++; - ;} + } + break; case 13: { - yyHour = (yyvsp[(1) - (2)].Number); + yyHour = (yyvsp[-1].Number); yyMinutes = 0; yySeconds = 0; - yyMeridian = (yyvsp[(2) - (2)].Meridian); - ;} + yyMeridian = (yyvsp[0].Meridian); + } + break; case 14: { - yyHour = (yyvsp[(1) - (4)].Number); - yyMinutes = (yyvsp[(3) - (4)].Number); + yyHour = (yyvsp[-3].Number); + yyMinutes = (yyvsp[-1].Number); yySeconds = 0; - yyMeridian = (yyvsp[(4) - (4)].Meridian); - ;} + yyMeridian = (yyvsp[0].Meridian); + } + break; case 15: { - yyHour = (yyvsp[(1) - (5)].Number); - yyMinutes = (yyvsp[(3) - (5)].Number); + yyHour = (yyvsp[-4].Number); + yyMinutes = (yyvsp[-2].Number); yyMeridian = MER24; yyDSTmode = DSToff; - yyTimezone = ((yyvsp[(5) - (5)].Number) % 100 + ((yyvsp[(5) - (5)].Number) / 100) * 60); + yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; - ;} + } + break; case 16: { - yyHour = (yyvsp[(1) - (6)].Number); - yyMinutes = (yyvsp[(3) - (6)].Number); - yySeconds = (yyvsp[(5) - (6)].Number); - yyMeridian = (yyvsp[(6) - (6)].Meridian); - ;} + yyHour = (yyvsp[-5].Number); + yyMinutes = (yyvsp[-3].Number); + yySeconds = (yyvsp[-1].Number); + yyMeridian = (yyvsp[0].Meridian); + } + break; case 17: { - yyHour = (yyvsp[(1) - (7)].Number); - yyMinutes = (yyvsp[(3) - (7)].Number); - yySeconds = (yyvsp[(5) - (7)].Number); + yyHour = (yyvsp[-6].Number); + yyMinutes = (yyvsp[-4].Number); + yySeconds = (yyvsp[-2].Number); yyMeridian = MER24; yyDSTmode = DSToff; - yyTimezone = ((yyvsp[(7) - (7)].Number) % 100 + ((yyvsp[(7) - (7)].Number) / 100) * 60); + yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; - ;} + } + break; case 18: { - yyTimezone = (yyvsp[(1) - (2)].Number); + yyTimezone = (yyvsp[-1].Number); yyDSTmode = DSTon; - ;} + } + break; case 19: { - yyTimezone = (yyvsp[(1) - (1)].Number); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSToff; - ;} + } + break; case 20: { - yyTimezone = (yyvsp[(1) - (1)].Number); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSTon; - ;} + } + break; case 21: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[(1) - (1)].Number); - ;} + yyDayNumber = (yyvsp[0].Number); + } + break; case 22: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[(1) - (2)].Number); - ;} + yyDayNumber = (yyvsp[-1].Number); + } + break; case 23: { - yyDayOrdinal = (yyvsp[(1) - (2)].Number); - yyDayNumber = (yyvsp[(2) - (2)].Number); - ;} + yyDayOrdinal = (yyvsp[-1].Number); + yyDayNumber = (yyvsp[0].Number); + } + break; case 24: { - yyDayOrdinal = (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number); - yyDayNumber = (yyvsp[(3) - (3)].Number); - ;} + yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); + yyDayNumber = (yyvsp[0].Number); + } + break; case 25: { yyDayOrdinal = 2; - yyDayNumber = (yyvsp[(2) - (2)].Number); - ;} + yyDayNumber = (yyvsp[0].Number); + } + break; case 26: { - yyMonth = (yyvsp[(1) - (3)].Number); - yyDay = (yyvsp[(3) - (3)].Number); - ;} + yyMonth = (yyvsp[-2].Number); + yyDay = (yyvsp[0].Number); + } + break; case 27: { - yyMonth = (yyvsp[(1) - (5)].Number); - yyDay = (yyvsp[(3) - (5)].Number); - yyYear = (yyvsp[(5) - (5)].Number); - ;} + yyMonth = (yyvsp[-4].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 28: { - yyYear = (yyvsp[(1) - (1)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (1)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (1)].Number) % 100; - ;} + yyYear = (yyvsp[0].Number) / 10000; + yyMonth = ((yyvsp[0].Number) % 10000)/100; + yyDay = (yyvsp[0].Number) % 100; + } + break; case 29: { - yyDay = (yyvsp[(1) - (5)].Number); - yyMonth = (yyvsp[(3) - (5)].Number); - yyYear = (yyvsp[(5) - (5)].Number); - ;} + yyDay = (yyvsp[-4].Number); + yyMonth = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 30: { - yyMonth = (yyvsp[(3) - (5)].Number); - yyDay = (yyvsp[(5) - (5)].Number); - yyYear = (yyvsp[(1) - (5)].Number); - ;} + yyMonth = (yyvsp[-2].Number); + yyDay = (yyvsp[0].Number); + yyYear = (yyvsp[-4].Number); + } + break; case 31: { - yyMonth = (yyvsp[(1) - (2)].Number); - yyDay = (yyvsp[(2) - (2)].Number); - ;} + yyMonth = (yyvsp[-1].Number); + yyDay = (yyvsp[0].Number); + } + break; case 32: { - yyMonth = (yyvsp[(1) - (4)].Number); - yyDay = (yyvsp[(2) - (4)].Number); - yyYear = (yyvsp[(4) - (4)].Number); - ;} + yyMonth = (yyvsp[-3].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 33: { - yyMonth = (yyvsp[(2) - (2)].Number); - yyDay = (yyvsp[(1) - (2)].Number); - ;} + yyMonth = (yyvsp[0].Number); + yyDay = (yyvsp[-1].Number); + } + break; case 34: @@ -1863,70 +1829,77 @@ yyreduce: yyMonth = 1; yyDay = 1; yyYear = EPOCH; - ;} + } + break; case 35: { - yyMonth = (yyvsp[(2) - (3)].Number); - yyDay = (yyvsp[(1) - (3)].Number); - yyYear = (yyvsp[(3) - (3)].Number); - ;} + yyMonth = (yyvsp[-1].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 36: { yyMonthOrdinal = 1; - yyMonth = (yyvsp[(2) - (2)].Number); - ;} + yyMonth = (yyvsp[0].Number); + } + break; case 37: { - yyMonthOrdinal = (yyvsp[(2) - (3)].Number); - yyMonth = (yyvsp[(3) - (3)].Number); - ;} + yyMonthOrdinal = (yyvsp[-1].Number); + yyMonth = (yyvsp[0].Number); + } + break; case 38: { - if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT; - yyYear = (yyvsp[(1) - (3)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (3)].Number) % 100; - yyHour = (yyvsp[(3) - (3)].Number) / 10000; - yyMinutes = ((yyvsp[(3) - (3)].Number) % 10000)/100; - yySeconds = (yyvsp[(3) - (3)].Number) % 100; - ;} + if ((yyvsp[-1].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[-2].Number) / 10000; + yyMonth = ((yyvsp[-2].Number) % 10000)/100; + yyDay = (yyvsp[-2].Number) % 100; + yyHour = (yyvsp[0].Number) / 10000; + yyMinutes = ((yyvsp[0].Number) % 10000)/100; + yySeconds = (yyvsp[0].Number) % 100; + } + break; case 39: { - if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT; - yyYear = (yyvsp[(1) - (7)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (7)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (7)].Number) % 100; - yyHour = (yyvsp[(3) - (7)].Number); - yyMinutes = (yyvsp[(5) - (7)].Number); - yySeconds = (yyvsp[(7) - (7)].Number); - ;} + if ((yyvsp[-5].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[-6].Number) / 10000; + yyMonth = ((yyvsp[-6].Number) % 10000)/100; + yyDay = (yyvsp[-6].Number) % 100; + yyHour = (yyvsp[-4].Number); + yyMinutes = (yyvsp[-2].Number); + yySeconds = (yyvsp[0].Number); + } + break; case 40: { - yyYear = (yyvsp[(1) - (2)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (2)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (2)].Number) % 100; - yyHour = (yyvsp[(2) - (2)].Number) / 10000; - yyMinutes = ((yyvsp[(2) - (2)].Number) % 10000)/100; - yySeconds = (yyvsp[(2) - (2)].Number) % 100; - ;} + yyYear = (yyvsp[-1].Number) / 10000; + yyMonth = ((yyvsp[-1].Number) % 10000)/100; + yyDay = (yyvsp[-1].Number) % 100; + yyHour = (yyvsp[0].Number) / 10000; + yyMinutes = ((yyvsp[0].Number) % 10000)/100; + yySeconds = (yyvsp[0].Number) % 100; + } + break; case 41: @@ -1937,12 +1910,13 @@ yyreduce: * in a range accessible with a 32 bit clock seconds value. */ - yyYear = (yyvsp[(2) - (4)].Number)/1000 + 2323 - 377; + yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377; yyDay = 1; yyMonth = 1; - yyRelDay += (((yyvsp[(2) - (4)].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; - yyRelSeconds += (yyvsp[(4) - (4)].Number) * 144 * 60; - ;} + yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; + yyRelSeconds += (yyvsp[0].Number) * 144 * 60; + } + break; case 42: @@ -1951,121 +1925,145 @@ yyreduce: yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; - ;} + } + break; case 44: { - *yyRelPointer += (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); - ;} + *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 45: { - *yyRelPointer += (yyvsp[(1) - (2)].Number) * (yyvsp[(2) - (2)].Number); - ;} + *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 46: { - *yyRelPointer += (yyvsp[(2) - (2)].Number); - ;} + *yyRelPointer += (yyvsp[0].Number); + } + break; case 47: { - *yyRelPointer += (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); - ;} + *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 48: { - *yyRelPointer += (yyvsp[(1) - (1)].Number); - ;} + *yyRelPointer += (yyvsp[0].Number); + } + break; case 49: { (yyval.Number) = -1; - ;} + } + break; case 50: { (yyval.Number) = 1; - ;} + } + break; case 51: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelSeconds; - ;} + } + break; case 52: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelDay; - ;} + } + break; case 53: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelMonth; - ;} + } + break; case 54: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { - yyYear = (yyvsp[(1) - (1)].Number); + yyYear = (yyvsp[0].Number); } else { yyHaveTime++; if (yyDigitCount <= 2) { - yyHour = (yyvsp[(1) - (1)].Number); + yyHour = (yyvsp[0].Number); yyMinutes = 0; } else { - yyHour = (yyvsp[(1) - (1)].Number) / 100; - yyMinutes = (yyvsp[(1) - (1)].Number) % 100; + yyHour = (yyvsp[0].Number) / 100; + yyMinutes = (yyvsp[0].Number) % 100; } yySeconds = 0; yyMeridian = MER24; } - ;} + } + break; case 55: { (yyval.Meridian) = MER24; - ;} + } + break; case 56: { - (yyval.Meridian) = (yyvsp[(1) - (1)].Meridian); - ;} + (yyval.Meridian) = (yyvsp[0].Meridian); + } + break; -/* Line 1267 of yacc.c. */ default: break; } + /* User semantic actions sometimes alter yychar, and that requires + that yytoken be updated with the new translation. We take the + approach of translating immediately before every use of yytoken. + One alternative is translating here after every semantic action, + but that translation would be missed if the semantic action invokes + YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or + if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an + incorrect destructor might then be invoked immediately. In the + case of YYERROR or YYBACKUP, subsequent parser actions might lead + to an incorrect destructor call or verbose syntax error message + before the lookahead is translated. */ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); YYPOPSTACK (yylen); @@ -2075,7 +2073,7 @@ yyreduce: *++yyvsp = yyval; *++yylsp = yyloc; - /* Now `shift' the result of the reduction. Determine what state + /* Now 'shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ @@ -2090,10 +2088,14 @@ yyreduce: goto yynewstate; -/*------------------------------------. -| yyerrlab -- here on detecting error | -`------------------------------------*/ +/*--------------------------------------. +| yyerrlab -- here on detecting error. | +`--------------------------------------*/ yyerrlab: + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); + /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { @@ -2101,62 +2103,61 @@ yyerrlab: #if ! YYERROR_VERBOSE yyerror (&yylloc, info, YY_("syntax error")); #else +# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ + yyssp, yytoken) { - YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); - if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) - { - YYSIZE_T yyalloc = 2 * yysize; - if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) - yyalloc = YYSTACK_ALLOC_MAXIMUM; - if (yymsg != yymsgbuf) - YYSTACK_FREE (yymsg); - yymsg = (char *) YYSTACK_ALLOC (yyalloc); - if (yymsg) - yymsg_alloc = yyalloc; - else - { - yymsg = yymsgbuf; - yymsg_alloc = sizeof yymsgbuf; - } - } - - if (0 < yysize && yysize <= yymsg_alloc) - { - (void) yysyntax_error (yymsg, yystate, yychar); - yyerror (&yylloc, info, yymsg); - } - else - { - yyerror (&yylloc, info, YY_("syntax error")); - if (yysize != 0) - goto yyexhaustedlab; - } + char const *yymsgp = YY_("syntax error"); + int yysyntax_error_status; + yysyntax_error_status = YYSYNTAX_ERROR; + if (yysyntax_error_status == 0) + yymsgp = yymsg; + else if (yysyntax_error_status == 1) + { + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); + if (!yymsg) + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + yysyntax_error_status = 2; + } + else + { + yysyntax_error_status = YYSYNTAX_ERROR; + yymsgp = yymsg; + } + } + yyerror (&yylloc, info, yymsgp); + if (yysyntax_error_status == 2) + goto yyexhaustedlab; } +# undef YYSYNTAX_ERROR #endif } - yyerror_range[0] = yylloc; + yyerror_range[1] = yylloc; if (yyerrstatus == 3) { - /* If just tried and failed to reuse look-ahead token after an - error, discard it. */ + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ if (yychar <= YYEOF) - { - /* Return failure if at end of input. */ - if (yychar == YYEOF) - YYABORT; - } + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } else - { - yydestruct ("Error: discarding", - yytoken, &yylval, &yylloc, info); - yychar = YYEMPTY; - } + { + yydestruct ("Error: discarding", + yytoken, &yylval, &yylloc, info); + yychar = YYEMPTY; + } } - /* Else will try to reuse look-ahead token after shifting the error + /* Else will try to reuse lookahead token after shifting the error token. */ goto yyerrlab1; @@ -2172,8 +2173,7 @@ yyerrorlab: if (/*CONSTCOND*/ 0) goto yyerrorlab; - yyerror_range[0] = yylsp[1-yylen]; - /* Do not reclaim the symbols of the rule which action triggered + /* Do not reclaim the symbols of the rule whose action triggered this YYERROR. */ YYPOPSTACK (yylen); yylen = 0; @@ -2186,43 +2186,42 @@ yyerrorlab: | yyerrlab1 -- common code for both syntax error and YYERROR. | `-------------------------------------------------------------*/ yyerrlab1: - yyerrstatus = 3; /* Each real token shifted decrements this. */ + yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; - if (yyn != YYPACT_NINF) - { - yyn += YYTERROR; - if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) - { - yyn = yytable[yyn]; - if (0 < yyn) - break; - } - } + if (!yypact_value_is_default (yyn)) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } /* Pop the current state because it cannot handle the error token. */ if (yyssp == yyss) - YYABORT; + YYABORT; - yyerror_range[0] = *yylsp; + yyerror_range[1] = *yylsp; yydestruct ("Error: popping", - yystos[yystate], yyvsp, yylsp, info); + yystos[yystate], yyvsp, yylsp, info); YYPOPSTACK (1); yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } - if (yyn == YYFINAL) - YYACCEPT; - + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END - yyerror_range[1] = yylloc; + yyerror_range[2] = yylloc; /* Using YYLLOC is tempting, but would change the location of - the look-ahead. YYLOC is available though. */ - YYLLOC_DEFAULT (yyloc, (yyerror_range - 1), 2); + the lookahead. YYLOC is available though. */ + YYLLOC_DEFAULT (yyloc, yyerror_range, 2); *++yylsp = yyloc; /* Shift the error token. */ @@ -2246,7 +2245,7 @@ yyabortlab: yyresult = 1; goto yyreturn; -#ifndef yyoverflow +#if !defined yyoverflow || YYERROR_VERBOSE /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | `-------------------------------------------------*/ @@ -2257,17 +2256,22 @@ yyexhaustedlab: #endif yyreturn: - if (yychar != YYEOF && yychar != YYEMPTY) - yydestruct ("Cleanup: discarding lookahead", - yytoken, &yylval, &yylloc, info); - /* Do not reclaim the symbols of the rule which action triggered + if (yychar != YYEMPTY) + { + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = YYTRANSLATE (yychar); + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval, &yylloc, info); + } + /* Do not reclaim the symbols of the rule whose action triggered this YYABORT or YYACCEPT. */ YYPOPSTACK (yylen); YY_STACK_PRINT (yyss, yyssp); while (yyssp != yyss) { yydestruct ("Cleanup: popping", - yystos[*yyssp], yyvsp, yylsp, info); + yystos[*yyssp], yyvsp, yylsp, info); YYPOPSTACK (1); } #ifndef yyoverflow @@ -2278,13 +2282,10 @@ yyreturn: if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); #endif - /* Make sure YYID is used. */ - return YYID (yyresult); + return yyresult; } - - /* * Month and day table. */ @@ -2680,7 +2681,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProc(*yyInput)) { + while (TclIsSpaceProc(UCHAR(*yyInput))) { yyInput++; } @@ -2911,4 +2912,3 @@ TclClockOldscanObjCmd( * fill-column: 78 * End: */ - diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3de71af..c79a408 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -23,6 +23,15 @@ # endif #endif +#if !defined(BUILD_tcl) +# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) +#elif defined(TCL_NO_DEPRECATED) +# define TCL_DEPRECATED(msg) MODULE_SCOPE +#else +# define TCL_DEPRECATED(msg) EXTERN +#endif + + /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -44,7 +53,7 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ @@ -110,7 +119,8 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* 22 */ -EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, @@ -122,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* 26 */ -EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, int line); /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); @@ -149,9 +160,9 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ -EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GetIndexFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, @@ -190,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 49 */ -EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ -EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 54 */ -EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); /* 57 */ -EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ @@ -216,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ -EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 63 */ -EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); /* 66 */ -EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message); /* 67 */ -EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); @@ -254,7 +273,8 @@ EXTERN int Tcl_AsyncReady(void); /* 76 */ EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ -EXTERN char Tcl_Backslash(const char *src, int *readPtr); +TCL_DEPRECATED("Use Tcl_UtfBackslash") +char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -271,7 +291,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); @@ -282,7 +302,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src, EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv); + const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, @@ -313,7 +333,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ -EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, +TCL_DEPRECATED("") +void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); @@ -403,16 +424,17 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); +EXTERN const char * Tcl_ErrnoId(void); /* 128 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +EXTERN const char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ -EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); @@ -460,13 +482,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *argcPtr, - CONST84 char ***argvPtr); + const char **targetCmdPtr, int *argcPtr, + const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *objcPtr, + const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, @@ -485,7 +507,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ -EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -496,12 +518,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 160 */ -EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ -EXTERN CONST84_RETURN char * Tcl_GetHostName(void); +EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); @@ -537,19 +559,20 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ -EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ -EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, - const char *varName, int flags); -/* 176 */ -EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); +/* 176 */ +EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, int flags); /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); /* 178 */ -EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, @@ -569,7 +592,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, @@ -582,7 +605,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -596,7 +619,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags); + const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -618,7 +641,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ -EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); @@ -648,8 +671,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, - CONST84 char **endPtr); + const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ @@ -660,7 +682,8 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -704,26 +727,26 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ -EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, - const char *varName, const char *newValue, - int flags); -/* 238 */ -EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); +/* 238 */ +EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, const char *newValue, + int flags); /* 239 */ -EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); +EXTERN const char * Tcl_SignalId(int sig); /* 240 */ -EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); +EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 244 */ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -732,9 +755,11 @@ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ -EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -755,13 +780,15 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 253 */ -EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags); /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 255 */ -EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); @@ -774,7 +801,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); /* 258 */ -EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 259 */ @@ -784,7 +812,8 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); /* 261 */ -EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); @@ -803,40 +832,46 @@ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, - const char *start, CONST84 char **termPtr); +EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr); /* 271 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 272 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ -EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* 274 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); @@ -878,7 +913,7 @@ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ -EXTERN void Tcl_ExitThread(int status); +EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -901,7 +936,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ -EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ @@ -950,30 +985,30 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index); +EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ -EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); +EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ -EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); +EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ -EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); +EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src); +EXTERN const char * Tcl_UtfNext(const char *src); /* 331 */ -EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -1001,9 +1036,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ -EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") +const char * Tcl_GetDefaultEncodingDir(void); /* 342 */ -EXTERN void Tcl_SetDefaultEncodingDir(const char *path); +TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") +void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ EXTERN void Tcl_AlertNotifier(ClientData clientData); /* 344 */ @@ -1038,7 +1075,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ -EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_EvalTokensStandard") +Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); @@ -1050,7 +1088,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, @@ -1062,7 +1100,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1108,9 +1146,10 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ -EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1152,8 +1191,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ -EXTERN CONST84_RETURN char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr); +EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); @@ -1259,13 +1297,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ -EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, +TCL_DEPRECATED("") +int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 436 */ -EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, +TCL_DEPRECATED("") +Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1816,6 +1856,39 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, + const char *service, const char *host, + unsigned int flags, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData); +/* 632 */ +EXTERN int TclZipfs_Mount(Tcl_Interp *interp, + const char *mountPoint, const char *zipname, + const char *passwd); +/* 633 */ +EXTERN int TclZipfs_Unmount(Tcl_Interp *interp, + const char *mountPoint); +/* 634 */ +EXTERN Tcl_Obj * TclZipfs_TclLibrary(void); +/* 635 */ +EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, + const char *mountPoint, unsigned char *data, + size_t datalen, int copy); +/* 636 */ +EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +/* 637 */ +EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes); +/* 638 */ +EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr); +/* 639 */ +EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr); +/* 640 */ +EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1828,7 +1901,7 @@ typedef struct TclStubs { const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ - CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ + const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ @@ -1865,11 +1938,11 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ @@ -1879,7 +1952,7 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1892,25 +1965,25 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ - void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -1920,16 +1993,16 @@ typedef struct TclStubs { void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ - char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ + TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ + char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ @@ -1938,7 +2011,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ @@ -1970,11 +2043,11 @@ typedef struct TclStubs { void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ - CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ - CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ + const char * (*tcl_ErrnoId) (void); /* 127 */ + const char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -1991,21 +2064,21 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ - CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ - CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ + const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ + const char * (*tcl_GetHostName) (void); /* 162 */ int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ @@ -2025,11 +2098,11 @@ typedef struct TclStubs { int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ - CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ + const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2037,25 +2110,25 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */ + char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */ + char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ - CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ + const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ @@ -2066,12 +2139,12 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ @@ -2088,48 +2161,48 @@ typedef struct TclStubs { void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ - CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ - CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ - CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ + const char * (*tcl_SignalId) (int sig); /* 239 */ + const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ - CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ - CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ @@ -2145,7 +2218,7 @@ typedef struct TclStubs { int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ - void (*tcl_ExitThread) (int status); /* 294 */ + TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ @@ -2153,7 +2226,7 @@ typedef struct TclStubs { void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ - CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ + const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ @@ -2171,18 +2244,18 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ - Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ - Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ - Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ + int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + int (*tcl_UniCharToLower) (int ch); /* 321 */ + int (*tcl_UniCharToTitle) (int ch); /* 322 */ + int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ + const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ - CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ - CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */ - CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ + const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ + const char * (*tcl_UtfNext) (const char *src); /* 330 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2192,8 +2265,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2208,13 +2281,13 @@ typedef struct TclStubs { char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ + TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ @@ -2232,8 +2305,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -2249,7 +2322,7 @@ typedef struct TclStubs { int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ - CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ + const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ @@ -2286,8 +2359,8 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ - Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ + TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ @@ -2482,6 +2555,16 @@ typedef struct TclStubs { void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */ + int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ + Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ + int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ + void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */ + Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */ + int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3774,6 +3857,26 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_OpenTcpServerEx \ + (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ +#define TclZipfs_Mount \ + (tclStubsPtr->tclZipfs_Mount) /* 632 */ +#define TclZipfs_Unmount \ + (tclStubsPtr->tclZipfs_Unmount) /* 633 */ +#define TclZipfs_TclLibrary \ + (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ +#define TclZipfs_MountBuffer \ + (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ +#define Tcl_FreeIntRep \ + (tclStubsPtr->tcl_FreeIntRep) /* 636 */ +#define Tcl_InitStringRep \ + (tclStubsPtr->tcl_InitStringRep) /* 637 */ +#define Tcl_FetchIntRep \ + (tclStubsPtr->tcl_FetchIntRep) /* 638 */ +#define Tcl_StoreIntRep \ + (tclStubsPtr->tcl_StoreIntRep) /* 639 */ +#define Tcl_HasStringRep \ + (tclStubsPtr->tcl_HasStringRep) /* 640 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3785,15 +3888,12 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetStringResult # undef Tcl_Init # undef Tcl_SetPanicProc -# undef Tcl_SetVar # undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) -# define Tcl_SetVar(interp, varName, newValue, flags) \ - (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif @@ -3803,6 +3903,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_MainEx Tcl_MainExW EXTERN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); + EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #endif #undef TCL_STORAGE_CLASS @@ -3826,13 +3927,13 @@ extern const TclStubs *tclStubsPtr; sizeof(char *), msg, flags, indexPtr) #undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(boolValue) \ - Tcl_NewIntObj((boolValue)!=0) + Tcl_NewLongObj((boolValue)!=0) #undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(boolValue, file, line) \ Tcl_DbNewLongObj((boolValue)!=0, file, line) #undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, boolValue) \ - Tcl_SetIntObj((objPtr), (boolValue)!=0) + Tcl_SetLongObj(objPtr, (boolValue)!=0) #undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) @@ -3854,6 +3955,51 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_UpVar #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) +#undef Tcl_AddErrorInfo +#define Tcl_AddErrorInfo(interp, message) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) +#undef Tcl_AddObjErrorInfo +#define Tcl_AddObjErrorInfo(interp, message, length) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) +#ifdef TCL_NO_DEPRECATED +#undef Tcl_Eval +#define Tcl_Eval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, 0) +#undef Tcl_GlobalEval +#define Tcl_GlobalEval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) +#undef Tcl_SaveResult +#define Tcl_SaveResult(interp, statePtr) \ + do { \ + (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount((statePtr)->objResultPtr); \ + Tcl_SetObjResult(interp, Tcl_NewObj()); \ + } while(0) +#undef Tcl_RestoreResult +#define Tcl_RestoreResult(interp, statePtr) \ + do { \ + Tcl_ResetResult(interp); \ + Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ + Tcl_DecrRefCount((statePtr)->objResultPtr); \ + } while(0) +#undef Tcl_DiscardResult +#define Tcl_DiscardResult(statePtr) \ + Tcl_DecrRefCount((statePtr)->objResultPtr) +#undef Tcl_SetResult +#define Tcl_SetResult(interp, result, freeProc) \ + do { \ + char *__result = result; \ + Tcl_FreeProc *__freeProc = freeProc; \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ + if (__freeProc == TCL_DYNAMIC) { \ + ckfree(__result); \ + } else { \ + (*__freeProc)(__result); \ + } \ + } \ + } while(0) +#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) @@ -3864,20 +4010,14 @@ extern const TclStubs *tclStubsPtr; * possible. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -# undef Tcl_DbNewLongObj # undef Tcl_GetLongFromObj -# undef Tcl_NewLongObj -# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp -# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) -# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) -# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; @@ -3903,15 +4043,28 @@ extern const TclStubs *tclStubsPtr; # endif #endif +#undef Tcl_NewLongObj +#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) +#undef Tcl_NewIntObj +#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) +#undef Tcl_DbNewLongObj +#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) +#undef Tcl_SetIntObj +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) +#undef Tcl_SetLongObj +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) +#undef Tcl_GetUnicode +#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) + /* * Deprecated Tcl procedures: */ #undef Tcl_EvalObj -#define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) +#define Tcl_EvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, 0) #undef Tcl_GlobalEvalObj -#define Tcl_GlobalEvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_GlobalEvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 2eff1ff..13ff0f8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -12,6 +12,7 @@ #include "tclInt.h" #include "tommath.h" +#include <assert.h> /* * Forward declaration. @@ -141,7 +142,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ + unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -149,13 +150,6 @@ typedef struct Dict { } Dict; /* - * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this - * must be assignable as well as readable. - */ - -#define DICT(dictObj) (*((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. */ @@ -168,6 +162,21 @@ const Tcl_ObjType tclDictType = { SetDictFromAny /* setFromAnyProc */ }; +#define DictSetIntRep(objPtr, dictRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (dictRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ + } while (0) + +#define DictGetIntRep(objPtr, dictRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclDictType); \ + (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it @@ -363,10 +372,11 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *oldDict, *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; + DictGetIntRep(srcPtr, oldDict); + /* * Copy values across from the old hash table. */ @@ -390,7 +400,7 @@ DupDictInternalRep( * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; newDict->refCount = 1; @@ -398,9 +408,7 @@ DupDictInternalRep( * Store in the object. */ - DICT(copyPtr) = newDict; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclDictType; + DictSetIntRep(copyPtr, newDict); } /* @@ -425,12 +433,13 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = DICT(dictPtr); + Dict *dict; + + DictGetIntRep(dictPtr, dict); if (dict->refCount-- <= 1) { DeleteDict(dict); } - dictPtr->typePtr = NULL; } /* @@ -489,7 +498,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = DICT(dictPtr); + Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -501,12 +510,17 @@ UpdateStringOfDict( * is not exposed by any API function... */ - int numElems = dict->table.numEntries * 2; + int numElems; + + DictGetIntRep(dictPtr, dict); + + assert (dict != NULL); + + numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = tclEmptyStringRep; - dictPtr->length = 0; + Tcl_InitStringRep(dictPtr, NULL, 0); return; } @@ -550,9 +564,8 @@ UpdateStringOfDict( * Pass 2: copy into string rep buffer. */ - dictPtr->length = bytesNeeded - 1; - dictPtr->bytes = ckalloc(bytesNeeded); - dst = dictPtr->bytes; + dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); @@ -566,7 +579,7 @@ UpdateStringOfDict( dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - dictPtr->bytes[dictPtr->length] = '\0'; + (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { ckfree(flagPtr); @@ -610,7 +623,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (objPtr->typePtr == &tclListType) { + if (Tcl_FetchIntRep(objPtr, &tclListType)) { int objc, i; Tcl_Obj **objv; @@ -665,10 +678,14 @@ SetDictFromAny( TclNewStringObj(keyPtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(keyPtr); - keyPtr->bytes = ckalloc((unsigned) elemSize + 1); - keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, - keyPtr->bytes); + Tcl_InvalidateStringRep(keyPtr); + dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(keyPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } if (TclFindDictElement(interp, nextElem, (limit - nextElem), @@ -681,10 +698,14 @@ SetDictFromAny( TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(valuePtr); - valuePtr->bytes = ckalloc((unsigned) elemSize + 1); - valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, - valuePtr->bytes); + Tcl_InvalidateStringRep(valuePtr); + dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(valuePtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } /* Store key and value in the hash table we're building. */ @@ -706,13 +727,10 @@ SetDictFromAny( * Tcl_GetStringFromObj, to use that old internalRep. */ - TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(objPtr) = dict; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclDictType; + DictSetIntRep(objPtr, dict); return TCL_OK; missingValue: @@ -726,6 +744,23 @@ SetDictFromAny( ckfree(dict); return TCL_ERROR; } + +static Dict * +GetDictFromObj( + Tcl_Interp *interp, + Tcl_Obj *dictPtr) +{ + Dict *dict; + + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); + } + return dict; +} /* *---------------------------------------------------------------------- @@ -770,11 +805,13 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); } - dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -810,13 +847,17 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType - && SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; + + DictGetIntRep(tmpObj, newDict); + + if (newDict == NULL) { + if (SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; + } } } - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -824,7 +865,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); } newDict->chain = dictPtr; @@ -859,17 +900,24 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = DICT(dictObj); + Dict *dict; + + DictGetIntRep(dictObj, dict); + assert( dict != NULL); do { + dict->refCount++; TclInvalidateStringRep(dictObj); + TclFreeIntRep(dictObj); + DictSetIntRep(dictObj, dict); + dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = DICT(dictObj); + DictGetIntRep(dictObj, dict); } while (dict != NULL); } @@ -907,16 +955,16 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = DICT(dictPtr); + TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); + dict->refCount++; + TclFreeIntRep(dictPtr) + DictSetIntRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); @@ -958,13 +1006,12 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { *valuePtrPtr = NULL; return TCL_ERROR; } - dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1005,16 +1052,13 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); dict->epoch++; } return TCL_OK; @@ -1046,12 +1090,11 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1098,15 +1141,14 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; @@ -1167,7 +1209,7 @@ Tcl_DictObjNext( * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } @@ -1224,8 +1266,8 @@ Tcl_DictObjDone( { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); @@ -1277,7 +1319,8 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -1334,7 +1377,8 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1377,12 +1421,10 @@ Tcl_NewDictObj(void) TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #endif } @@ -1427,12 +1469,10 @@ Tcl_DbNewDictObj( TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); @@ -1618,16 +1658,13 @@ DictReplaceCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; i<objc ; i+=2) { Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]); } @@ -1669,16 +1706,13 @@ DictRemoveCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; i<objc ; i++) { Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } @@ -1729,8 +1763,7 @@ DictMergeCmd( */ targetObj = objv[1]; - if (targetObj->typePtr != &tclDictType - && SetDictFromAny(interp, targetObj) != TCL_OK) { + if (GetDictFromObj(interp, targetObj) == NULL) { return TCL_ERROR; } @@ -1813,8 +1846,7 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType - && SetDictFromAny(interp, objv[1]) != TCL_OK) { + if (GetDictFromObj(interp, objv[1]) == NULL) { return TCL_ERROR; } @@ -2021,7 +2053,6 @@ DictInfoCmd( int objc, Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr; Dict *dict; char *statsStr; @@ -2030,12 +2061,10 @@ DictInfoCmd( return TCL_ERROR; } - dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, objv[1]); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2096,12 +2125,11 @@ DictIncrCmd( * soon be no good. */ - char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - dictPtr->bytes = NULL; - dictPtr = Tcl_DuplicateObj(dictPtr); - oldPtr->bytes = saved; + TclNewObj(dictPtr); + TclInvalidateStringRep(dictPtr); + DupDictInternalRep(oldPtr, dictPtr); } if (valuePtr == NULL) { /* @@ -2238,7 +2266,7 @@ DictLappendCmd( if (allocatedValue) { Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else if (dictPtr->bytes != NULL) { + } else { TclInvalidateStringRep(dictPtr); } @@ -2277,7 +2305,7 @@ DictAppendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int i, allocatedDict = 0; + int allocatedDict = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); @@ -2300,17 +2328,49 @@ DictAppendCmd( return TCL_ERROR; } - if (valuePtr == NULL) { - TclNewObj(valuePtr); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + if ((objc > 3) || (valuePtr == NULL)) { + /* Only go through append activites when something will change. */ + Tcl_Obj *appendObjPtr = NULL; + + if (objc > 3) { + /* Something to append */ - for (i=3 ; i<objc ; i++) { - Tcl_AppendObjToObj(valuePtr, objv[i]); + if (objc == 4) { + appendObjPtr = objv[3]; + } else { + appendObjPtr = TclStringCat(interp, objc-3, objv+3, + TCL_STRING_IN_PLACE); + if (appendObjPtr == NULL) { + return TCL_ERROR; + } + } + } + + if (appendObjPtr == NULL) { + /* => (objc == 3) => (valuePtr == NULL) */ + TclNewObj(valuePtr); + } else if (valuePtr == NULL) { + valuePtr = appendObjPtr; + appendObjPtr = NULL; + } + + if (appendObjPtr) { + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + + Tcl_IncrRefCount(appendObjPtr); + Tcl_AppendObjToObj(valuePtr, appendObjPtr); + Tcl_DecrRefCount(appendObjPtr); + } + + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); + /* + * Even if nothing changed, we still overwrite so that variable + * trace expectations are met. + */ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f62c260..6ea3397 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -38,7 +38,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr); * reporting of inner contexts in errorstack without string allocation. */ -static const Tcl_ObjType tclInstNameType = { +static const Tcl_ObjType instNameType = { "instname", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -46,12 +46,21 @@ static const Tcl_ObjType tclInstNameType = { NULL, /* setFromAnyProc */ }; -/* - * How to get the bytecode out of a Tcl_Obj. - */ +#define InstNameSetIntRep(objPtr, inst) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.wideValue = (inst); \ + Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ + } while (0) + +#define InstNameGetIntRep(objPtr, inst) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &instNameType); \ + assert(irPtr != NULL); \ + (inst) = (size_t)irPtr->wideValue; \ + } while (0) -#define BYTECODE(objPtr) \ - ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) /* *---------------------------------------------------------------------- @@ -191,7 +200,7 @@ TclPrintObject( char *bytes; int length; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -245,17 +254,20 @@ DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; - Interp *iPtr = (Interp *) *codePtr->interpHandle; + Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; - char ptrBuf1[20], ptrBuf2[20]; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + + iPtr = (Interp *) *codePtr->interpHandle; TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { + if (!codePtr->refCount) { return bufferObj; /* Already freed. */ } @@ -267,11 +279,9 @@ DisassembleByteCodeObj( * Print header lines describing the ByteCode. */ - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, @@ -314,10 +324,9 @@ DisassembleByteCodeObj( Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; - sprintf(ptrBuf1, "%p", procPtr); Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, + " Proc %p, refCt %u, args %d, compiled locals %d\n", + procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; @@ -648,7 +657,7 @@ FormatInstruction( int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); @@ -800,9 +809,8 @@ TclNewInstNameObj( { Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; + TclInvalidateStringRep(objPtr); + InstNameSetIntRep(objPtr, (long) inst); return objPtr; } @@ -821,20 +829,22 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; + size_t inst; /* NOTE: We know this is really an unsigned char */ + char *dst; - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; + InstNameGetIntRep(objPtr, inst); + + if (inst > LAST_INST_OPCODE) { + dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); + TclOOM(dst, TCL_INTEGER_SPACE + 5); + sprintf(dst, "inst_%" TCL_Z_MODIFIER "d", inst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + const char *s = tclInstructionTable[inst].name; + unsigned int len = strlen(s); + dst = Tcl_InitStringRep(objPtr, s, len); + TclOOM(dst, len); } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; } /* @@ -898,7 +908,7 @@ PrintSourceToObj( Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); i += 10; } else -#elif TCL_UTF_MAX > 3 +#else /* If len == 0, this means we have a char > 0xffff, resulting in * TclUtfToUniChar producing a surrogate pair. We want to output * this pair as a single Unicode character. @@ -946,13 +956,15 @@ DisassembleByteCodeAsDicts( * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + /* * Get the literals from the bytecode. */ @@ -1290,6 +1302,7 @@ Tcl_DisassembleObjCmd( Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; + ByteCode *codePtr; Method *methodPtr; if (objc < 2) { @@ -1308,27 +1321,19 @@ Tcl_DisassembleObjCmd( /* * Compile (if uncompiled) and disassemble a lambda term. - * - * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); return TCL_ERROR; } - if (objv[2]->typePtr == &tclLambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = tclLambdaType.setFromAnyProc(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + + procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); + if (procPtr == NULL) { + return TCL_ERROR; } memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; @@ -1378,8 +1383,9 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + + if ((NULL == Tcl_FetchIntRep(objv[2], &tclByteCodeType)) && (TCL_OK + != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { return TCL_ERROR; } codeObjPtr = objv[2]; @@ -1579,7 +1585,7 @@ Tcl_DisassembleObjCmd( "METHODTYPE", NULL); return TCL_ERROR; } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (NULL == Tcl_FetchIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1607,14 +1613,16 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } - if (PTR2INT(clientData)) { + if (clientData) { Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(interp, codeObjPtr)); } else { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2548b73..6d32676 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -46,7 +46,7 @@ typedef struct Encoding { * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - int refCount; /* Number of uses of this structure. */ + size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -279,6 +279,21 @@ static int Iso88591ToUtfProc(ClientData clientData, static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; +#define EncodingSetIntRep(objPtr, encoding) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (encoding); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ + } while (0) + +#define EncodingGetIntRep(objPtr, encoding) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep ((objPtr), &encodingType); \ + (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -305,17 +320,16 @@ Tcl_GetEncodingFromObj( Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { - const char *name = Tcl_GetString(objPtr); - - if (objPtr->typePtr != &encodingType) { - Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); + Tcl_Encoding encoding; + const char *name = TclGetString(objPtr); + EncodingGetIntRep(objPtr, encoding); + if (encoding == NULL) { + encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = encoding; - objPtr->typePtr = &encodingType; + EncodingSetIntRep(objPtr, encoding); } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; @@ -335,8 +349,10 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); - objPtr->typePtr = NULL; + Tcl_Encoding encoding; + + EncodingGetIntRep(objPtr, encoding); + Tcl_FreeEncoding(encoding); } /* @@ -354,7 +370,8 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); + EncodingSetIntRep(dupPtr, encoding); } /* @@ -562,7 +579,7 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ - type.encodingName = "identity"; + type.encodingName = NULL; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; @@ -692,6 +709,7 @@ TclFinalizeEncodingSubsystem(void) *------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { @@ -704,7 +722,7 @@ Tcl_GetDefaultEncodingDir(void) } Tcl_ListObjIndex(NULL, searchPath, 0, &first); - return Tcl_GetString(first); + return TclGetString(first); } /* @@ -735,6 +753,7 @@ Tcl_SetDefaultEncodingDir( Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } +#endif /* *------------------------------------------------------------------------- @@ -843,18 +862,16 @@ FreeEncoding( if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount<=0) { - Tcl_Panic("FreeEncoding: refcount problem !!!"); - } - encodingPtr->refCount--; - if (encodingPtr->refCount == 0) { + if (encodingPtr->refCount-- <= 1) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - ckfree(encodingPtr->name); + if (encodingPtr->name) { + ckfree(encodingPtr->name); + } ckfree(encodingPtr); } } @@ -1043,9 +1060,24 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { + Encoding *encodingPtr = ckalloc(sizeof(Encoding)); + encodingPtr->name = NULL; + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = (LengthProc *) strlen; + } else { + encodingPtr->lengthProc = (LengthProc *) unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = NULL; + + if (typePtr->encodingName) { Tcl_HashEntry *hPtr; int isNew; - Encoding *encodingPtr; char *name; Tcl_MutexLock(&encodingMutex); @@ -1056,30 +1088,17 @@ Tcl_CreateEncoding( * reference goes away. */ - encodingPtr = Tcl_GetHashValue(hPtr); - encodingPtr->hPtr = NULL; + Encoding *replaceMe = Tcl_GetHashValue(hPtr); + replaceMe->hPtr = NULL; } name = ckalloc(strlen(typePtr->encodingName) + 1); - - encodingPtr = ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); - encodingPtr->toUtfProc = typePtr->toUtfProc; - encodingPtr->fromUtfProc = typePtr->fromUtfProc; - encodingPtr->freeProc = typePtr->freeProc; - encodingPtr->nullSize = typePtr->nullSize; - encodingPtr->clientData = typePtr->clientData; - if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = (LengthProc *) strlen; - } else { - encodingPtr->lengthProc = (LengthProc *) unilen; - } - encodingPtr->refCount = 1; encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - + } return (Tcl_Encoding) encodingPtr; } @@ -1518,10 +1537,10 @@ OpenEncodingFileChannel( } } if (!verified) { - const char *dirString = Tcl_GetString(directory); + const char *dirString = TclGetString(directory); for (i=0; i<numDirs && !verified; i++) { - if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) { + if (strcmp(dirString, TclGetString(dir[i])) == 0) { verified = 1; } } @@ -1762,7 +1781,7 @@ LoadTableEncoding( const char *p; Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); - p = Tcl_GetString(objPtr); + p = TclGetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; @@ -2055,7 +2074,7 @@ LoadEscapeEncoding( dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData), - (size_t) Tcl_DStringLength(&escapeData)); + Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); @@ -2296,8 +2315,11 @@ UtfToUtfProc( const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; - Tcl_UniChar ch = 0; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } result = TCL_OK; srcStart = src; @@ -2349,12 +2371,19 @@ UtfToUtfProc( * incomplete char its bytes are made to represent themselves. */ - ch = (unsigned char) *src; + *chPtr = (unsigned char) *src; src += 1; - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(*chPtr, dst); } else { - src += TclUtfToUniChar(src, &ch); - dst += Tcl_UniCharToUtf(ch, dst); + int len = TclUtfToUniChar(src, chPtr); + src += len; + dst += Tcl_UniCharToUtf(*chPtr, dst); +#if TCL_UTF_MAX <= 4 + if (!len) { + src += TclUtfToUniChar(src, chPtr); + dst += Tcl_UniCharToUtf(*chPtr, dst); + } +#endif } } @@ -2410,8 +2439,11 @@ UnicodeToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars, charLimit = INT_MAX; - Tcl_UniChar ch = 0; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } @@ -2439,11 +2471,11 @@ UnicodeToUtfProc( * Tcl_UniChar-size data. */ - ch = *(Tcl_UniChar *)src; - if (ch && ch < 0x80) { - *dst++ = (ch & 0xFF); + *chPtr = *(Tcl_UniChar *)src; + if (*chPtr && *chPtr < 0x80) { + *dst++ = (*chPtr & 0xFF); } else { - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(*chPtr, dst); } src += sizeof(Tcl_UniChar); } @@ -2500,8 +2532,11 @@ UtfToUnicodeProc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar ch = 0; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2527,7 +2562,7 @@ UtfToUnicodeProc( result = TCL_CONVERT_NOSPACE; break; } - src += TclUtfToUniChar(src, &ch); + src += TclUtfToUniChar(src, chPtr); /* * Need to handle this in a way that won't cause misalignment by @@ -2536,23 +2571,23 @@ UtfToUnicodeProc( #ifdef WORDS_BIGENDIAN #if TCL_UTF_MAX > 4 - *dst++ = (ch >> 24); - *dst++ = ((ch >> 16) & 0xFF); - *dst++ = ((ch >> 8) & 0xFF); - *dst++ = (ch & 0xFF); + *dst++ = (*chPtr >> 24); + *dst++ = ((*chPtr >> 16) & 0xFF); + *dst++ = ((*chPtr >> 8) & 0xFF); + *dst++ = (*chPtr & 0xFF); #else - *dst++ = (ch >> 8); - *dst++ = (ch & 0xFF); + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); #endif #else #if TCL_UTF_MAX > 4 - *dst++ = (ch & 0xFF); - *dst++ = ((ch >> 8) & 0xFF); - *dst++ = ((ch >> 16) & 0xFF); - *dst++ = (ch >> 24); + *dst++ = (*chPtr & 0xFF); + *dst++ = ((*chPtr >> 8) & 0xFF); + *dst++ = ((*chPtr >> 16) & 0xFF); + *dst++ = (*chPtr >> 24); #else - *dst++ = (ch & 0xFF); - *dst++ = (ch >> 8); + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); #endif #endif } @@ -2754,7 +2789,7 @@ TableFromUtfProc( } len = TclUtfToUniChar(src, &ch); -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 /* * This prevents a crash condition. More evaluation is required for * full support of int Tcl_UniChar. [Bug 1004065] @@ -2763,6 +2798,10 @@ TableFromUtfProc( if (ch & 0xffff0000) { word = 0; } else +#else + if (!len) { + word = 0; + } else #endif word = fromUnicode[(ch >> 8)][ch & 0xff]; @@ -2960,12 +2999,18 @@ Iso88591FromUtfProc( * Check for illegal characters. */ - if (ch > 0xff) { + if (ch > 0xff +#if TCL_UTF_MAX <= 4 + || !len +#endif + ) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } - +#if TCL_UTF_MAX <= 4 + if (!len) len = 4; +#endif /* * Plunge on, using '?' as a fallback character. */ @@ -3599,11 +3644,11 @@ unilen( static void InitializeEncodingSearchPath( char **valuePtr, - int *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs, numBytes; + int i, numDirs; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); @@ -3633,11 +3678,11 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); + bytes = TclGetString(searchPathObj); - *lengthPtr = numBytes; - *valuePtr = ckalloc(numBytes + 1); - memcpy(*valuePtr, bytes, (size_t) numBytes + 1); + *lengthPtr = searchPathObj->length; + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b79eaa3..b710399 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -21,8 +21,6 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NsEnsembleImplementationCmdNR(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); @@ -86,22 +84,36 @@ static const Tcl_ObjType ensembleCmdType = { NULL /* setFromAnyProc */ }; +#define ECRSetIntRep(objPtr, ecRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (ecRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ + } while (0) + +#define ECRGetIntRep(objPtr, ecRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* - * The internal rep for caching ensemble subcommand lookups and - * spell corrections. + * The internal rep for caching ensemble subcommand lookups and spelling + * corrections. */ typedef struct { - int epoch; /* Used to confirm when the data in this + unsigned int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ - Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand - * hash table. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash + * table. */ } EnsembleCmdRep; - static inline Tcl_Obj * NewNsObj( @@ -111,9 +123,8 @@ NewNsObj( if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); - } else { - return Tcl_NewStringObj(nsPtr->fullName, -1); } + return Tcl_NewStringObj(nsPtr->fullName, -1); } /* @@ -146,10 +157,12 @@ TclNamespaceEnsembleCmd( Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; + const char *simpleName; int index, done; if (nsPtr == NULL || nsPtr->flags & NS_DYING) { @@ -195,13 +208,8 @@ TclNamespaceEnsembleCmd( objv += 2; objc -= 2; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; /* * Parse the option list, applying type checks as we go. Note that we @@ -221,6 +229,7 @@ TclNamespaceEnsembleCmd( switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); + cxtPtr = nsPtr; continue; case CRT_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { @@ -304,7 +313,8 @@ TclNamespaceEnsembleCmd( Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } - Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done); + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, + &done); } while (!done); if (allocatedMapFlag) { @@ -337,6 +347,10 @@ TclNamespaceEnsembleCmd( } } + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, + &actualCxtPtr, &simpleName); + /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we @@ -344,7 +358,8 @@ TclNamespaceEnsembleCmd( * we've created it (and after any deletions have occurred.) */ - token = Tcl_CreateEnsemble(interp, name, NULL, + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); @@ -573,7 +588,8 @@ TclNamespaceEnsembleCmd( Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, + &newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } @@ -636,48 +652,36 @@ TclNamespaceEnsembleCmd( /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- - * - * Create a simple ensemble attached to the given namespace. + * TclCreateEnsembleInNs -- * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_CreateEnsemble( +TclCreateEnsembleInNs( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, + const char *name, /* Simple name of command to create (no + * namespace components). */ + Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command + * in. */ + Tcl_Namespace *ensembleNsPtr, + /* Name of the namespace for the ensemble. */ int flags) { - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = NewNsObj((Tcl_Namespace *) nsPtr); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = TclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; } ensemblePtr->nsPtr = nsPtr; @@ -690,9 +694,7 @@ Tcl_CreateEnsemble( ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -709,15 +711,52 @@ Tcl_CreateEnsemble( ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } return ensemblePtr->token; } /* *---------------------------------------------------------------------- * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. Deprecated + * (internally) by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. @@ -742,7 +781,7 @@ Tcl_SetEnsembleSubcommandList( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -818,7 +857,7 @@ Tcl_SetEnsembleParameterList( Tcl_Obj *oldList; int length; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -894,7 +933,7 @@ Tcl_SetEnsembleMappingDict( EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -993,7 +1032,7 @@ Tcl_SetEnsembleUnknownHandler( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1059,7 +1098,7 @@ Tcl_SetEnsembleFlags( EnsembleConfig *ensemblePtr; int wasCompiled; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1135,7 +1174,7 @@ Tcl_GetEnsembleSubcommandList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1177,7 +1216,7 @@ Tcl_GetEnsembleParameterList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1219,7 +1258,7 @@ Tcl_GetEnsembleMappingDict( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1260,7 +1299,7 @@ Tcl_GetEnsembleUnknownHandler( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1301,7 +1340,7 @@ Tcl_GetEnsembleFlags( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1342,7 +1381,7 @@ Tcl_GetEnsembleNamespace( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1392,7 +1431,7 @@ Tcl_FindEnsemble( return NULL; } - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. @@ -1400,7 +1439,8 @@ Tcl_FindEnsemble( cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ + if (cmdPtr == NULL + || cmdPtr->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1438,11 +1478,11 @@ Tcl_IsEnsemble( { Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + if (cmdPtr->objProc == TclEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) { return 0; } return 1; @@ -1605,7 +1645,7 @@ TclMakeEnsemble( Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - ckfree((char *) nameParts); + ckfree(nameParts); } return ensemble; } @@ -1613,7 +1653,7 @@ TclMakeEnsemble( /* *---------------------------------------------------------------------- * - * NsEnsembleImplementationCmd -- + * TclEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with the same @@ -1632,8 +1672,8 @@ TclMakeEnsemble( *---------------------------------------------------------------------- */ -static int -NsEnsembleImplementationCmd( +int +TclEnsembleImplementationCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -1717,10 +1757,10 @@ NsEnsembleImplementationCmdNR( * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ + EnsembleCmdRep *ensembleCmd; - if (subObj->typePtr==&ensembleCmdType){ - EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - + ECRGetIntRep(subObj, ensembleCmd); + if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); @@ -1771,7 +1811,7 @@ NsEnsembleImplementationCmdNR( int tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); + subcmdName = TclGetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -1885,6 +1925,7 @@ NsEnsembleImplementationCmdNR( TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2084,22 +2125,27 @@ TclSpellFix( iPtr->ensembleRewrite.numInsertedObjs = 0; } - /* Compute the valid length of the ensemble root */ + /* + * Compute the valid length of the ensemble root. + */ size = iPtr->ensembleRewrite.numRemovedObjs + objc - - iPtr->ensembleRewrite.numInsertedObjs; + - iPtr->ensembleRewrite.numInsertedObjs; search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { - /* Awful casting abuse here */ + /* + * Awful casting abuse here... + */ search = (Tcl_Obj *const *) search[1]; } if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { /* - * Misspelled value was inserted. We cannot directly jump - * to the bad value, but have to search. + * Misspelled value was inserted. We cannot directly jump to the bad + * value, but have to search. */ + idx = 1; while (idx < size) { if (search[idx] == bad) { @@ -2123,13 +2169,14 @@ TclSpellFix( search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { - store = (Tcl_Obj **)search[2]; - } else { + store = (Tcl_Obj **) search[2]; + } else { Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *)); + tmp[0] = NULL; - tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs; - tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *)); - memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *)); + tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs; + tmp[2] = (Tcl_Obj *) ckalloc(size * sizeof(Tcl_Obj *)); + memcpy(tmp[2], tmp[1], size * sizeof(Tcl_Obj *)); iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp; TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL); @@ -2346,8 +2393,8 @@ MakeCachedEnsembleCommand( { register EnsembleCmdRep *ensembleCmd; - if (objPtr->typePtr == &ensembleCmdType) { - ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + ECRGetIntRep(objPtr, ensembleCmd); + if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); @@ -2358,10 +2405,8 @@ MakeCachedEnsembleCommand( * our own. */ - TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &ensembleCmdType; + ECRSetIntRep(objPtr, ensembleCmd); } /* @@ -2549,19 +2594,16 @@ BuildEnsembleConfig( name = TclGetString(subv[i+1]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (isNew) { - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } + cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } } else { - /* Usual case where we can freely act on the list and dict. */ + /* + * Usual case where we can freely act on the list and dict. + */ for (i = 0; i < subc; i++) { name = TclGetString(subv[i]); @@ -2570,7 +2612,10 @@ BuildEnsembleConfig( continue; } - /* Lookup target in the dictionary */ + /* + * Lookup target in the dictionary. + */ + if (mapDict) { Tcl_DictObjGet(NULL, mapDict, subv[i], &target); if (target) { @@ -2582,16 +2627,12 @@ BuildEnsembleConfig( /* * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the - * command is actually there; that is the programmer's - * responsibility (or [::unknown] of course). + * Note in this case that we do not guarantee that the command + * is actually there; that is the programmer's responsibility + * (or [::unknown] of course). */ - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } + + cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); @@ -2619,53 +2660,49 @@ BuildEnsembleConfig( Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { - /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. - * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. - */ + /* + * Discover what commands are actually exported by the namespace. + * What we have is an array of patterns and a hash table whose keys + * are the command names exported by the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Note that we use an intermediate + * hash table to make memory management easier, and because that makes + * exact matching far easier too. + * + * Suggestion for future enhancement: compute the unique prefixes and + * place them in the hash too, which should make for even faster + * matching. + */ - hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); - for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { - char *nsCmdName = /* Name of command in namespace. */ - Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); - - for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { - if (Tcl_StringMatch(nsCmdName, - ensemblePtr->nsPtr->exportArrayPtr[i])) { - hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); - - /* - * Remember, hash entries have a full reference to the - * substituted part of the command (as a list) as their - * content! - */ - - if (isNew) { - Tcl_Obj *cmdObj, *cmdPrefixObj; - - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - break; - } - } - } + hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); + for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { + char *nsCmdName = /* Name of command in namespace. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + + for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { + if (Tcl_StringMatch(nsCmdName, + ensemblePtr->nsPtr->exportArrayPtr[i])) { + hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); + + /* + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! + */ + + if (isNew) { + Tcl_Obj *cmdObj, *cmdPrefixObj; + + cmdObj = Tcl_NewStringObj(nsCmdName, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + break; + } + } + } } if (hash->numEntries == 0) { @@ -2773,14 +2810,14 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; + ECRGetIntRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } ckfree(ensembleCmd); - objPtr->typePtr = NULL; } /* @@ -2806,11 +2843,12 @@ DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - copyPtr->typePtr = &ensembleCmdType; - copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ECRGetIntRep(objPtr, ensembleCmd); + ECRSetIntRep(copyPtr, ensembleCopy); + ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; @@ -2936,7 +2974,7 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); + str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! @@ -3325,7 +3363,7 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; char *bytes; - int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3338,15 +3376,15 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); + bytes = TclGetString(words[i-1]); + PushLiteral(envPtr, bytes, words[i-1]->length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); + int literal = TclRegisterLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3367,11 +3405,11 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8cc4b74..40ced17 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -723,14 +723,25 @@ TclFinalizeEnvironment(void) * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty - * unlikely, so we don't bother. + * unlikely, so we don't bother. However, in the case of DPURIFY, just + * free all strings in the cache. */ if (env.cache) { +#ifdef PURIFY + int i; + for (i = 0; i < env.cacheSize; i++) { + ckfree(env.cache[i]); + } +#endif ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV + if ((env.ourEnviron != NULL)) { + ckfree(env.ourEnviron); + env.ourEnviron = NULL; + } env.ourEnvironSize = 0; #endif } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index b0b8188..913ff0f 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors @@ -100,7 +100,7 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#ifdef TCL_THREADS +#if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ @@ -1043,6 +1043,9 @@ TclInitSubsystems(void) #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif +#if TCL_THREADS && defined(USE_THREAD_ALLOC) + TclInitThreadAlloc(); /* Setup thread allocator caches */ +#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif @@ -1054,7 +1057,6 @@ TclInitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } @@ -1218,7 +1220,7 @@ Tcl_Finalize(void) * Close down the thread-specific object allocator. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif @@ -1536,7 +1538,7 @@ Tcl_UpdateObjCmd( return TCL_OK; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1599,7 +1601,7 @@ Tcl_CreateThread( int flags) /* Flags controlling behaviour of the new * thread. */ { -#ifdef TCL_THREADS +#if TCL_THREADS ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); int result; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 761a23e..f38f7cd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -34,14 +34,14 @@ #endif /* - * A mask (should be 2**n-1) that is used to work out when the bytecode engine - * should call Tcl_AsyncReady() to see whether there is a signal that needs - * handling. + * A counter that is used to work out when the bytecode engine should call + * Tcl_AsyncReady() to see whether there is a signal that needs handling, and + * other expensive periodic operations. */ -#ifndef ASYNC_CHECK_COUNT_MASK -# define ASYNC_CHECK_COUNT_MASK 63 -#endif /* !ASYNC_CHECK_COUNT_MASK */ +#ifndef ASYNC_CHECK_COUNT +# define ASYNC_CHECK_COUNT 64 +#endif /* !ASYNC_CHECK_COUNT */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -498,29 +498,9 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ - ? (*(tPtr) = TCL_NUMBER_WIDE, \ + ? (*(tPtr) = TCL_NUMBER_INT, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ @@ -530,23 +510,8 @@ VarHashCreateVar( *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * int *boolPtr); - */ - -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - ((((objPtr)->typePtr == &tclIntType) \ - || ((objPtr)->typePtr == &tclBooleanType)) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -576,40 +541,6 @@ VarHashCreateVar( * Auxiliary tables used to compute powers of small integers. */ -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); - -/* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. - */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. @@ -713,7 +644,6 @@ static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. @@ -744,8 +674,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); @@ -820,20 +748,22 @@ ReleaseDictIterator( { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; + const Tcl_ObjIntRep *irPtr; + + irPtr = Tcl_FetchIntRep(objPtr, &dictIteratorType); + assert(irPtr != NULL); /* * First kill the search, and then release the reference to the dictionary * that we were holding. */ - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + searchPtr = irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); ckfree(searchPtr); - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + dictPtr = irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; } /* @@ -908,9 +838,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewBooleanObj(eePtr->constants[0], 0); + TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewBooleanObj(eePtr->constants[1], 1); + TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -1272,7 +1202,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree((char *) freePtr); + ckfree(freePtr); return; } @@ -1333,12 +1263,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } @@ -1496,11 +1426,9 @@ ExprObjCallback( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. * * Side effects: - * The Tcl_ObjType of objPtr is changed to the "bytecode" type, + * The Tcl_ObjType of objPtr is changed to the "exprcode" type, * and the ByteCode is kept in the internal rep (along with context * data for checking validity) for faster operations the next time * CompileExprObj is called on the same value. @@ -1524,28 +1452,31 @@ CompileExprObj( * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &exprCodeType) { + + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + + if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeExprCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &exprCodeType) { + + if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. */ - int length; - const char *string = TclGetStringFromObj(objPtr, &length); + const char *string = TclGetString(objPtr); - TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - TclCompileExpr(interp, string, length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); + TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -1553,7 +1484,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), &compEnv); } @@ -1564,10 +1495,8 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &exprCodeType; + codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1639,12 +1568,11 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + assert(codePtr != NULL); - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); } /* @@ -1680,7 +1608,8 @@ TclCompileObj( * compilation). Otherwise, check that it is "fresh" enough. */ - if (objPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the @@ -1698,7 +1627,6 @@ TclCompileObj( * here. */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1826,7 +1754,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1885,37 +1813,6 @@ TclIncrObj( return TCL_ERROR; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } -#endif - } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) @@ -1933,7 +1830,6 @@ TclIncrObj( return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1946,11 +1842,10 @@ TclIncrObj( */ if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); + TclSetIntObj(valuePtr, sum); return TCL_OK; } } -#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); @@ -2030,7 +1925,7 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - codePtr->refCount++; + TclPreserveByteCode(codePtr); /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame @@ -2119,8 +2014,14 @@ TEBCresume( * sporadically: no special need for speed. */ - int instructionCount = 0; /* Counter that is used to work out when to - * call Tcl_AsyncReady() */ + unsigned interruptCounter = 1; + /* Counter that is used to work out when to + * call Tcl_AsyncReady(). This must be 1 + * initially so that we call the async-check + * stanza early, otherwise there are command + * sequences that can make the interpreter + * busy-loop without an opportunity to + * recognise an interrupt. */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2318,10 +2219,11 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). + * ASYNC_CHECK_COUNT instructions. */ - if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if ((--interruptCounter) == 0) { + interruptCounter = ASYNC_CHECK_COUNT; DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -2535,7 +2437,7 @@ TEBCresume( /* 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)); + TclGetString(valuePtr)); } fflush(stdout); } @@ -2682,154 +2584,18 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_STR_CONCAT1: { - int appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - int onlyb = 1; + case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); - - /* - * Detect only-bytearray-or-null case. - */ - - for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { - if (((*currPtr)->typePtr != &tclByteArrayType) - && ((*currPtr)->bytes != tclEmptyStringRep)) { - onlyb = 0; - break; - } else if (((*currPtr)->typePtr == &tclByteArrayType) && - ((*currPtr)->bytes != NULL)) { - onlyb = 0; - break; - } - } - - /* - * Compute the length to be appended. - */ - - if (onlyb) { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - Tcl_GetByteArrayFromObj(*currPtr, &length); - appendLen += length; - } - } - } else { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; - } - } - } - - if (appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - /* - * If nothing is to be appended, just return the first object by - * dropping all the others from the stack; this saves both the - * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } - - /* - * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure it - * has enough room to accomodate all the concatenated bytes. Note that - * if it is unshared its bytes are copied by ckrealloc, so that we set - * the loop parameters to avoid copying them again: p points to the - * end of the already copied bytes, currPtr to the second object. - */ - - objResultPtr = OBJ_AT_DEPTH(opnd-1); - if (!onlyb) { - bytes = TclGetStringFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - p = ckalloc(length + appendLen + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } - } - *p = '\0'; - } else { - bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - TclNewObj(objResultPtr); - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); - p += length; - } - } + objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + TCL_STRING_IN_PLACE); + if (objResultPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); - } case INST_CONCAT_STK: /* @@ -3763,9 +3529,7 @@ TEBCresume( { Tcl_Obj *incrPtr; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; -#endif long increment; case INST_INCR_SCALAR1: @@ -3864,9 +3628,9 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; + if (type == TCL_NUMBER_INT) { + Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); + Tcl_WideInt sum = augend + increment; /* * Overflow when (augend and sum have different sign) and @@ -3878,16 +3642,15 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); + TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); + TclSetIntObj(objPtr, sum); } goto doneIncr; } -#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3904,44 +3667,10 @@ TEBCresume( * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+increment); + TclSetIntObj(objPtr, w+increment); } goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif + } /* end if (type == TCL_NUMBER_INT) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -3951,7 +3680,7 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); @@ -3965,7 +3694,7 @@ TEBCresume( * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -4169,7 +3898,8 @@ TEBCresume( } TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { + if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) + && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectUnsettable(varPtr)) { /* @@ -4294,17 +4024,12 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/0, /*createPart2*/0, &arrayPtr); doArrayExists: - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - DECACHE_STACK_INFO(); - result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, - NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| - TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_ERROR(interp); - goto gotError; - } + DECACHE_STACK_INFO(); + result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_ERROR(interp); + goto gotError; } if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { objResultPtr = TCONST(1); @@ -4353,10 +4078,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); #ifdef TCL_COMPILE_DEBUG TRACE_APPEND(("done\n")); } else { @@ -5046,8 +4768,8 @@ TEBCresume( */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) - && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, + && (NULL == Tcl_FetchIntRep(value2Ptr, &tclListType)) + && (TclGetIntForIndexM(NULL, value2Ptr, objc-1, &index) == TCL_OK)) { TclDecrRefCount(value2Ptr); tosPtr--; @@ -5089,16 +4811,9 @@ TEBCresume( goto gotError; } - /* - * Select the list item based on the index. Negative operand means - * end-based indexing. - */ + /* Decode end-offset index values. */ - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } + index = TclIndexDecode(opnd, objc - 1); pcAdjustment = 5; lindexFastPath: @@ -5226,11 +4941,11 @@ TEBCresume( TclGetInt4AtPtr(pc+5))); /* - * Get the contents of the list, making sure that it really is a list + * Get the length of the list, making sure that it really is a list * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5246,62 +4961,49 @@ TEBCresume( } #endif + /* Every range of an empty list is an empty list */ + if (objc == 0) { + TRACE_APPEND(("\n")); + NEXT_INST_F(9, 0, 0); + } + + /* Decode index value operands. */ + /* - * Adjust the indices for end-based handling. + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; + if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { + emptyList: + objResultPtr = Tcl_NewObj(); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; + toIdx = TclIndexDecode(toIdx, objc - 1); + if (toIdx < 0) { + goto emptyList; + } else if (toIdx >= objc) { + toIdx = objc - 1; } + assert ( toIdx >= 0 && toIdx < objc); /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. + assert ( fromIdx != TCL_INDEX_BEFORE ); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - /* - * BEWARE! This is looking inside the implementation of the - * list type. - */ - - List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; + fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (listPtr->refCount == 1) { - for (index=toIdx+1; index<objc ; index++) { - TclDecrRefCount(objv[index]); - } - listPtr->elemCount = toIdx+1; - listPtr->canonicalFlag = 1; - TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); @@ -5391,88 +5093,10 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (valuePtr == value2Ptr) { - match = 0; - } else { - /* - * We only need to check (in)equality when we have equal length - * strings. We can use memcmp in all (n)eq cases because we - * don't need to worry about lexical LE/BE variance. - */ - - typedef int (*memCmpFn_t)(const void*, const void*, size_t); - memCmpFn_t memCmpFn; + { int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); - - if (TclIsPureByteArray(valuePtr) - && TclIsPureByteArray(value2Ptr)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - memCmpFn = memcmp; - } else if ((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ - - s1len = Tcl_GetCharLength(valuePtr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == valuePtr->length) - && (valuePtr->bytes != NULL) - && (s2len == value2Ptr->length) - && (value2Ptr->bytes != NULL)) { - s1 = valuePtr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(valuePtr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; - } - } - } else { - /* - * strcmp can't do a simple memcmp in order to handle the - * special Tcl \xC0\x80 null encoding for utf-8. - */ - - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - if (checkEq) { - memCmpFn = memcmp; - } else { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; - } - } - - if (checkEq && (s1len != s2len)) { - match = 1; - } else { - /* - * The comparison function should compare up to the minimum - * byte length only. - */ - match = memCmpFn(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - if (match == 0) { - match = s1len - s2len; - } - } + match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1); } /* @@ -5596,17 +5220,23 @@ TEBCresume( objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + char buf[4]; + int ch = Tcl_GetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) * but creating the object as a string seems to be faster in * practical use. */ - - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); + if (ch == -1) { + objResultPtr = Tcl_NewObj(); + } else { + length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } + objResultPtr = Tcl_NewStringObj(buf, length); + } } TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); @@ -5645,31 +5275,58 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + /* Every range of an empty value is an empty value */ + if (length == 0) { + TRACE_APPEND(("\n")); + NEXT_INST_F(9, 0, 0); + } + + /* Decode index operands. */ + /* - * Adjust indices for end-based indexing. + assert ( toIdx != TCL_INDEX_BEFORE ); + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ - - if (fromIdx < -1) { - fromIdx += 1 + length; - if (fromIdx < 0) { - fromIdx = 0; - } - } else if (fromIdx >= length) { - fromIdx = length; + if (toIdx == TCL_INDEX_BEFORE) { + goto emptyRange; } - if (toIdx < -1) { - toIdx += 1 + length; + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } + + toIdx = TclIndexDecode(toIdx, length - 1); + if (toIdx < 0) { + goto emptyRange; } else if (toIdx >= length) { toIdx = length - 1; } + assert ( toIdx >= 0 && toIdx < length ); + /* - * Check if we can do a sane substring. + assert ( fromIdx != TCL_INDEX_BEFORE ); + assert ( fromIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } + if (fromIdx == TCL_INDEX_AFTER) { + goto emptyRange; + } + + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (fromIdx < 0) { + fromIdx = 0; + } if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { + emptyRange: TclNewObj(objResultPtr); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -5677,18 +5334,18 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + int length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - length = Tcl_GetCharLength(valuePtr) - 1; + endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); @@ -5698,103 +5355,33 @@ TEBCresume( (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); - if (fromIdx < 0) { - fromIdx = 0; - } - if (fromIdx > toIdx || fromIdx > length) { + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); } - if (toIdx > length) { - toIdx = length; + if (fromIdx < 0) { + fromIdx = 0; + } + + if (toIdx > endIdx) { + toIdx = endIdx; } - if (fromIdx == 0 && toIdx == length) { + if (fromIdx == 0 && toIdx == endIdx) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); NEXT_INST_F(1, 0, 0); } - length3 = Tcl_GetCharLength(value3Ptr); - - /* - * See if we can splice in place. This happens when the number of - * characters being replaced is the same as the number of characters - * in the string to be inserted. - */ - - if (length3 - 1 == toIdx - fromIdx) { - unsigned char *bytes1, *bytes2; - - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - } else { - objResultPtr = valuePtr; - } - if (TclIsPureByteArray(objResultPtr) - && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); - memcpy(bytes1 + fromIdx, bytes2, length3); - } else { - ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); - ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); - memcpy(ustring1 + fromIdx, ustring2, - length3 * sizeof(Tcl_UniChar)); - } - Tcl_InvalidateStringRep(objResultPtr); - TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - if (objResultPtr == valuePtr) { - NEXT_INST_F(1, 0, 0); - } else { - NEXT_INST_F(1, 1, 1); - } - } - - /* - * Get the unicode representation; this is where we guarantee to lose - * bytearrays. - */ - - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - length--; - - /* - * Remove substring using copying. - */ + objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, + toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); - objResultPtr = NULL; - if (fromIdx > 0) { - objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); - } - if (length3 > 0) { - if (objResultPtr) { - Tcl_AppendObjToObj(objResultPtr, value3Ptr); - } else if (Tcl_IsShared(value3Ptr)) { - objResultPtr = Tcl_DuplicateObj(value3Ptr); - } else { - objResultPtr = value3Ptr; - } - } - if (toIdx < length) { - if (objResultPtr) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, - length - toIdx); - } else { - objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, - length - toIdx); - } - } - if (objResultPtr == NULL) { - /* This has to be the case [string replace $s 0 end {}] */ - /* which has result {} which is same as value3Ptr. */ - objResultPtr = value3Ptr; - } if (objResultPtr == value3Ptr) { /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); @@ -5867,20 +5454,7 @@ TEBCresume( NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - end = ustring1 + length - length2 + 1; - for (p=ustring1 ; p<end ; p++) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); @@ -5888,23 +5462,10 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); @@ -5995,12 +5556,7 @@ TEBCresume( 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; - } + trim1 = TclTrim(string1, length, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we @@ -6078,35 +5634,18 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; - } else if (type1 == TCL_NUMBER_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 */ + /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */ Tcl_WideInt w; if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { - type1 = TCL_NUMBER_WIDE; + type1 = TCL_NUMBER_INT; } } TclNewIntObj(objResultPtr, type1); @@ -6124,6 +5663,14 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + /* + Try to determine, without triggering generation of a string + representation, whether one value is not a number. + */ + if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) { + goto stringCompare; + } + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { /* @@ -6144,10 +5691,10 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } @@ -6223,17 +5770,17 @@ TEBCresume( * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { + } else if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -6242,7 +5789,7 @@ TEBCresume( objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { + } else if (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ @@ -6252,24 +5799,24 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; + if ((wResult < 0 || (wResult == 0 && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult * w2 != w1)) { + wResult -= 1; } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + wResult = w1 - w2*wResult; + goto wideResultOfArithmetic; } case INST_RSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6280,7 +5827,7 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); @@ -6290,7 +5837,7 @@ TEBCresume( * Quickly force large right shifts to 0 or -1. */ - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe @@ -6299,7 +5846,7 @@ TEBCresume( */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { + if (w1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); @@ -6312,12 +5859,12 @@ TEBCresume( * Handle shifts within the native long range. */ - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + wResult = w1 >> ((int) w2); + goto wideResultOfArithmetic; } case INST_LSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6328,12 +5875,12 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { + } else if (w2 > INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do @@ -6351,17 +5898,17 @@ TEBCresume( #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) l2; + int shift = (int) w2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) + && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; + wResult = w1 << shift; + goto wideResultOfArithmetic; } } @@ -6373,23 +5920,14 @@ TEBCresume( break; case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; + wResult = w1 & w2; + goto wideResultOfArithmetic; case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; + wResult = w1 | w2; + goto wideResultOfArithmetic; case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w1 ^ w2; + goto wideResultOfArithmetic; } } @@ -6472,18 +6010,13 @@ TEBCresume( * an external function. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -6491,14 +6024,10 @@ TEBCresume( if (Overflowing(w1, w2, wResult)) { goto overflow; } -#endif goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -6512,7 +6041,6 @@ TEBCresume( if (Overflowing(w1, ~w2, wResult)) { goto overflow; } -#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { @@ -6520,45 +6048,45 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + } else if ((w1 == WIDE_MIN) && (w2 == -1)) { /* - * Can't represent (-LONG_MIN) as a long. + * Can't represent (-WIDE_MIN) as a Tcl_WideInt. */ goto overflow; } - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; } - goto longResultOfArithmetic; + goto wideResultOfArithmetic; case INST_MULT: - if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) - || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; + if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) + && (w1 <= INT_MAX) && (w1 >= INT_MIN) + && (w2 <= INT_MAX) && (w2 >= INT_MIN)) + || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) + && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) + && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { + wResult = w1 * w2; + goto wideResultOfArithmetic; } } @@ -6625,14 +6153,14 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); + if (type1 == TCL_NUMBER_INT) { + w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); + TclNewIntObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, ~l1); + TclSetIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6662,15 +6190,15 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { + case TCL_NUMBER_INT: + w1 = *((const Tcl_WideInt *) ptr1); + if (w1 != WIDE_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); + TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, -l1); + TclSetIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6814,7 +6342,8 @@ TEBCresume( Var *iterVarPtr, *listVarPtr; Tcl_Obj *oldValuePtr, *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; + int numLists, listTmpIndex, listLen, numVars; + size_t iterNum; int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; @@ -6831,10 +6360,10 @@ TEBCresume( oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); + TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetLongObj(oldValuePtr, -1); + TclSetIntObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); @@ -6868,8 +6397,8 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); + iterNum = (size_t)valuePtr->internalRep.wideValue + 1; + TclSetIntObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the @@ -6889,7 +6418,7 @@ TEBCresume( i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } - if (listLen > iterNum * numVars) { + if ((size_t)listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -6955,7 +6484,7 @@ TEBCresume( listTmpIndex++; } } - TRACE_APPEND(("%d lists, iter %d, %s loop\n", + TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "d, %s loop\n", numLists, iterNum, (continueLoop? "continue" : "exit"))); /* @@ -6976,8 +6505,9 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements, *tmpPtr; ForeachVarList *varListPtr; - int numLists, iterMax, listLen, numVars; - int iterTmp, iterNum, listTmpDepth; + int numLists, listLen, numVars; + int listTmpDepth; + size_t iterNum, iterMax, iterTmp; int varIndex, valIndex, j; long i; @@ -7028,8 +6558,8 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); - tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); + tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* @@ -7061,8 +6591,8 @@ TEBCresume( TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); - iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); - iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); + iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; + iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; /* * If some list still has a remaining list element iterate one more @@ -7074,7 +6604,7 @@ TEBCresume( * Set the variables and jump back to run the body */ - tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); + tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); listTmpDepth = numLists + 1; @@ -7582,13 +7112,16 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + { + Tcl_ObjIntRep ir; + TclNewObj(statePtr); + ir.twoPtrValue.ptr1 = searchPtr; + ir.twoPtrValue.ptr2 = dictPtr; + Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); + } varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + if (Tcl_FetchIntRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); @@ -7601,11 +7134,17 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); + { + const Tcl_ObjIntRep *irPtr; + + if (statePtr && + (irPtr = Tcl_FetchIntRep(statePtr, &dictIteratorType))) { + searchPtr = irPtr->twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + } else { + Tcl_Panic("mis-issued dictNext!"); + } } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); @@ -7868,7 +7407,6 @@ TEBCresume( default: Tcl_Panic("clockRead instruction with unknown clock#"); } - /* TclNewWideObj(objResultPtr, wval); doesn't exist */ objResultPtr = Tcl_NewWideIntObj(wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); @@ -8162,9 +7700,7 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); TclStackFree(interp, TD); /* free my stack */ return result; @@ -8302,19 +7838,11 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ @@ -8336,7 +7864,6 @@ ExecuteExtendedBinaryMathOp( int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; - long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; @@ -8350,13 +7877,13 @@ ExecuteExtendedBinaryMathOp( case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); - if (l2 == 0) { + w2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_INT) { + w2 = *((const Tcl_WideInt *)ptr2); + if (w2 == 0) { return DIVIDED_BY_ZERO; } - if ((l2 == 1) || (l2 == -1)) { + if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -8364,9 +7891,16 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef TCL_WIDE_INT_IS_LONG - if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_INT) { w1 = *((const Tcl_WideInt *)ptr1); + + if (w1 == 0) { + /* + * 0 % (non-zero) always yields remainder of 0. + */ + + return constants[0]; + } if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8396,7 +7930,7 @@ ExecuteExtendedBinaryMathOp( * Arguments are opposite sign; remainder is sum. */ - TclBNInitBignumFromWideInt(&big1, w1); + TclInitBignumFromWideInt(&big1, w1); mp_add(&big2, &big1, &big2); mp_clear(&big1); BIG_RESULT(&big2); @@ -8409,7 +7943,6 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); return NULL; } -#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -8436,17 +7969,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); + invalid = mp_isneg(&big2); mp_clear(&big2); break; default: @@ -8463,7 +7991,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } @@ -8476,8 +8004,8 @@ ExecuteExtendedBinaryMathOp( * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { + if ((type2 != TCL_NUMBER_INT) + || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the @@ -8489,7 +8017,7 @@ ExecuteExtendedBinaryMathOp( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const long *)ptr2)); + shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. @@ -8509,8 +8037,8 @@ ExecuteExtendedBinaryMathOp( * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + if ((type2 != TCL_NUMBER_INT) + || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could @@ -8520,17 +8048,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (mp_cmp_d(&big1, 0) == MP_GT); + zero = (!mp_isneg(&big1)); mp_clear(&big1); break; default: @@ -8540,26 +8063,24 @@ ExecuteExtendedBinaryMathOp( if (zero) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } - shift = (int)(*(const long *)ptr2); + shift = (int)(*(const Tcl_WideInt *)ptr2); -#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ - if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_INT) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w1 >= (Tcl_WideInt)0) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } -#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -8570,7 +8091,7 @@ ExecuteExtendedBinaryMathOp( } else { mp_init(&bigRemainder); mp_div_2d(&big1, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + if (mp_isneg(&bigRemainder)) { /* * Convert to Tcl's integer division rules. */ @@ -8597,14 +8118,14 @@ ExecuteExtendedBinaryMathOp( * arguments is negative, store it in 'Second'. */ - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); + if (!mp_isneg(&big1)) { + numPos = 1 + !mp_isneg(&big2); First = &big1; Second = &big2; } else { First = &big2; Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); + numPos = (!mp_isneg(First)); } mp_init(&bigResult); @@ -8727,8 +8248,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8748,25 +8268,24 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } -#endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: - lResult = l1 & l2; + wResult = w1 & w2; break; case INST_BITOR: - lResult = l1 | l2; + wResult = w1 | w2; break; case INST_BITXOR: - lResult = l1 ^ l2; + wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ - lResult = 0; + wResult = 0; } - LONG_RESULT(lResult); + WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; @@ -8782,16 +8301,16 @@ ExecuteExtendedBinaryMathOp( dResult = pow(d1, d2); goto doubleResult; } - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { + w2 = 0; + if (type2 == TCL_NUMBER_INT) { + w2 = *((const Tcl_WideInt *) ptr2); + if (w2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (l2 == 1) { + } else if (w2 == 1) { /* * Anything to the first power is itself */ @@ -8801,32 +8320,26 @@ ExecuteExtendedBinaryMathOp( } switch (type2) { - case TCL_NUMBER_LONG: - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + negativeExponent = mp_isneg(&big2); mp_mod_2d(&big2, 1, &big2); oddExponent = !mp_iszero(&big2); mp_clear(&big2); break; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); + if (type1 == TCL_NUMBER_INT) { + w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_INT) { + switch (w1) { case 0: /* * Zero to a negative power is div by zero error. @@ -8835,7 +8348,7 @@ ExecuteExtendedBinaryMathOp( return EXPONENT_OF_ZERO; case -1: if (oddExponent) { - LONG_RESULT(-1); + WIDE_RESULT(-1); } /* fallthrough */ case 1: @@ -8855,8 +8368,8 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_INT) { + switch (w1) { case 0: /* * Zero to a positive power is zero. @@ -8873,7 +8386,7 @@ ExecuteExtendedBinaryMathOp( if (!oddExponent) { return constants[1]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } } @@ -8882,141 +8395,58 @@ ExecuteExtendedBinaryMathOp( * which means the max exponent value is 2**28-1 = 0x0fffffff = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we + * not using TCL_NUMBER_INT type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_LONG) { + if (type2 != TCL_NUMBER_INT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { + if (type1 == TCL_NUMBER_INT) { + if (w1 == 2) { /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); + if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); - } -#endif goto overflowExpon; } - if (l1 == -2) { + if (w1 == -2) { int signum = oddExponent ? -1 : 1; /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); + if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); - } -#endif goto overflowExpon; } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - lResult = l1 * l1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - LONG_RESULT(lResult); - } - - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - LONG_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); - } - } -#endif } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; -#ifndef TCL_WIDE_INT_IS_LONG - } else if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_INT) { w1 = *((const Tcl_WideInt *) ptr1); -#endif } else { goto overflowExpon; } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + if (w2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[w2 - 2] + && w1 >= -MaxBase64[w2 - 2]) { /* * Small powers of integers whose result is wide. */ wResult = w1 * w1; /* b**2 */ - switch (l2) { + switch (w2) { case 2: break; case 3: - wResult *= l1; /* b**3 */ + wResult *= w1; /* b**3 */ break; case 4: wResult *= wResult; /* b**4 */ @@ -9093,9 +8523,9 @@ ExecuteExtendedBinaryMathOp( */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -9107,9 +8537,9 @@ ExecuteExtendedBinaryMathOp( } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -9120,7 +8550,6 @@ ExecuteExtendedBinaryMathOp( WIDE_RESULT(wResult); } } -#endif overflowExpon: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -9132,7 +8561,7 @@ ExecuteExtendedBinaryMathOp( } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1); mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); @@ -9200,9 +8629,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { /* * Check for overflow. @@ -9216,9 +8643,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { /* * Must check for overflow. The macro tests for overflows @@ -9238,8 +8663,7 @@ ExecuteExtendedBinaryMathOp( break; case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; @@ -9251,10 +8675,10 @@ ExecuteExtendedBinaryMathOp( } /* - * Need a bignum to represent (LLONG_MIN / -1) + * Need a bignum to represent (WIDE_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { + if ((w1 == WIDE_MIN) && (w2 == -1)) { goto overflowBasic; } wResult = w1 / w2; @@ -9342,12 +8766,10 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_INT) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); @@ -9357,22 +8779,13 @@ ExecuteExtendedUnaryMathOp( switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclBNInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w = *((const Tcl_WideInt *) ptr); - if (w != LLONG_MIN) { + if (w != WIDE_MIN) { WIDE_RESULT(-w); } - TclBNInitBignumFromWideInt(&big, w); + TclInitBignumFromWideInt(&big, w); break; -#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } @@ -9383,7 +8796,6 @@ ExecuteExtendedUnaryMathOp( Tcl_Panic("unexpected opcode"); return NULL; } -#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT @@ -9415,31 +8827,22 @@ TclCompareTwoNumbers( ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; - long l1, l2; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; -#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); + case TCL_NUMBER_INT: + w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) l1; + d1 = (double) w1; /* * If the double has a fractional part, or if the long can be @@ -9447,7 +8850,7 @@ TclCompareTwoNumbers( * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } @@ -9464,55 +8867,17 @@ TclCompareTwoNumbers( * integer comparison can tell the difference. */ - if (d2 < (double)LONG_MIN) { - return MP_GT; - } - if (d2 > (double)LONG_MAX) { - return MP_LT; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { + if (d2 < (double)WIDE_MIN) { return MP_GT; } - if (d2 > (double)LLONG_MAX) { + if (d2 > (double)WIDE_MAX) { return MP_LT; } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9520,7 +8885,6 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } -#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -9529,45 +8893,28 @@ TclCompareTwoNumbers( d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } - if (d1 < (double)LLONG_MIN) { + if (d1 < (double)WIDE_MIN) { return MP_LT; } - if (d1 > (double)LLONG_MAX) { + if (d1 > (double)WIDE_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; goto wideCompare; -#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { + if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9588,10 +8935,7 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: + case TCL_NUMBER_INT: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -9602,7 +8946,7 @@ TclCompareTwoNumbers( mp_clear(&big1); return compare; } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -9656,8 +9000,8 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); @@ -9755,7 +9099,7 @@ ValidatePcAndStackTop( TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); + fprintf(stderr,"%s\n", TclGetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); @@ -9805,7 +9149,7 @@ IllegalExprOperandType( if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -10218,7 +9562,7 @@ TclExprFloatError( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), NULL); + TclGetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -10431,10 +9775,10 @@ EvalStatsCmd( for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + if (NULL != Tcl_FetchIntRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10656,7 +10000,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); + char *str = TclGetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index bb814ea..ea2a1c5 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -240,9 +240,13 @@ TclFileMakeDirsCmd( break; } for (j = 0; j < pobjc; j++) { + int errCount = 2; + target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); + createDir: + /* * Call Tcl_FSStat() so that if target is a symlink that points to * a directory we will create subdirectories in that directory. @@ -269,23 +273,25 @@ TclFileMakeDirsCmd( * subdirectory. */ - if (errno != EEXIST) { - errfile = target; - goto done; - } else if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, so keep - * going without error. - */ - - Tcl_ResetResult(interp); - } else { - errfile = target; - goto done; + if (errno == EEXIST) { + /* Be aware other workers could delete it immediately after + * creation, so give this worker still one chance (repeat once), + * see [270f78ca95] for description of the race-condition. + * Don't repeat the create always (to avoid endless loop). */ + if (--errCount > 0) { + goto createDir; + } + /* Already tried, with delete in-between directly after + * creation, so just continue (assume created successful). */ + goto nextPart; } + + /* return with error */ + errfile = target; + goto done; } + nextPart: /* * Forget about this sub-path. */ @@ -363,14 +369,7 @@ TclFileDeleteCmd( */ if (Tcl_FSLstat(objv[i], &statBuf) != 0) { - /* - * Trying to delete a file that does not exist is not considered - * an error, just a no-op - */ - - if (errno != ENOENT) { - result = TCL_ERROR; - } + result = TCL_ERROR; } else if (S_ISDIR(statBuf.st_mode)) { /* * We own a reference count on errorBuffer, if it was set as a @@ -406,13 +405,20 @@ TclFileDeleteCmd( } if (result != TCL_OK) { - result = TCL_ERROR; /* + * Avoid possible race condition (file/directory deleted after call + * of lstat), so bypass ENOENT because not an error, just a no-op + */ + if (errno == ENOENT) { + result = TCL_OK; + continue; + } + /* * It is important that we break on error, otherwise we might end * up owning reference counts on numerous errorBuffers. */ - + result = TCL_ERROR; break; } } @@ -1079,12 +1085,9 @@ TclFileAttrsCmd( } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } - if (attributeStringsAllocated != NULL) { - TclFreeIntRep(objv[0]); - } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1107,12 +1110,9 @@ TclFileAttrsCmd( for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } - if (attributeStringsAllocated != NULL) { - TclFreeIntRep(objv[i]); - } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 2136883..015cfc3 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -387,7 +387,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -578,7 +578,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - Tcl_GetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -597,7 +597,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = Tcl_GetStringFromObj(eltPtr, &len); + str = TclGetStringFromObj(eltPtr, &len); memcpy(p, str, (size_t) len+1); p += len+1; } @@ -857,7 +857,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = Tcl_GetStringFromObj(prefix, &length); + start = TclGetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed @@ -885,7 +885,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -921,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -1003,7 +1003,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1249,7 +1249,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = Tcl_GetStringFromObj(objv[i], &length); + string = TclGetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1357,7 +1357,7 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; const char *last; - const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *first = TclGetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1460,7 +1460,7 @@ Tcl_GlobObjCmd( const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = Tcl_GetStringFromObj(look, &len); + str = TclGetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1881,7 +1881,7 @@ TclGlob( separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/') { + if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); @@ -1904,7 +1904,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. @@ -1992,7 +1992,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + pre = TclGetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -2010,7 +2010,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2362,7 +2362,7 @@ DoGlob( Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); - bytes = Tcl_GetStringFromObj(fixme, &numBytes); + bytes = TclGetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); Tcl_ListObjReplace(NULL, matchesObj, repair, 1, 1, &newObj); @@ -2400,7 +2400,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) Tcl_GetStringFromObj(pathPtr, &length); + (void) TclGetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2446,7 +2446,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2483,7 +2483,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { diff --git a/generic/tclGet.c b/generic/tclGet.c index 97e8c7b..12e0e79 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -142,7 +142,7 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.longValue; + TclGetBooleanFromObj(NULL, &obj, boolPtr); } return code; } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index da4c3fd..9c67227 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -897,7 +897,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (isspace(UCHAR(*yyInput))) { + while (TclIsSpaceProc(UCHAR(*yyInput))) { yyInput++; } diff --git a/generic/tclHash.c b/generic/tclHash.c index 7e8961d..32c9aec 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -43,20 +43,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); - -/* - * Prototypes for the one word hash key methods. Not actually declared because - * this is a critical path that is implemented in the core hash table access - * function. - */ - -#if 0 -static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr, - void *keyPtr); -static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); -#endif +static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. @@ -65,7 +52,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -321,11 +308,9 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { -#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } -#endif if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { if (newPtr) { *newPtr = 0; @@ -336,11 +321,9 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { -#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } -#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; @@ -368,15 +351,9 @@ CreateHashEntry( } hPtr->tablePtr = tablePtr; -#if TCL_HASH_KEY_STORE_HASH hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; -#else - hPtr->bucketPtr = &tablePtr->buckets[index]; - hPtr->nextPtr = *hPtr->bucketPtr; - *hPtr->bucketPtr = hPtr; -#endif tablePtr->numEntries++; /* @@ -416,9 +393,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; -#if TCL_HASH_KEY_STORE_HASH int index; -#endif tablePtr = entryPtr->tablePtr; @@ -433,7 +408,6 @@ Tcl_DeleteHashEntry( typePtr = &tclArrayHashKeyType; } -#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); @@ -442,9 +416,6 @@ Tcl_DeleteHashEntry( } bucketPtr = &tablePtr->buckets[index]; -#else - bucketPtr = entryPtr->bucketPtr; -#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; @@ -790,7 +761,7 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static unsigned int +static TCL_HASH_TYPE HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -803,7 +774,7 @@ HashArrayKey( count--, array++) { result += *array; } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -886,7 +857,7 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static unsigned +static TCL_HASH_TYPE HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -932,7 +903,7 @@ HashStringKey( result += (result << 3) + UCHAR(c); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -940,7 +911,7 @@ HashStringKey( * * BogusFind -- * - * This function is invoked when an Tcl_FindHashEntry is called on a + * This function is invoked when Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: @@ -967,7 +938,7 @@ BogusFind( * * BogusCreate -- * - * This function is invoked when an Tcl_CreateHashEntry is called on a + * This function is invoked when Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: @@ -1065,7 +1036,6 @@ RebuildTable( for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; -#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); @@ -1074,26 +1044,6 @@ RebuildTable( } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; -#else - void *key = Tcl_GetHashKey(tablePtr, hPtr); - - if (typePtr->hashKeyProc) { - unsigned int hash; - - hash = typePtr->hashKeyProc(tablePtr, key); - if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hash); - } else { - index = hash & tablePtr->mask; - } - } else { - index = RANDOM_INDEX(tablePtr, key); - } - - hPtr->bucketPtr = &tablePtr->buckets[index]; - hPtr->nextPtr = *hPtr->bucketPtr; - *hPtr->bucketPtr = hPtr; -#endif } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b08e352..47806d4 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,15 +62,14 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; - int length = strlen(cmd); int result; - if (length > 0) { + if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); diff --git a/generic/tclIO.c b/generic/tclIO.c index e74624f..d144cbc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -116,7 +116,7 @@ typedef struct CopyState { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested * Tcl_NotifyChannel invocations. */ @@ -321,9 +321,9 @@ static int WillRead(Channel *chanPtr); typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - int epoch; /* The epoch of the channel when the lookup + size_t epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - int refCount; /* Share this struct among many Tcl_Obj. */ + size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -337,6 +337,22 @@ static const Tcl_ObjType chanObjType = { NULL /* setFromAnyProc */ }; +#define ChanSetIntRep(objPtr, resPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (resPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (resPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ + } while (0) + +#define ChanGetIntRep(objPtr, resPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &chanObjType); \ + (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -381,20 +397,20 @@ ChanCloseHalf( * * ChanRead -- * - * Read up to dstSize bytes using the inputProc of chanPtr, store - * them at dst, and return the number of bytes stored. + * 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(). + * - -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. + * 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? * *--------------------------------------------------------------------------- @@ -408,15 +424,17 @@ ChanRead( 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. + * If the caller asked for zero bytes, we'd force the inputProc to return + * zero bytes, and then misinterpret that as EOF. */ + assert(dstSize > 0); /* * Each read op must set the blocked and eof states anew, not let * the effect of prior reads leak through. */ + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } @@ -429,7 +447,10 @@ ChanRead( bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, &result); - /* Stop any flag leakage through stacked channel levels */ + /* + * Stop any flag leakage through stacked channel levels. + */ + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } @@ -437,10 +458,10 @@ ChanRead( chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; if (bytesRead > 0) { /* - * If we get a short read, signal up that we may be BLOCKED. - * We should avoid calling the driver because on some - * platforms we will block in the low level reading code even - * though the channel is set into nonblocking mode. + * If 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) { @@ -477,13 +498,13 @@ ChanSeek( offset, mode, errnoPtr); } - if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { + if (offset<LONG_MIN || offset>LONG_MAX) { *errnoPtr = EOVERFLOW; - return Tcl_LongAsWide(-1); + return -1; } - return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData, - Tcl_WideAsLong(offset), mode, errnoPtr)); + return chanPtr->typePtr->seekProc(chanPtr->instanceData, + offset, mode, errnoPtr); } static inline void @@ -574,7 +595,10 @@ TclFinalizeIOSubsystem(void) int active = 1; /* Flag == 1 while there's still work to do */ int doflushnb; - /* Fetch the pre-TIP#398 compatibility flag */ + /* + * Fetch the pre-TIP#398 compatibility flag. + */ + { const char *s; Tcl_DString ds; @@ -619,18 +643,20 @@ TclFinalizeIOSubsystem(void) */ if (active) { - TclChannelPreserve((Tcl_Channel)chanPtr); + /* - * TIP #398: by default, we no longer set the channel back into - * blocking mode. To restore the old blocking behavior, the - * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set + * TIP #398: by default, we no longer set the channel back into + * blocking mode. To restore the old blocking behavior, the + * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set * and not be "0". */ + if (doflushnb) { - /* Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ + /* + * Set the channel back into blocking mode to ensure that we + * wait for all data to flush out. + */ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, "-blocking", "on"); @@ -711,17 +737,18 @@ Tcl_SetStdChannel( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int init = channel ? 1 : -1; switch (type) { case TCL_STDIN: - tsdPtr->stdinInitialized = 1; + tsdPtr->stdinInitialized = init; tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: - tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutInitialized = init; tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: - tsdPtr->stderrInitialized = 1; + tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; break; } @@ -758,8 +785,8 @@ Tcl_GetStdChannel( switch (type) { case TCL_STDIN: if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinInitialized = -1; tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); - tsdPtr->stdinInitialized = 1; /* * Artificially bump the refcount to ensure that the channel is @@ -771,6 +798,7 @@ Tcl_GetStdChannel( */ if (tsdPtr->stdinChannel != NULL) { + tsdPtr->stdinInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdinChannel); } } @@ -778,9 +806,10 @@ Tcl_GetStdChannel( break; case TCL_STDOUT: if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutInitialized = -1; tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); - tsdPtr->stdoutInitialized = 1; if (tsdPtr->stdoutChannel != NULL) { + tsdPtr->stdoutInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdoutChannel); } } @@ -788,9 +817,10 @@ Tcl_GetStdChannel( break; case TCL_STDERR: if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); - tsdPtr->stderrInitialized = 1; if (tsdPtr->stderrChannel != NULL) { + tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } } @@ -1058,7 +1088,7 @@ CheckForStdChannelsBeingClosed( ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (tsdPtr->stdinInitialized + if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { @@ -1066,7 +1096,7 @@ CheckForStdChannelsBeingClosed( tsdPtr->stdinChannel = NULL; return; } - } else if (tsdPtr->stdoutInitialized + } else if (tsdPtr->stdoutInitialized == 1 && tsdPtr->stdoutChannel != NULL && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { @@ -1074,7 +1104,7 @@ CheckForStdChannelsBeingClosed( tsdPtr->stdoutChannel = NULL; return; } - } else if (tsdPtr->stderrInitialized + } else if (tsdPtr->stderrInitialized == 1 && tsdPtr->stderrChannel != NULL && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { @@ -1501,18 +1531,20 @@ TclGetChannelFromObj( return TCL_ERROR; } - if (objPtr->typePtr == &chanObjType) { + ChanGetIntRep(objPtr, resPtr); + if (resPtr) { /* * Confirm validity of saved lookup results. */ - resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ && (resPtr->epoch == statePtr->epoch)) { + /* + * Have a valid saved lookup. Jump to end to return it. + */ - /* Have a valid saved lookup. Jump to end to return it. */ goto valid; } } @@ -1521,22 +1553,21 @@ TclGetChannelFromObj( if (chan == NULL) { if (resPtr) { - FreeChannelIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &chanObjType, NULL); } return TCL_ERROR; } if (resPtr && resPtr->refCount == 1) { - /* Re-use the ResolvedCmdName struct */ - Tcl_Release((ClientData) resPtr->statePtr); + /* + * Re-use the ResolvedCmdName struct. + */ + Tcl_Release((ClientData) resPtr->statePtr); } else { - TclFreeIntRep(objPtr); - resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; - objPtr->typePtr = &chanObjType; + resPtr->refCount = 0; + ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; @@ -1671,7 +1702,7 @@ Tcl_CreateChannel( * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and - * output, so that Tcl does not look for an in-file EOF indicator (e.g. + * output, so that Tcl does not look for an in-file EOF indicator (e.g., * ^Z) and does not append an EOF indicator to files. */ @@ -1899,7 +1930,6 @@ Tcl_StackChannel( */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) { - /* * When statePtr->inQueueHead is not NULL, we know * prevChanPtr->inQueueHead must be NULL. @@ -2031,9 +2061,7 @@ Tcl_UnstackChannel( * of registered channels we wind down the state of the * transformation, and then restore the state of underlying channel * into the old structure. - */ - - /* + * * TODO: Figure out how to handle the situation where the chan * operations called below by this unstacking operation cause * another unstacking recursively. In that case the downChanPtr @@ -2511,6 +2539,7 @@ RecycleBuffer( /* * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { mustDiscard = 1; } @@ -2521,9 +2550,8 @@ RecycleBuffer( } /* - * Only save buffers which have the requested buffersize for the - * channel. This is to honor dynamic changes of the buffersize - * made by the user. + * Only save buffers which have the requested buffersize for the channel. + * This is to honor dynamic changes of the buffersize made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { @@ -2693,14 +2721,18 @@ FlushChannel( /* * Should we shift the current output buffer over to the output queue? * First check that there are bytes in it. If so then... - * If the output queue is empty, then yes, trusting the caller called - * us only when written bytes ought to be flushed. - * If the current output buffer is full, then yes, so we can meet - * the post-condition that on a successful return to caller we've - * left space in the current output buffer for more writing (the flush - * call was to make new room). - * If the channel is blocking, then yes, so we guarantee that - * blocking flushes actually flush all pending data. + * + * If the output queue is empty, then yes, trusting the caller called us + * only when written bytes ought to be flushed. + * + * If the current output buffer is full, then yes, so we can meet the + * post-condition that on a successful return to caller we've left space + * in the current output buffer for more writing (the flush call was to + * make new room). + * + * If the channel is blocking, then yes, so we guarantee that blocking + * flushes actually flush all pending data. + * * Otherwise, no. Keep the current output buffer where it is so more * can be written to it, possibly filling it, to promote more efficient * buffer usage. @@ -2794,8 +2826,8 @@ FlushChannel( /* * TIP #219, Tcl Channel Reflection API. * When defering the error copy a message from the bypass into - * the unreported area. Or discard it if the new error is to be - * ignored in favor of an earlier defered error. + * the unreported area. Or discard it if the new error is to + * be ignored in favor of an earlier defered error. */ Tcl_Obj *msg = statePtr->chanMsg; @@ -2847,8 +2879,11 @@ FlushChannel( ReleaseChannelBuffer(bufPtr); break; } else { - /* TODO: Consider detecting and reacting to short writes - * on blocking channels. Ought not happen. See iocmd-24.2. */ + /* + * TODO: Consider detecting and reacting to short writes on + * blocking channels. Ought not happen. See iocmd-24.2. + */ + wroteSome = 1; } @@ -2882,7 +2917,6 @@ FlushChannel( 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 @@ -2927,7 +2961,8 @@ FlushChannel( (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { - errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE); + errorCode = CloseChannelPart(interp, chanPtr, errorCode, + TCL_CLOSE_WRITE); goto done; } @@ -3398,7 +3433,6 @@ Tcl_Close( if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { - int code = CheckChannelErrors(statePtr, TCL_WRITABLE); if (code == 0) { @@ -3488,12 +3522,14 @@ Tcl_Close( } 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)) ) { + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(flushcode); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); @@ -3588,8 +3624,8 @@ Tcl_CloseEx( } /* - * A user may try to call half-close from within a channel close - * handler. That won't do. + * A user may try to call half-close from within a channel close handler. + * That won't do. */ if (statePtr->flags & CHANNEL_INCLOSE) { @@ -3660,9 +3696,12 @@ CloseWrite( * closed. May still be used by some * interpreter */ { - /* Notes: clear-channel-handlers - write side only ? or keep around, just - * not called. */ - /* No close cllbacks are run - channel is still open (read side) */ + /* + * Notes: clear-channel-handlers - write side only ? or keep around, just + * not called. + * + * No close callbacks are run - channel is still open (read side) + */ ChannelState *statePtr = chanPtr->state; /* State of real IO channel. */ @@ -3687,9 +3726,9 @@ CloseWrite( * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags * FlushChannel() has called CloseChannelPart(). While we can still access * "chan" (no structures were freed), the only place which may still - * contain a message is the interpreter itself, and "CloseChannelPart" made - * sure to lift any channel message it generated into it. Hence the NULL - * argument in the call below. + * contain a message is the interpreter itself, and "CloseChannelPart" + * made sure to lift any channel message it generated into it. Hence the + * NULL argument in the call below. */ if (TclChanCaughtErrorBypass(interp, NULL)) { @@ -3913,10 +3952,10 @@ Tcl_ClearChannelHandlers( StopCopy(statePtr->csPtrW); /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. + * Must set the interest mask now to 0, otherwise infinite loops will + * occur if Tcl_DoOneEvent is called before the channel is finally deleted + * in FlushChannel. This can happen if the channel has a background flush + * active. */ statePtr->interestMask = 0; @@ -4185,22 +4224,24 @@ WillRead( Channel *chanPtr) { if (chanPtr->typePtr == NULL) { - /* Prevent read attempts on a closed channel */ + /* + * 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)) { - /* - * 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. + * 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) { @@ -4292,11 +4333,17 @@ Write( &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - /* See chan-io-1.[89]. Tcl Bug 506297. */ + /* + * 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 */ + /* + * We're reading from invalid/incomplete UTF-8. + */ + ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); @@ -4336,11 +4383,10 @@ Write( } result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - - assert (srcRead == nlLen); + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + assert(srcRead == nlLen); bufPtr->nextAdded += dstWrote; src++; @@ -4354,11 +4400,11 @@ Write( 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. + * When translating from UTF-8 to external encoding, we allowed + * the translation to produce a character that crossed the end of + * the output buffer, so that we would get a completely full + * buffer before flushing it. The extra bytes will be moved to the + * beginning of the next buffer. */ saved = -SpaceLeft(bufPtr); @@ -4378,15 +4424,16 @@ Write( flushed += statePtr->bufSize; /* - * We just flushed. So if we have needNlFlush set to record - * that we need to flush because theres a (translated) newline - * in the buffer, that's likely not true any more. But there - * is a tricky exception. If we have saved bytes that did not - * really get flushed and those bytes came from a translation - * of a newline as the last thing taken from the src array, - * then needNlFlush needs to remain set to flag that the - * next buffer still needs a newline flush. + * We just flushed. So if we have needNlFlush set to record that + * we need to flush because theres a (translated) newline in the + * buffer, that's likely not true any more. But there is a tricky + * exception. If we have saved bytes that did not really get + * flushed and those bytes came from a translation of a newline as + * the last thing taken from the src array, then needNlFlush needs + * to remain set to flag that the next buffer still needs a + * newline flush. */ + if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; } @@ -4492,8 +4539,8 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: Do we need this? */ UpdateInterest(chanPtr); @@ -4833,17 +4880,17 @@ Tcl_GetsObj( */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; @@ -4863,10 +4910,9 @@ Tcl_GetsObj( * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * - * WARNING! The notion of "binary" used here is different from - * notions of "binary" used in other places. In particular, this - * "binary" routine may be called when an -eofchar is set on the - * channel. + * WARNING! The notion of "binary" used here is different from notions + * of "binary" used in other places. In particular, this "binary" routine + * may be called when an -eofchar is set on the channel. * * Results: * Number of characters accumulated in the object or -1 if error, @@ -4932,8 +4978,8 @@ TclGetsObjBinary( ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* - * Subtract the number of bytes that were removed from channel - * buffer during last call. + * Subtract the number of bytes that were removed from channel buffer + * during last call. */ if (bufPtr != NULL) { @@ -4945,10 +4991,11 @@ TclGetsObjBinary( if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still - * hasn't seen EOL. Need to read more bytes from the channel - * device. Side effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still hasn't + * seen EOL. Need to read more bytes from the channel device. Side + * effect is to allocate another channel buffer. */ + if (GetInput(chanPtr) != 0) { goto restore; } @@ -4958,15 +5005,15 @@ TclGetsObjBinary( } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. - * A new CHANNEL_STICKY_EOF set in this routine leads to - * return before coming back here. When we are not dealing - * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an - * empty buffer. Here the buffer is non-empty so we know - * we're a non-EOF */ + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with + * CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer. + * Here the buffer is non-empty so we know we're a non-EOF. + */ - assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); - assert ( !GotFlag(statePtr, CHANNEL_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -5033,8 +5080,8 @@ TclGetsObjBinary( } /* - * Copy bytes from the channel buffer to the ByteArray. - * This may realloc space, so keep track of result. + * Copy bytes from the channel buffer to the ByteArray. This may + * realloc space, so keep track of result. */ rawLen = dstEnd - dst; @@ -5118,11 +5165,11 @@ TclGetsObjBinary( */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; @@ -5255,15 +5302,15 @@ FilterInputBytes( } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. - * A new CHANNEL_STICKY_EOF set in this routine leads to - * return before coming back here. When we are not dealing - * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an - * empty buffer. Here the buffer is non-empty so we know - * we're a non-EOF */ + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with CHANNEL_STICKY_EOF, + * a CHANNEL_EOF implies an empty buffer. Here the buffer is + * non-empty so we know we're a non-EOF. + */ - assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); - assert ( !GotFlag(statePtr, CHANNEL_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } /* @@ -5593,7 +5640,9 @@ Tcl_ReadRaw( return -1; } - /* First read bytes from the push-back buffers. */ + /* + * First read bytes from the push-back buffers. + */ while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; @@ -5601,7 +5650,9 @@ Tcl_ReadRaw( int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer : bytesToRead; - /* Copy the current chunk into the read buffer. */ + /* + * Copy the current chunk into the read buffer. + */ memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy); bufPtr->nextRemoved += toCopy; @@ -5609,7 +5660,9 @@ Tcl_ReadRaw( readBuf += toCopy; bytesToRead -= toCopy; - /* If the current buffer is empty recycle it. */ + /* + * If the current buffer is empty recycle it. + */ if (IsBufferEmpty(bufPtr)) { chanPtr->inQueueHead = bufPtr->nextPtr; @@ -5621,37 +5674,40 @@ Tcl_ReadRaw( } /* - * Go to the driver only if we got nothing from pushback. - * Have to do it this way to avoid EOF mis-timings when we - * consider the ability that EOF may not be a permanent - * condition in the driver, and in that case we have to - * synchronize. + * Go to the driver only if we got nothing from pushback. Have to do it + * this way to avoid EOF mis-timings when we consider the ability that EOF + * may not be a permanent condition in the driver, and in that case we + * have to synchronize. */ if (copied) { return copied; } - /* This test not needed. */ - if (bytesToRead > 0) { + /* + * This test not needed. + */ + if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); if (nread > 0) { - /* Successful read (short is OK) - add to bytes copied */ + /* + * 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. + * 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; } @@ -5788,21 +5844,23 @@ DoReadChars( /* * Early out when next read will see eofchar. * - * NOTE: See DoRead for argument that it's a bug (one we're keeping) - * to have this escape before the one for zero-char read request. + * NOTE: See DoRead for argument that it's a bug (one we're keeping) to + * have this escape before the one for zero-char read request. */ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: We don't need this call? */ UpdateInterest(chanPtr); return 0; } - /* Special handling for zero-char read request. */ + /* + * Special handling for zero-char read request. + */ if (toRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; @@ -5821,7 +5879,10 @@ DoReadChars( chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); - /* Must clear the BLOCKED|EOF flags here since we check before reading */ + /* + * Must clear the BLOCKED|EOF flags here since we check before reading. + */ + if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } @@ -5879,10 +5940,11 @@ DoReadChars( } /* - * 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. + * 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); } @@ -5891,6 +5953,7 @@ DoReadChars( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; @@ -5901,11 +5964,12 @@ DoReadChars( * Update the notifier state so we don't block while there is still data * in the buffers. */ - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copied; @@ -6022,11 +6086,10 @@ ReadChars( int numBytes, 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. + * 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. */ int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead; @@ -6044,6 +6107,7 @@ ReadChars( Tcl_AppendToObj(objPtr, NULL, dstLimit); if (toRead == srcLen) { unsigned int size; + dst = TclGetStringStorage(objPtr, &size) + numBytes; dstLimit = size - numBytes; } else { @@ -6051,19 +6115,18 @@ ReadChars( } /* - * 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. + * 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. * - * 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. + * 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. */ while (1) { @@ -6076,18 +6139,17 @@ ReadChars( } /* - * Perform the encoding transformation. Read no more than - * srcLen bytes, write no more than dstLimit bytes. + * Perform the encoding transformation. Read no more than srcLen + * bytes, write no more than dstLimit bytes. * - * Some trickiness with encoding flags here. We do not want - * the end of a buffer to be treated as the end of all input - * when the presence of bytes in a next buffer are already - * known to exist. This is checked with an assert() because - * so far no test case causing the assertion to be false has - * been created. The normal operations of channel reading - * appear to cause EOF and TCL_ENCODING_END setting to appear - * only in situations where there are no further bytes in - * any buffers. + * Some trickiness with encoding flags here. We do not want the end + * of a buffer to be treated as the end of all input when the presence + * of bytes in a next buffer are already known to exist. This is + * checked with an assert() because so far no test case causing the + * assertion to be false has been created. The normal operations of + * channel reading appear to cause EOF and TCL_ENCODING_END setting to + * appear only in situations where there are no further bytes in any + * buffers. */ assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0 @@ -6098,10 +6160,10 @@ ReadChars( dst, dstLimit, &srcRead, &dstDecoded, &numChars); /* - * 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. + * 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. */ dstWrote = dstLimit; @@ -6109,11 +6171,9 @@ ReadChars( TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); if (dstRead < dstDecoded) { - /* - * The encoding transformation produced bytes that the - * translation transformation did not consume. Why did - * this happen? + * The encoding transformation produced bytes that the translation + * transformation did not consume. Why did this happen? */ if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { @@ -6122,40 +6182,38 @@ ReadChars( * 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. + * 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. + * 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. + * 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. + * There are chars leading the buffer before the eof char. + * Adjust the dstLimit so we go back and read only those + * and do not encounter the eof char this time. */ dstLimit = dstRead - 1 + TCL_UTF_MAX; @@ -6167,10 +6225,9 @@ ReadChars( } /* - * 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. + * 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. */ assert(dst[dstRead] == '\r'); @@ -6178,10 +6235,10 @@ ReadChars( 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. + * 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. */ dstLimit = dstRead - 1 + TCL_UTF_MAX; @@ -6195,9 +6252,9 @@ ReadChars( assert(dstRead == 0); /* - * 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? + * 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? */ if (code != TCL_OK) { @@ -6238,10 +6295,9 @@ ReadChars( } } else if (statePtr->flags & CHANNEL_EOF) { - /* - * The bare \r is the only char and we will never read - * a subsequent char to make the determination. + * The bare \r is the only char and we will never read a + * subsequent char to make the determination. */ dst[0] = '\r'; @@ -6251,8 +6307,8 @@ ReadChars( } /* - * Revise the dstRead value so that the numChars calc - * below correctly computes zero characters read. + * Revise the dstRead value so that the numChars calc below + * correctly computes zero characters read. */ dstRead = numChars; @@ -6261,9 +6317,9 @@ ReadChars( } /* - * 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. + * 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. */ numChars -= (dstRead - dstWrote); @@ -6273,10 +6329,9 @@ ReadChars( /* * TODO: This cannot happen anymore. * - * We read more chars than allowed. Reset limits to - * prevent that and try again. Don't forget the extra - * padding of TCL_UTF_MAX bytes demanded by the - * Tcl_ExternalToUtf() call! + * We read more chars than allowed. Reset limits to prevent that + * and try again. Don't forget the extra padding of TCL_UTF_MAX + * bytes demanded by the Tcl_ExternalToUtf() call! */ dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - 1 + TCL_UTF_MAX - dst; @@ -6289,18 +6344,19 @@ ReadChars( if (dstWrote == 0) { ChannelBuffer *nextPtr; - /* We were not able to read any chars. */ + /* + * We were not able to read any chars. + */ - assert (numChars == 0); + assert(numChars == 0); /* - * There is one situation where this is the correct final - * result. If the src buffer contains only a single \n - * byte, and we are in TCL_TRANSLATE_AUTO mode, and - * when the translation pass was made the INPUT_SAW_CR - * flag was set on the channel. In that case, the - * correct behavior is to consume that \n and produce the - * empty string. + * There is one situation where this is the correct final result. + * If the src buffer contains only a single \n byte, and we are in + * TCL_TRANSLATE_AUTO mode, and when the translation pass was made + * the INPUT_SAW_CR flag was set on the channel. In that case, the + * correct behavior is to consume that \n and produce the empty + * string. */ if (dstRead == 1 && dst[0] == '\n') { @@ -6309,12 +6365,13 @@ ReadChars( 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. + /* + * Otherwise, reading zero characters indicates there's something + * incomplete at the end of the src buffer. Maybe there were not + * enough src bytes to decode into a char. Maybe a lone \r could + * not be translated (crlf mode). Need to combine any unused src + * bytes we have in the first buffer with subsequent bytes to try + * again. */ nextPtr = bufPtr->nextPtr; @@ -6329,15 +6386,15 @@ ReadChars( /* * 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'. + * 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. + * 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) { @@ -6356,10 +6413,12 @@ ReadChars( consume: bufPtr->nextRemoved += srcRead; + /* - * If this read contained multibyte characters, revise factorPtr - * so the next read will allocate bigger buffers. + * 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; } @@ -6407,22 +6466,27 @@ TranslateInputEOL( int inEofChar = statePtr->inEofChar; /* - * 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. + * 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. */ + /* + * 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. */ + /* + * In other modes, at most 2 src bytes become a dst byte. + */ + if (srcLen/2 > dstLen) { srcLen = 2 * dstLen; } @@ -6755,7 +6819,7 @@ GetInput( * eofchar. */ - assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); /* * Prevent reading from a dead channel -- a channel that has been closed @@ -6769,24 +6833,21 @@ GetInput( } /* - * WARNING: There was once a comment here claiming that it was - * a bad idea to make another call to the inputproc of a channel - * driver when EOF has already been detected on the channel. Through - * much of Tcl's history, this warning was then completely negated - * by having all (most?) read paths clear the EOF setting before - * reaching here. So we had a guard that was never triggered. + * WARNING: There was once a comment here claiming that it was a bad idea + * to make another call to the inputproc of a channel driver when EOF has + * already been detected on the channel. Through much of Tcl's history, + * this warning was then completely negated by having all (most?) read + * paths clear the EOF setting before reaching here. So we had a guard + * that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on the + * channel, continue through and call the inputproc again. This is the + * way to enable the ability to [read] again beyond the EOF, which seems a + * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683] + * and which may even be essential for channels representing things like + * ttys or other devices where the stream might take the logical form of a + * series of 'files' separated by an EOF condition. * - * Don't be tempted to restore the guard. Even if EOF is set on - * the channel, continue through and call the inputproc again. This - * is the way to enable the ability to [read] again beyond the EOF, - * which seems a strange thing to do, but for which use cases exist - * [Tcl Bug 5adc350683] and which may even be essential for channels - * representing things like ttys or other devices where the stream - * might take the logical form of a series of 'files' separated by - * an EOF condition. - */ - - /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information @@ -6794,7 +6855,6 @@ GetInput( */ if (chanPtr->inQueueHead != NULL) { - /* TODO: Tests to cover this. */ assert(statePtr->inQueueHead == NULL); @@ -6824,8 +6884,9 @@ GetInput( /* * Check the actual buffersize against the requested buffersize. - * Saved buffers of the wrong size are squashed. This is done - * to honor dynamic changes of the buffersize made by the user. + * Saved buffers of the wrong size are squashed. This is done to honor + * dynamic changes of the buffersize made by the user. + * * TODO: Tests to cover this. */ @@ -6904,7 +6965,7 @@ Tcl_Seek( * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6915,7 +6976,7 @@ Tcl_Seek( */ if (CheckForDeadChannel(NULL, statePtr)) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6931,7 +6992,7 @@ Tcl_Seek( if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6944,7 +7005,7 @@ Tcl_Seek( if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6987,7 +7048,7 @@ Tcl_Seek( wasAsync = 1; result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); if (result != 0) { - return Tcl_LongAsWide(-1); + return -1; } ResetFlag(statePtr, CHANNEL_NONBLOCKING); if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { @@ -7012,7 +7073,7 @@ Tcl_Seek( */ curPos = ChanSeek(chanPtr, offset, mode, &result); - if (curPos == Tcl_LongAsWide(-1)) { + if (curPos == -1) { Tcl_SetErrno(result); } } @@ -7028,7 +7089,7 @@ Tcl_Seek( SetFlag(statePtr, CHANNEL_NONBLOCKING); result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); if (result != 0) { - return Tcl_LongAsWide(-1); + return -1; } } @@ -7068,7 +7129,7 @@ Tcl_Tell( Tcl_WideInt curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7079,7 +7140,7 @@ Tcl_Tell( */ if (CheckForDeadChannel(NULL, statePtr)) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7095,7 +7156,7 @@ Tcl_Tell( if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7112,10 +7173,10 @@ Tcl_Tell( * wideSeekProc if that is available and non-NULL... */ - curPos = ChanSeek(chanPtr, Tcl_LongAsWide(0), SEEK_CUR, &result); - if (curPos == Tcl_LongAsWide(-1)) { + curPos = ChanSeek(chanPtr, 0, SEEK_CUR, &result); + if (curPos == -1) { Tcl_SetErrno(result); - return Tcl_LongAsWide(-1); + return -1; } if (inputBuffered != 0) { @@ -7127,53 +7188,12 @@ Tcl_Tell( /* *--------------------------------------------------------------------------- * - * Tcl_SeekOld, Tcl_TellOld -- - * - * Backward-compatibility versions of the seek/tell interface that do not - * support 64-bit offsets. This interface is not documented or expected - * to be supported indefinitely. - * - * Results: - * As for Tcl_Seek and Tcl_Tell respectively, except truncated to - * whatever value will fit in an 'int'. - * - * Side effects: - * As for Tcl_Seek and Tcl_Tell respectively. - * - *--------------------------------------------------------------------------- - */ - -int -Tcl_SeekOld( - Tcl_Channel chan, /* The channel on which to seek. */ - int offset, /* Offset to seek to. */ - int mode) /* Relative to which location to seek? */ -{ - Tcl_WideInt wOffset, wResult; - - wOffset = Tcl_LongAsWide((long) offset); - wResult = Tcl_Seek(chan, wOffset, mode); - return (int) Tcl_WideAsLong(wResult); -} - -int -Tcl_TellOld( - Tcl_Channel chan) /* The channel to return pos for. */ -{ - Tcl_WideInt wResult = Tcl_Tell(chan); - - return (int) Tcl_WideAsLong(wResult); -} - -/* - *--------------------------------------------------------------------------- - * * Tcl_TruncateChannel -- * * Truncate a channel to the given length. * * Results: - * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not + * TCL_OK on success, TCL_ERROR if the operation failed (e.g., is not * supported by the type of channel, or the underlying OS operation * failed in some way). * @@ -9028,6 +9048,7 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ @@ -9039,6 +9060,7 @@ TclCopyChannelOld( return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( @@ -9533,7 +9555,10 @@ CopyData( } if (size == 0) { if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { - /* We allowed a short read. Keep trying. */ + /* + * We allowed a short read. Keep trying. + */ + continue; } if (bufObj != NULL) { @@ -9747,7 +9772,7 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; - assert (bytesToRead >= 0); + assert(bytesToRead >= 0); /* * Early out when we know a read will get the eofchar. @@ -9763,15 +9788,18 @@ DoRead( if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: Don't need this call */ UpdateInterest(chanPtr); return 0; } - /* Special handling for zero-char read request. */ + /* + * Special handling for zero-char read request. + */ + if (bytesToRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; @@ -9786,8 +9814,8 @@ DoRead( TclChannelPreserve((Tcl_Channel)chanPtr); while (bytesToRead) { /* - * Each pass through the loop is intended to process up to - * one channel buffer. + * Each pass through the loop is intended to process up to one channel + * buffer. */ int bytesRead, bytesWritten; @@ -9799,33 +9827,39 @@ DoRead( while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ - (BytesLeft(bufPtr) < bytesToRead) ) ) { - /* Not enough bytes in it - * yet to fill the dst */ + (BytesLeft(bufPtr) < bytesToRead))) { + /* Not enough bytes in it yet + * to fill the dst */ int code; moreData: code = GetInput(chanPtr); bufPtr = statePtr->inQueueHead; - assert (bufPtr != NULL); + assert(bufPtr != NULL); if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { - /* Further reads cannot do any more */ + /* + * Further reads cannot do any more. + */ + break; } if (code) { - /* Read error */ + /* + * Read error + */ + UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } - assert (IsBufferFull(bufPtr)); + assert(IsBufferFull(bufPtr)); } - assert (bufPtr != NULL); + assert(bufPtr != NULL); bytesRead = BytesLeft(bufPtr); bytesWritten = bytesToRead; @@ -9840,8 +9874,8 @@ DoRead( /* * Buffer is not empty. How can that be? * - * 0) We stopped early because we got all the bytes - * we were seeking. That's fine. + * 0) We stopped early because we got all the bytes we were + * seeking. That's fine. */ if (bytesToRead == 0) { @@ -9857,8 +9891,8 @@ DoRead( } /* - * 2) The buffer holds a \r while in CRLF translation, - * followed by the end of the buffer. + * 2) The buffer holds a \r while in CRLF translation, followed by + * the end of the buffer. */ assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); @@ -9866,26 +9900,38 @@ DoRead( assert(BytesLeft(bufPtr) == 1); if (bufPtr->nextPtr == NULL) { - /* There's no more buffered data.... */ + /* + * There's no more buffered data... + */ if (statePtr->flags & CHANNEL_EOF) { - /* ...and there never will be. */ + /* + * ...and there never will be. + */ *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; } else if (statePtr->flags & CHANNEL_BLOCKED) { - /* ...and we cannot get more now. */ + /* + * ...and we cannot get more now. + */ + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); break; } else { - /* ... so we need to get some. */ + /* + * ...so we need to get some. + */ + goto moreData; } } if (bufPtr->nextPtr) { - /* There's a next buffer. Shift orphan \r to it. */ + /* + * There's a next buffer. Shift orphan \r to it. + */ ChannelBuffer *nextPtr = bufPtr->nextPtr; @@ -9910,8 +9956,8 @@ DoRead( } /* - * When there's no buffered data to read, and we're at EOF, - * escape to the caller. + * When there's no buffered data to read, and we're at EOF, escape to + * the caller. */ if (GotFlag(statePtr, CHANNEL_EOF) @@ -9923,11 +9969,11 @@ DoRead( ResetFlag(statePtr, CHANNEL_BLOCKED); } - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); @@ -11164,11 +11210,11 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - resPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; - copyPtr->typePtr = srcPtr->typePtr; + ChanGetIntRep(srcPtr, resPtr); + assert(resPtr); + ChanSetIntRep(copyPtr, resPtr); } /* @@ -11191,10 +11237,11 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - objPtr->typePtr = NULL; - if (--resPtr->refCount) { + ChanGetIntRep(objPtr, resPtr); + assert(resPtr); + if (resPtr->refCount-- > 1) { return; } Tcl_Release(resPtr->statePtr); diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..07c54fa 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,7 +214,7 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname + size_t epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 834f225..1dd8666 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -16,7 +16,7 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ + Tcl_Obj *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -25,7 +25,7 @@ typedef struct AcceptCallback { * It must be per-thread because of std channel limitations. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; @@ -37,8 +37,7 @@ static Tcl_ThreadDataKey dataKey; */ static void FinalizeIOCmdTSD(ClientData clientData); -static void AcceptCallbackProc(ClientData callbackData, - Tcl_Channel chan, char *address, int port); +static Tcl_TcpAcceptProc AcceptCallbackProc; static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -114,7 +113,6 @@ Tcl_PutsObjCmd( int newline; /* Add a newline at end? */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ - ThreadSpecificData *tsdPtr; switch (objc) { case 2: /* [puts $x] */ @@ -139,7 +137,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -161,7 +159,7 @@ Tcl_PutsObjCmd( } if (chanObjPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; @@ -441,7 +439,7 @@ Tcl_ReadObjCmd( if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -456,7 +454,7 @@ Tcl_ReadObjCmd( TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } newline = 1; #endif @@ -561,7 +559,7 @@ Tcl_SeekObjCmd( TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); - if (result == Tcl_LongAsWide(-1)) { + if (result == -1) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and @@ -993,7 +991,7 @@ Tcl_ExecObjCmd( resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { - if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { /* * TIP #219. * Capture error messages put by the driver into the bypass area @@ -1373,15 +1371,22 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { - char portBuf[TCL_INTEGER_SPACE]; - char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - int result; + Tcl_Obj *script, *objv[2]; + int result = TCL_OK; - Tcl_Preserve(script); - Tcl_Preserve(interp); + objv[0] = acceptCallbackPtr->script; + objv[1] = Tcl_NewListObj(3, NULL); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( + Tcl_GetChannelName(chan), -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); + + script = Tcl_ConcatObj(2, objv); + Tcl_IncrRefCount(script); + Tcl_DecrRefCount(objv[1]); - TclFormatInt(portBuf, port); + Tcl_Preserve(interp); Tcl_RegisterChannel(interp, chan); /* @@ -1391,8 +1396,9 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); + result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(script); + if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); @@ -1406,7 +1412,6 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); - Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to use @@ -1450,7 +1455,7 @@ TcpServerCloseProc( UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + Tcl_DecrRefCount(acceptCallbackPtr->script); ckfree(acceptCallbackPtr); } @@ -1479,13 +1484,18 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", + NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *script = NULL, *myaddr = NULL; + int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + reusea = -1; + unsigned int flags = 0; + const char *host, *port, *myaddr = NULL; + Tcl_Obj *script = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1548,7 +1558,29 @@ Tcl_SocketObjCmd( "no argument given for -server option", -1)); return TCL_ERROR; } - script = TclGetString(objv[a]); + script = objv[a]; + break; + case SKT_REUSEADDR: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseaddr option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_REUSEPORT: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseport option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { + return TCL_ERROR; + } break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1573,32 +1605,63 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-myaddr addr? port"); + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? port"); return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + if (!server && (reusea != -1 || reusep != -1)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -reuseaddr and -reuseport are only valid for servers", + -1)); + return TCL_ERROR; + } + + /* + * Set the options to their default value if the user didn't override + * their value. + */ + + if (reusep == -1) { + reusep = 0; + } + if (reusea == -1) { + reusea = 1; + } + + /* + * Build the bitset with the flags values. + */ + + if (reusea) { + flags |= TCL_TCPSERVER_REUSEADDR; + } + if (reusep) { + flags |= TCL_TCPSERVER_REUSEPORT; + } + + /* + * All the arguments should have been parsed by now, 'a' points to the + * last one, the port number. + */ + + if (a != objc-1) { goto wrongNumArgs; } + port = TclGetString(objv[a]); + if (server) { - AcceptCallback *acceptCallbackPtr = - ckalloc(sizeof(AcceptCallback)); - unsigned len = strlen(script) + 1; - char *copyScript = ckalloc(len); + AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); - memcpy(copyScript, script, len); - acceptCallbackPtr->script = copyScript; + Tcl_IncrRefCount(script); + acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - acceptCallbackPtr); + + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, + AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { - ckfree(copyScript); + Tcl_DecrRefCount(script); ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1620,7 +1683,13 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + int portNum; + + if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { + return TCL_ERROR; + } + + chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } @@ -1844,7 +1913,7 @@ ChanTruncateObjCmd( */ length = Tcl_Tell(chan); - if (length == Tcl_WideAsLong(-1)) { + if (length == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not determine current location in \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 7f61def..9949a0e 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -211,7 +211,7 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ - int refCount; + size_t refCount; }; static void @@ -225,7 +225,7 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (--dataPtr->refCount) { + if (dataPtr->refCount-- > 1) { return; } ResultClear(&dataPtr->result); @@ -910,7 +910,7 @@ TransformWideSeekProc( Tcl_ChannelWideSeekProc(parentType); ClientData parentData = Tcl_GetChannelInstanceData(parent); - if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { + if ((offset == 0) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. @@ -920,8 +920,7 @@ TransformWideSeekProc( return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } - return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode, - errorCodePtr)); + return parentSeekProc(parentData, 0, mode, errorCodePtr); } /* @@ -961,13 +960,13 @@ TransformWideSeekProc( * to go out of the representable range. */ - if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { + if (offset<LONG_MIN || offset>LONG_MAX) { *errorCodePtr = EOVERFLOW; - return Tcl_LongAsWide(-1); + return -1; } - return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset), - mode, errorCodePtr)); + return parentSeekProc(parentData, offset, + mode, errorCodePtr); } /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e862761..611ee3f 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -39,7 +39,7 @@ static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); static int ReflectBlock(ClientData clientData, int mode); -#ifdef TCL_THREADS +#if TCL_THREADS static void ReflectThread(ClientData clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, ClientData cd); @@ -76,7 +76,7 @@ static const Tcl_ChannelType tclRChannelType = { NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ ReflectSeekWide, /* Move access point (64 bit). NULL'able */ -#ifdef TCL_THREADS +#if TCL_THREADS ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ @@ -97,7 +97,7 @@ typedef struct { * interpreter/thread containing its Tcl * command is gone. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif @@ -201,7 +201,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -236,7 +236,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -311,7 +311,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -348,7 +348,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. @@ -451,7 +451,7 @@ static const char *msg_read_toomuch = "{read delivered more than requested}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; #endif /* TCL_THREADS */ static const char *msg_send_dstlost = "{Owner lost}"; @@ -593,7 +593,7 @@ TclChanCreateObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -619,35 +619,35 @@ TclChanCreateObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"read\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"write\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -706,7 +706,7 @@ TclChanCreateObjCmd( Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); } Tcl_SetHashValue(hPtr, chan); -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, &isNew); @@ -725,7 +725,7 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - ckfree((char*) rcPtr); + ckfree(rcPtr); return TCL_ERROR; #undef MODE @@ -750,8 +750,8 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ -#ifdef TCL_THREADS -typedef struct ReflectEvent { +#if TCL_THREADS +typedef struct { Tcl_Event header; ReflectedChannel *rcPtr; int events; @@ -855,11 +855,12 @@ TclChanPostEventObjCmd( } /* - * Note that the search above subsumes several of the older checks, namely: + * Note that the search above subsumes several of the older checks, + * namely: * - * (1) Does the channel handle refer to a reflected channel ? + * (1) Does the channel handle refer to a reflected channel? * (2) Is the post event issued from the interpreter holding the handler - * of the reflected channel ? + * of the reflected channel? * * A successful search answers yes to both. Because the map holds only * handles of reflected channels, and only of such whose handler is @@ -916,11 +917,11 @@ TclChanPostEventObjCmd( * We have the channel and the events to post. */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif Tcl_NotifyChannel(chan, events); -#ifdef TCL_THREADS +#if TCL_THREADS } else { ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); @@ -943,7 +944,8 @@ TclChanPostEventObjCmd( (void) GetThreadReflectedChannelMap(); - /* XXX Race condition !! + /* + * XXX Race condition !! * XXX The destination thread may not exist anymore already. * XXX (Delayed postevent executed after channel got removed). * XXX Can we detect this ? (check the validity of the owner threadid ?) @@ -1135,7 +1137,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1156,7 +1158,7 @@ ReflectClose( tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree((char *)tctPtr); + ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); @@ -1167,7 +1169,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1214,7 +1216,7 @@ ReflectClose( Tcl_DeleteHashEntry(hPtr); } } -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); @@ -1225,8 +1227,8 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree((char *)tctPtr); - ((Channel *)rcPtr->chan)->typePtr = NULL; + ckfree(tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; @@ -1265,7 +1267,7 @@ ReflectInput( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1276,7 +1278,10 @@ ReflectInput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1368,7 +1373,7 @@ ReflectOutput( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1379,7 +1384,10 @@ ReflectOutput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1430,8 +1438,8 @@ ReflectOutput( if ((written == 0) && (toWrite > 0)) { /* - * The handler claims to have written nothing of what it was - * given. That is bad. + * The handler claims to have written nothing of what it was given. + * That is bad. */ SetChannelErrorStr(rcPtr->chan, msg_write_nothing); @@ -1494,7 +1502,7 @@ ReflectSeekWide( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1536,7 +1544,7 @@ ReflectSeekWide( goto invalid; } - if (newLoc < Tcl_LongAsWide(0)) { + if (newLoc < 0) { SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); goto invalid; } @@ -1568,7 +1576,7 @@ ReflectSeek( * routine. */ - return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + return ReflectSeekWide(clientData, offset, seekMode, errorCodePtr); } @@ -1617,7 +1625,7 @@ ReflectWatch( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1675,7 +1683,7 @@ ReflectBlock( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1711,7 +1719,7 @@ ReflectBlock( return errorNum; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1781,7 +1789,7 @@ ReflectSetOption( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1860,7 +1868,7 @@ ReflectGetOption( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { int opcode; ForwardParam p; @@ -1950,7 +1958,7 @@ ReflectGetOption( goto error; } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2123,7 +2131,7 @@ NewReflectedChannel( rcPtr->chan = NULL; rcPtr->interp = interp; rcPtr->dead = 0; -#ifdef TCL_THREADS +#if TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif rcPtr->mode = mode; @@ -2323,7 +2331,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -2377,8 +2385,8 @@ InvokeTclMethod( * None. * * Users: - * ReflectInput/Output(), to enable the signaling of EAGAIN - * on 0-sized short reads/writes. + * ReflectInput/Output(), to enable the signaling of EAGAIN on 0-sized + * short reads/writes. * *---------------------------------------------------------------------- */ @@ -2402,7 +2410,7 @@ ErrnoReturn( if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { - if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { + if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { code = -EAGAIN; } else { code = 0; @@ -2498,7 +2506,7 @@ DeleteReflectedChannelMap( Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2528,7 +2536,7 @@ DeleteReflectedChannelMap( Tcl_DeleteHashTable(&rcmPtr->map); ckfree(&rcmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2564,7 +2572,10 @@ DeleteReflectedChannelMap( evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL) { continue; } @@ -2611,7 +2622,7 @@ DeleteReflectedChannelMap( #endif } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2679,8 +2690,8 @@ DeleteThreadReflectedChannelMap( /* * Go through the list of pending results and cancel all whose events were - * destined for this thread. While this is in progress we block any - * other access to the list of pending results. + * destined for this thread. While this is in progress we block any other + * access to the list of pending results. */ Tcl_MutexLock(&rcForwardMutex); @@ -2711,7 +2722,10 @@ DeleteThreadReflectedChannelMap( evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL ) { continue; } @@ -2765,8 +2779,8 @@ ForwardOpToHandlerThread( const void *param) /* Arguments */ { /* - * Core of the communication from OWNER to HANDLER thread. - * The receiver is ForwardProc() below. + * Core of the communication from OWNER to HANDLER thread. The receiver is + * ForwardProc() below. */ Tcl_ThreadId dst = rcPtr->thread; @@ -2816,7 +2830,10 @@ ForwardOpToHandlerThread( */ TclSpliceIn(resultPtr, forwardList); - /* Do not unlock here. That is done by the ConditionWait */ + + /* + * Do not unlock here. That is done by the ConditionWait. + */ /* * Ensure cleanup of the event if the origin thread exits while this event @@ -2892,7 +2909,7 @@ ForwardProc( * Notes regarding access to the referenced data. * * In principle the data belongs to the originating thread (see - * evPtr->src), however this thread is currently blocked at (*), i.e. + * evPtr->src), however this thread is currently blocked at (*), i.e., * quiescent. Because of this we can treat the data as belonging to us, * without fear of race conditions. I.e. we can read and write as we like. * @@ -3062,7 +3079,7 @@ ForwardProc( Tcl_WideInt newLoc; if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { - if (newLoc < Tcl_LongAsWide(0)) { + if (newLoc < 0) { ForwardSetStaticError(paramPtr, msg_seek_beforestart); paramPtr->seek.offset = -1; } else { @@ -3178,7 +3195,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3277,7 +3294,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index af86ba5..4841e39 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -127,7 +127,7 @@ typedef struct { * in the argv, see below. The separate field * gives us direct access, needed when working * with the reflection maps. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif @@ -220,7 +220,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -253,7 +253,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -298,7 +298,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -329,7 +329,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected transformations owned by this thread. */ @@ -438,7 +438,7 @@ static void DeleteReflectedTransformMap(ClientData clientData, static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_write_unsup = "{write not supported by Tcl driver}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ @@ -554,7 +554,7 @@ TclChanPushObjCmd( */ chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode); + parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); if (parentChan == NULL) { return TCL_ERROR; } @@ -608,7 +608,7 @@ TclChanPushObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -619,7 +619,7 @@ TclChanPushObjCmd( "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", - Tcl_GetString(cmdObj), + TclGetString(cmdObj), Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; @@ -633,7 +633,7 @@ TclChanPushObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -655,7 +655,7 @@ TclChanPushObjCmd( if (!mode) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" makes the channel inaccessible", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -666,14 +666,14 @@ TclChanPushObjCmd( if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"drain\" but not \"read\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"flush\" but not \"write\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -694,14 +694,14 @@ TclChanPushObjCmd( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); } Tcl_SetHashValue(hPtr, rtPtr); -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ @@ -911,7 +911,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -938,7 +938,7 @@ ReflectClose( if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { if (!TransformDrain(rtPtr, &errorCode)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -952,7 +952,7 @@ ReflectClose( if (HAS(rtPtr->methods, METH_FLUSH)) { if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -968,7 +968,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1025,9 +1025,9 @@ ReflectClose( * under a channel by deleting the owning thread. */ -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -1340,7 +1340,7 @@ ReflectSeekWide( if (seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -1390,16 +1390,15 @@ ReflectSeekWide( parent->typePtr->wideSeekProc != NULL) { curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset, seekMode, errorCodePtr); - } else if (offset < Tcl_LongAsWide(LONG_MIN) || - offset > Tcl_LongAsWide(LONG_MAX)) { + } else if (offset < LONG_MIN || offset > LONG_MAX) { *errorCodePtr = EOVERFLOW; - curPos = Tcl_LongAsWide(-1); + curPos = -1; } else { - curPos = Tcl_LongAsWide(parent->typePtr->seekProc( - parent->instanceData, Tcl_WideAsLong(offset), seekMode, - errorCodePtr)); + curPos = parent->typePtr->seekProc( + parent->instanceData, offset, seekMode, + errorCodePtr); } - if (curPos == Tcl_LongAsWide(-1)) { + if (curPos == -1) { Tcl_SetErrno(*errorCodePtr); } @@ -1422,7 +1421,7 @@ ReflectSeek( * routine. */ - return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + return ReflectSeekWide(clientData, offset, seekMode, errorCodePtr); } @@ -1767,7 +1766,7 @@ NewReflectedTransform( rtPtr->chan = NULL; rtPtr->methods = 0; -#ifdef TCL_THREADS +#if TCL_THREADS rtPtr->thread = Tcl_GetCurrentThread(); #endif rtPtr->parent = parentChan; @@ -2043,7 +2042,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2152,7 +2151,7 @@ DeleteReflectedTransformMap( Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedTransform *rtPtr; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2182,7 +2181,7 @@ DeleteReflectedTransformMap( Tcl_DeleteHashTable(&rtmPtr->map); ckfree(&rtmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2254,7 +2253,7 @@ DeleteReflectedTransformMap( #endif /* TCL_THREADS */ } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2568,7 +2567,7 @@ ForwardProc( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); /* @@ -2578,7 +2577,7 @@ ForwardProc( */ rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransformArgs(rtPtr); @@ -2807,7 +2806,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); @@ -2955,7 +2954,7 @@ ResultClear( return; } - ckfree((char *) rPtr->buf); + ckfree(rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -3088,7 +3087,7 @@ TransformRead( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3144,7 +3143,7 @@ TransformWrite( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3210,7 +3209,7 @@ TransformDrain( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3260,7 +3259,7 @@ TransformFlush( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3315,7 +3314,7 @@ TransformClear( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3347,7 +3346,7 @@ TransformLimit( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index c5b7d28..12e2900 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -11,17 +11,22 @@ #include "tclInt.h" -#if defined(_WIN32) && defined(UNICODE) -/* On Windows, we need to do proper Unicode->UTF-8 conversion. */ +#if defined(_WIN32) +/* + * On Windows, we need to do proper Unicode->UTF-8 conversion. + */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; Tcl_DString errorMsg; /* UTF-8 encoded error-message */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #undef gai_strerror -static const char *gai_strerror(int code) { +static const char * +gai_strerror( + int code) +{ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->initialized) { @@ -56,8 +61,8 @@ static const char *gai_strerror(int code) { int TclSockGetPort( Tcl_Interp *interp, - const char *string, /* Integer or service name */ - const char *proto, /* "tcp" or "udp", typically */ + const char *string, /* Integer or service name */ + const char *proto, /* "tcp" or "udp", typically */ int *portPtr) /* Return port number */ { struct servent *sp; /* Protocol info for named services */ @@ -126,7 +131,7 @@ TclSockMinimumBuffers( } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) ¤t, &len); + (char *) ¤t, &len); if (current < size) { len = sizeof(int); setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, @@ -154,15 +159,15 @@ TclSockMinimumBuffers( int TclCreateSocketAddress( - Tcl_Interp *interp, /* Interpreter for querying - * the desired socket family */ - struct addrinfo **addrlist, /* Socket address list */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port, /* Port number */ - int willBind, /* Is this an address to bind() to or - * to connect() to? */ - const char **errorMsgPtr) /* Place to store the error message - * detail, if available. */ + Tcl_Interp *interp, /* Interpreter for querying the desired socket + * family */ + struct addrinfo **addrlist, /* Socket address list */ + const char *host, /* Host. NULL implies INADDR_ANY */ + int port, /* Port number */ + int willBind, /* Is this an address to bind() to or to + * connect() to? */ + const char **errorMsgPtr) /* Place to store the error message detail, if + * available. */ { struct addrinfo hints; struct addrinfo *p; @@ -181,30 +186,31 @@ TclCreateSocketAddress( * Workaround for OSX's apparent inability to resolve "localhost", "0" * when the loopback device is the only available network interface. */ + if (host != NULL && port == 0) { - portstring = NULL; + portstring = NULL; } else { - TclFormatInt(portbuf, port); - portstring = portbuf; + TclFormatInt(portbuf, port); + portstring = portbuf; } (void) memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; /* - * Magic variable to enforce a certain address family - to be superseded - * by a TIP that adds explicit switches to [socket] + * Magic variable to enforce a certain address family; to be superseded + * by a TIP that adds explicit switches to [socket]. */ if (interp != NULL) { - family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); - if (family != NULL) { - if (strcmp(family, "inet") == 0) { - hints.ai_family = AF_INET; - } else if (strcmp(family, "inet6") == 0) { - hints.ai_family = AF_INET6; - } - } + family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0); + if (family != NULL) { + if (strcmp(family, "inet") == 0) { + hints.ai_family = AF_INET; + } else if (strcmp(family, "inet6") == 0) { + hints.ai_family = AF_INET6; + } + } } hints.ai_socktype = SOCK_STREAM; @@ -214,7 +220,7 @@ TclCreateSocketAddress( * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of - * using AI_ADDRCONFIG in situations where it works, is probably low, + * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * * Missing on: OpenBSD, NetBSD. @@ -251,6 +257,7 @@ TclCreateSocketAddress( * * There might be more elegant/efficient ways to do this. */ + if (willBind) { for (p = *addrlist; p != NULL; p = p->ai_next) { if (p->ai_family == AF_INET) { @@ -283,6 +290,38 @@ TclCreateSocketAddress( } /* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer( + Tcl_Interp *interp, + int port, + const char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +{ + char portbuf[TCL_INTEGER_SPACE]; + + TclFormatInt(portbuf, port); + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, + acceptProc, callbackData); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 19620e7..63d16be 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -57,7 +57,7 @@ typedef struct FilesystemRecord { * this information each time the corresponding epoch counter changes. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; size_t cwdPathEpoch; size_t filesystemEpoch; @@ -139,7 +139,6 @@ Tcl_FSRenameFileProc TclpObjRenameFile; Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; Tcl_FSLinkProc TclpObjLink; Tcl_FSListVolumesProc TclpObjListVolumes; @@ -245,7 +244,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; @@ -276,8 +275,8 @@ Tcl_Stat( Tcl_WideInt tmp1, tmp2, tmp3 = 0; # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ - ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) + (((Tcl_WideInt)(x)) < LONG_MIN || \ + ((Tcl_WideInt)(x)) > LONG_MAX) # define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) @@ -543,8 +542,8 @@ TclFSCwdPointerEquals( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be @@ -610,6 +609,7 @@ FsRecacheFilesystemList(void) while (toFree) { FilesystemRecord *next = toFree->nextPtr; + toFree->fsPtr = NULL; ckfree(toFree); toFree = next; @@ -671,7 +671,6 @@ TclFSEpoch(void) return tsdPtr->filesystemEpoch; } - /* * If non-NULL, clientData is owned by us and must be freed later. @@ -687,7 +686,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -783,7 +782,9 @@ TclFinalizeFilesystem(void) while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* The native filesystem is static, so we don't free it. */ + /* + * The native filesystem is static, so we don't free it. + */ if (fsRecPtr != &nativeFilesystemRecord) { ckfree(fsRecPtr); @@ -828,15 +829,6 @@ TclResetFilesystem(void) if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } - -#ifdef _WIN32 - /* - * Cleans up the win32 API filesystem proc lookup table. This must happen - * very late in finalization so that deleting of copied dlls can occur. - */ - - TclWinResetInterfaces(); -#endif } /* @@ -946,7 +938,7 @@ Tcl_FSRegister( int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ + const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -1223,8 +1215,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = Tcl_GetStringFromObj(mElt, &mlen); - path = Tcl_GetStringFromObj(norm, &len); + mount = TclGetStringFromObj(mElt, &mlen); + path = TclGetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1232,7 +1224,7 @@ FsAddMountsToGlobResult( len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ + len++; /* account for '/' in the mElt [Bug 1602539] */ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } @@ -1398,31 +1390,62 @@ TclFSNormalizeToUniquePath( { FilesystemRecord *fsRecPtr, *firstFsRecPtr; + int i; + int isVfsPath = 0; + char *path; + /* - * Call each of the "normalise path" functions in succession. This is a - * special case, in which if we have a native filesystem handler, we call - * it first. This is because the root of Tcl's filesystem is always a - * native filesystem (i.e. '/' on unix is native). + * Paths starting with a UNC prefix whose final character is a colon + * are reserved for VFS use. These names can not conflict with real + * UNC paths per https://msdn.microsoft.com/en-us/library/gg465305.aspx + * and rfc3986's definition of reg-name. + * + * We check these first to avoid useless calls to the native filesystem's + * normalizePathProc. */ + path = Tcl_GetStringFromObj(pathPtr, &i); + if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') + || (path[0] == '\\' && path[1] == '\\') ) ) { + for ( i = 2; ; i++) { + if (path[i] == '\0') break; + if (path[i] == path[0]) break; + } + --i; + if (path[i] == ':') isVfsPath = 1; + } + + /* + * Call each of the "normalise path" functions in succession. + */ firstFsRecPtr = FsGetFirstFilesystem(); Claim(); - for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - continue; - } + + if (!isVfsPath) { /* - * TODO: Assume that we always find the native file system; it should - * always be there... + * If we have a native filesystem handler, we call it first. This is + * because the root of Tcl's filesystem is always a native filesystem + * (i.e., '/' on unix is native). */ - if (fsRecPtr->fsPtr->normalizePathProc != NULL) { - startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, - startAt); + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + continue; + } + + /* + * TODO: Assume that we always find the native file system; it should + * always be there... + */ + + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); + } + break; } - break; } for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { @@ -1524,7 +1547,7 @@ TclGetOpenModeEx( #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They are + * Check for the simpler fopen-like access modes (e.g., "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ @@ -1784,7 +1807,7 @@ Tcl_FSEvalFileEx( * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1799,7 +1822,7 @@ Tcl_FSEvalFileEx( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1815,7 +1838,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = Tcl_GetStringFromObj(objPtr, &length); + string = TclGetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. @@ -1842,7 +1865,7 @@ Tcl_FSEvalFileEx( * Record information telling where the error occurred. */ - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1889,6 +1912,7 @@ TclNREvalFile( Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } + TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect @@ -1918,7 +1942,7 @@ TclNREvalFile( * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1934,7 +1958,7 @@ TclNREvalFile( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1993,7 +2017,7 @@ EvalFileCallback( */ int length; - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); const int limit = 150; int overflow = (length > limit); @@ -2669,6 +2693,7 @@ Tcl_FSGetCwd( fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; + if (fsRecPtr->fsPtr->getCwdProc == NULL) { continue; } @@ -2845,8 +2870,8 @@ Tcl_FSGetCwd( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(norm, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and @@ -3141,8 +3166,8 @@ 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. + * 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 @@ -3159,29 +3184,31 @@ Tcl_FSLoadFile( * present and set to true (any integer > 0) then the unlink is skipped. */ -int -TclSkipUnlink (Tcl_Obj* shlibFile) +static int +skipUnlink( + Tcl_Obj *shlibFile) { - /* Order of testing: + /* + * 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) + * 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. + * 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). + * 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; + char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); - skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); } @@ -3190,7 +3217,8 @@ TclSkipUnlink (Tcl_Obj* shlibFile) #ifndef NO_FSTATFS { struct statfs fs; - /* Have fstatfs. May not have the AUFS super magic ... Indeed our build + /* + * Have fstatfs. May not have the AUFS super magic ... Indeed our build * box is too old to have it directly in the headers. Define taken from * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h * http://aufs.sourceforge.net/ @@ -3199,16 +3227,18 @@ TclSkipUnlink (Tcl_Obj* shlibFile) #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)) { + 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 */ + /* + * Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip + */ return 0; #endif /* hpux */ } @@ -3413,9 +3443,8 @@ Tcl_LoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if ( - !TclSkipUnlink (copyToPtr) && - (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { + if (!skipUnlink(copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* @@ -3683,30 +3712,10 @@ Tcl_FSUnloadFile( } return TCL_ERROR; } - TclpUnloadFile(handle); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a library given its handle - * - * This function was once filesystem-specific, but has been made portable by - * having TclpDlopen return a structure that includes procedure pointers. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile( - Tcl_LoadHandle handle) -{ if (handle->unloadFileProcPtr != NULL) { handle->unloadFileProcPtr(handle); } + return TCL_OK; } /* @@ -4114,7 +4123,7 @@ TclGetPathType( * caller. */ { int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -4226,7 +4235,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4573,8 +4582,8 @@ Tcl_FSRemoveDirectory( Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + normPathStr = TclGetStringFromObj(normPath, &normLen); + cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 30c33f1..c39c0dc 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -101,6 +101,7 @@ typedef struct { *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetIndexFromObj int Tcl_GetIndexFromObj( @@ -114,6 +115,7 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { + if (!(flags & INDEX_TEMP_TABLE)) { /* * See if there is a valid cached result from a previous lookup (doing the @@ -121,8 +123,10 @@ Tcl_GetIndexFromObj( * the common case where the result is cached). */ - if (objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &indexType); + + if (irPtr) { + IndexRep *indexRep = irPtr->twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints @@ -135,9 +139,11 @@ Tcl_GetIndexFromObj( return TCL_OK; } } + } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -211,13 +217,8 @@ GetIndexFromObjList( tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags, indexPtr); - - /* - * The internal rep must be cleared since tablePtr will go away. - */ + sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); - TclFreeIntRep(objPtr); ckfree(tablePtr); return result; @@ -270,6 +271,7 @@ Tcl_GetIndexFromObjStruct( const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; + const Tcl_ObjIntRep *irPtr; /* Protect against invalid values, like -1 or 0. */ if (offset < (int)sizeof(char *)) { @@ -279,13 +281,16 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (!(flags & INDEX_TEMP_TABLE)) { + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } } + } /* * Lookup the value of the object in the table. Accept unique @@ -340,17 +345,21 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (!(flags & INDEX_TEMP_TABLE)) { + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; } else { - TclFreeIntRep(objPtr); + Tcl_ObjIntRep ir; + indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + ir.twoPtrValue.ptr1 = indexRep; + Tcl_StoreIntRep(objPtr, &indexType, &ir); } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; + } *indexPtr = index; return TCL_OK; @@ -448,16 +457,10 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; - register char *buf; - register unsigned len; + IndexRep *indexRep = Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; register const char *indexStr = EXPAND_OF(indexRep); - len = strlen(indexStr); - buf = ckalloc(len + 1); - memcpy(buf, indexStr, len+1); - objPtr->bytes = buf; - objPtr->length = len; + Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); } /* @@ -483,12 +486,14 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_ObjIntRep ir; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); - memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; - dupPtr->typePtr = &indexType; + memcpy(dupIndexRep, Tcl_FetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, + sizeof(IndexRep)); + + ir.twoPtrValue.ptr1 = dupIndexRep; + Tcl_StoreIntRep(dupPtr, &indexType, &ir); } /* @@ -512,7 +517,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -712,10 +717,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -768,13 +773,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -959,10 +964,10 @@ Tcl_WrongNumArgs( /* * Add the element, quoting it if necessary. */ + const Tcl_ObjIntRep *irPtr; - if (origObjv[i]->typePtr == &indexType) { - register IndexRep *indexRep = - origObjv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(origObjv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); @@ -1009,9 +1014,10 @@ Tcl_WrongNumArgs( * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ + const Tcl_ObjIntRep *irPtr; - if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(objv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else { @@ -1149,7 +1155,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = Tcl_GetStringFromObj(curArg, &length); + str = TclGetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2a3d2a0..4c08fca 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -50,7 +50,7 @@ declare 6 { declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } @@ -73,7 +73,7 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) @@ -88,7 +88,7 @@ declare 14 { declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} @@ -114,7 +114,7 @@ declare 23 { } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - int TclFormatInt(char *buffer, long n) + int TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) @@ -123,7 +123,7 @@ declare 25 { # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) @@ -147,7 +147,7 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} @@ -160,7 +160,7 @@ declare 34 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} @@ -185,9 +185,9 @@ declare 41 { declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -220,14 +220,14 @@ declare 50 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char **argv) + int argc, const char **argv) } declare 54 { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, @@ -273,7 +273,7 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) @@ -313,9 +313,7 @@ declare 75 { declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: @@ -357,7 +355,7 @@ declare 81 { # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -declare 88 { +declare 88 {deprecated {}} { char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags) } @@ -380,7 +378,7 @@ declare 92 { declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -419,7 +417,7 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: @@ -455,26 +453,26 @@ declare 111 { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { @@ -490,28 +488,28 @@ declare 120 { Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { @@ -532,7 +530,7 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 @@ -550,7 +548,7 @@ declare 133 { # int TclpChdir(const char *dirName) #} declare 138 { - CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, @@ -562,7 +560,7 @@ declare 138 { #} # This is used by TclX, but should otherwise be considered private declare 141 { - CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -625,12 +623,10 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { @@ -676,13 +672,10 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars @@ -730,12 +723,11 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED @@ -748,12 +740,10 @@ declare 179 { # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } @@ -937,10 +927,7 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } @@ -1009,7 +996,7 @@ declare 250 { # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - char *bytes, int length, int flags) + const char *bytes, int length, int flags) } # Exporting of the internal API to variables. @@ -1088,9 +1075,9 @@ declare 9 win { } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { - Tcl_DirEntry *TclpReaddir(DIR *dir) + Tcl_DirEntry *TclpReaddir(TclDIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} @@ -1140,7 +1127,6 @@ declare 19 win { declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } @@ -1226,7 +1212,7 @@ declare 9 unix { # Added in 8.4: declare 10 unix { - Tcl_DirEntry *TclpReaddir(DIR *dir) + Tcl_DirEntry *TclpReaddir(TclDIR *dir) } # Slots 11 and 12 are forwarders for functions that were promoted to # generic Stubs @@ -1272,7 +1258,7 @@ declare 19 macosx { } declare 29 {win unix} { - int TclWinCPUID(unsigned int index, unsigned int *regs) + int TclWinCPUID(int index, int *regs) } # Added in 8.6; core of TclpOpenTemporaryFile declare 30 {win unix} { diff --git a/generic/tclInt.h b/generic/tclInt.h index ac67ebd..453c10f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,6 +26,36 @@ #undef ACCEPT_NAN /* + * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3. + * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them + * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+ + * releases. Perhaps Tcl 8.7 will add even better public interfaces + * supporting all the re-invocation mechanisms extensions like Itcl 3 + * need. As an absolute last resort, folks who must make Itcl 3 work + * unchanged with Tcl 8.7 can remove this line to regain the migration + * support. Tcl 9 will no longer offer even that option. + */ + +#define AVOID_HACKS_FOR_ITCL 1 + + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + * Also used in the platform-specific *Port.h files. + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + + + +/* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but @@ -82,19 +112,6 @@ typedef int ptrdiff_t; #endif /* - * Used to tag functions that are only to be visible within the module being - * built and not outside it (where this is supported by the linker). - */ - -#ifndef MODULE_SCOPE -# ifdef __cplusplus -# define MODULE_SCOPE extern "C" -# else -# define MODULE_SCOPE extern -# endif -#endif - -/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". @@ -103,19 +120,19 @@ typedef int ptrdiff_t; #if !defined(INT2PTR) && !defined(PTR2INT) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((int)(intptr_t)(p)) +# define PTR2INT(p) ((intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) -# define PTR2INT(p) ((int)(p)) +# define PTR2INT(p) ((long)(p)) # endif #endif #if !defined(UINT2PTR) && !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) # define UINT2PTR(p) ((void *)(uintptr_t)(p)) -# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p)) +# define PTR2UINT(p) ((uintptr_t)(p)) # else # define UINT2PTR(p) ((void *)(p)) -# define PTR2UINT(p) ((unsigned int)(p)) +# define PTR2UINT(p) ((unsigned long)(p)) # endif #endif @@ -123,6 +140,26 @@ typedef int ptrdiff_t; # define vsnprintf _vsnprintf #endif +#if !defined(TCL_THREADS) +# define TCL_THREADS 1 +#endif +#if !TCL_THREADS +# undef TCL_DECLARE_MUTEX +# define TCL_DECLARE_MUTEX(name) +# undef Tcl_MutexLock +# define Tcl_MutexLock(mutexPtr) +# undef Tcl_MutexUnlock +# define Tcl_MutexUnlock(mutexPtr) +# undef Tcl_MutexFinalize +# define Tcl_MutexFinalize(mutexPtr) +# undef Tcl_ConditionNotify +# define Tcl_ConditionNotify(condPtr) +# undef Tcl_ConditionWait +# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +# undef Tcl_ConditionFinalize +# define Tcl_ConditionFinalize(condPtr) +#endif + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. @@ -147,13 +184,13 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - CONST84 char *name, int length, Tcl_Namespace *context, + const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { @@ -252,7 +289,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - long nsId; /* Unique id for the namespace. */ + unsigned long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -261,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - int refCount; /* Count of references by namespaceName + unsigned int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -286,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + unsigned int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name + unsigned int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -318,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + unsigned int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -419,7 +456,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + unsigned int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -532,7 +569,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -605,7 +642,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + unsigned int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -937,7 +974,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + unsigned int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1054,7 +1091,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - int refCount; + unsigned int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1133,6 +1170,10 @@ typedef struct CallFrame { * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ +#define FRAME_IS_PRIVATE_DEFINE 0x10 + /* Marks this frame as being used for private + * declarations with [oo::define]. Usually + * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 @@ -1216,7 +1257,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + unsigned int refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1344,7 +1385,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, */ #define TCL_TSD_INIT(keyPtr) \ - (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- @@ -1479,11 +1520,11 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + size_t refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, -1. */ + * 0. If in a local literal table, (size_t)-1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce @@ -1503,7 +1544,7 @@ typedef struct LiteralTable { * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + unsigned int mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1621,12 +1662,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each + unsigned int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + unsigned int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1849,6 +1890,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1856,6 +1898,11 @@ typedef struct Interp { * partialResult. */ int appendUsed; /* Number of non-null bytes currently stored * at partialResult. */ +#else + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif /* * Information about packages. Used only in tclPkg.c. @@ -1885,7 +1932,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - int compileEpoch; /* Holds the current "compilation epoch" for + unsigned int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -1917,8 +1964,14 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ - char resultSpace[TCL_RESULT_SIZE+1]; +#if TCL_MAJOR_VERSION < 9 +# if !defined(TCL_NO_DEPRECATED) + char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; /* Static space holding small results. */ +# else + char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; +# endif +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -2311,6 +2364,13 @@ typedef struct Interp { #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* + * A common panic alert when memory allocation fails. + */ + +#define TclOOM(ptr, size) \ + ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1))) + +/* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ @@ -2361,7 +2421,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - int refCount; + unsigned int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2384,12 +2444,6 @@ typedef struct List { #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) -#define ListSetIntRep(objPtr, listRepPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ - (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ - (listRepPtr)->refCount++, \ - (objPtr)->typePtr = &tclListType - #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -2422,40 +2476,46 @@ typedef struct List { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* - * Macros providing a faster path to integers: Tcl_GetLongFromObj, - * Tcl_GetIntFromObj and TclGetIntForIndex. + * Macros providing a faster path to booleans and integers: + * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj + * and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : ((objPtr)->typePtr == &tclBooleanType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) - -#if (LONG_MAX == INT_MAX) -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) -#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) #else +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ + ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#endif + #define TclGetIntFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ - && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ + ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= INT_MIN \ - && (objPtr)->internalRep.longValue <= INT_MAX) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + && (objPtr)->internalRep.wideValue >= INT_MIN \ + && (objPtr)->internalRep.wideValue <= INT_MAX) \ + ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) -#endif /* * Macro used to save a function call for common uses of @@ -2465,21 +2525,11 @@ typedef struct List { * Tcl_WideInt *wideIntPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Flag values for TclTraceDictPath(). @@ -2545,6 +2595,15 @@ typedef struct TclFileAttrProcs { } TclFileAttrProcs; /* + * Private flag value which controls Tcl_GetIndexFromObj*() routines + * to instruct them not to cache lookups because the table will not + * live long enough to make it worthwhile. Must not clash with public + * flag value TCL_EXACT. + */ + +#define INDEX_TEMP_TABLE 2 + +/* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ @@ -2594,7 +2653,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2606,9 +2665,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, */ typedef struct ProcessGlobalValue { - int epoch; /* Epoch counter to detect changes in the + unsigned int epoch; /* Epoch counter to detect changes in the * master value. */ - int numBytes; /* Length of the master string. */ + unsigned int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ @@ -2651,8 +2710,11 @@ typedef struct ProcessGlobalValue { *---------------------------------------------------------------------- */ -#define TCL_NUMBER_LONG 1 -#define TCL_NUMBER_WIDE 2 +#define TCL_NUMBER_INT 2 +#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED) +# define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ +# define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ +#endif #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 @@ -2689,17 +2751,12 @@ MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; -MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -#ifndef TCL_WIDE_INT_IS_LONG -MODULE_SCOPE const Tcl_ObjType tclWideIntType; -#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -2732,9 +2789,12 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; * shared by all new objects allocated by Tcl_NewObj. */ -MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; +enum CheckEmptyStringResult { + TCL_EMPTYSTRING_UNKNOWN = -1, TCL_EMPTYSTRING_NO, TCL_EMPTYSTRING_YES +}; + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world, @@ -2864,8 +2924,6 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, int strLen, const unsigned char *pattern, @@ -2873,12 +2931,17 @@ MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, MODULE_SCOPE double TclCeil(const mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); +MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); +MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, @@ -2888,12 +2951,19 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, + const char *name, Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); @@ -2914,8 +2984,10 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -2933,6 +3005,7 @@ MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); +MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); @@ -2941,6 +3014,11 @@ MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); @@ -2952,6 +3030,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); +MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); @@ -2963,6 +3043,11 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); +MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, + const char *targetName, + const char *packageName); +MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, + Tcl_WideInt *); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -2982,6 +3067,9 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclInitBignumFromLong(mp_int *, long); +MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); +MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -3007,6 +3095,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, + int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -3061,7 +3151,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - int *lengthPtr, Tcl_Encoding *encodingPtr); + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); @@ -3089,16 +3179,17 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); +MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); +MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); -MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, void *data); -MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); @@ -3112,7 +3203,8 @@ MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); -MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); @@ -3124,11 +3216,16 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); +typedef int (*memCmpFn_t)(const void*, const void*, size_t); +MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, + int checkEq, int nocase, int reqlength); +MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int *nocase, + int *reqlength); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); -MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -3140,11 +3237,19 @@ MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); +MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, + const char *trim, int numTrim, int *trimRight); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); +MODULE_SCOPE void TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr); +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); +MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -3165,12 +3270,20 @@ MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsMount(Tcl_Interp *interp, const char *zipname, + const char *mntpt, const char *passwd); +MODULE_SCOPE int TclZipfsUnmount(Tcl_Interp *interp, const char *zipname); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, + const char *msg, int length); +/* Tip 430 */ +MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfs_SafeInit(Tcl_Interp *interp); -MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); /* *---------------------------------------------------------------- @@ -3192,9 +3305,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3250,7 +3365,6 @@ MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3279,7 +3393,6 @@ MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3930,6 +4043,29 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, struct CompileEnv *envPtr); /* + * Routines that provide the [string] ensemble functionality. Possible + * candidates for public interface. + */ + +MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags); +MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, + int start); +MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, + int last); +MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, + int count, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, + int first, int count, Tcl_Obj *insertPtr, + int flags); +MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); + +/* Flag values for the [string] ensemble functions. */ + +#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ +#define TCL_STRING_IN_PLACE (1<<1) + +/* * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. @@ -3980,11 +4116,70 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * Just for the purposes of command-type registration. + */ + +MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; + +/* + * TIP #462. + */ + +/* + * The following enum values give the status of a spawned process. + */ + +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ +} TclProcessWaitStatus; + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); + +/* + * TIP #508: [array default] + */ + +MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); +MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); + +/* + * Utility routines for encoding index values as integers. Used by both + * some of the command compilers and by [lsort] and [lsearch]. + */ + +MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, + int before, int after, int *indexPtr); +MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); + +/* Constants used in index value encoding routines. */ +#define TCL_INDEX_END (-2) +#define TCL_INDEX_BEFORE (-1) +#define TCL_INDEX_START (0) +#define TCL_INDEX_AFTER (INT_MAX) + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -4042,7 +4237,7 @@ typedef const char *TclDTraceStr; TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) @@ -4059,8 +4254,8 @@ typedef const char *TclDTraceStr; if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ + && ((objPtr)->bytes != &tclEmptyString)) { \ + ckfree((objPtr)->bytes); \ } \ (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ @@ -4070,6 +4265,10 @@ typedef const char *TclDTraceStr; } \ } +#if TCL_THREADS && !defined(USE_THREAD_ALLOC) +# define USE_THREAD_ALLOC 1 +#endif + #if defined(PURIFY) /* @@ -4083,11 +4282,11 @@ typedef const char *TclDTraceStr; (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) + ckfree(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#elif TCL_THREADS && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from @@ -4101,6 +4300,7 @@ MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); +MODULE_SCOPE void TclpInitAllocCache(void); MODULE_SCOPE void TclpFreeAllocCache(void *); /* @@ -4151,7 +4351,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); # define USE_TCLALLOC 0 #endif -#ifdef TCL_THREADS +#if TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; #endif @@ -4219,11 +4419,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } @@ -4241,7 +4441,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclGetString(objPtr) \ - ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) #define TclGetStringFromObj(objPtr, lenPtr) \ ((objPtr)->bytes \ @@ -4276,15 +4476,27 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if (objPtr->bytes != NULL) { \ - if (objPtr->bytes != tclEmptyStringRep) { \ - ckfree((char *) objPtr->bytes); \ + if ((objPtr)->bytes != NULL) { \ + if ((objPtr)->bytes != &tclEmptyString) { \ + ckfree((objPtr)->bytes); \ } \ - objPtr->bytes = NULL; \ + (objPtr)->bytes = NULL; \ } /* *---------------------------------------------------------------- + * Macro used by the Tcl core to test whether an object has a + * string representation (or is a 'pure' internal value). + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: @@ -4367,7 +4579,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ + ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) @@ -4410,8 +4622,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ -#define TclIsPureByteArray(objPtr) \ - (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) +MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); +#define TclIsPureDict(objPtr) \ + (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) + /* *---------------------------------------------------------------- @@ -4433,7 +4647,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); @@ -4493,51 +4707,25 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); - * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); - * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetLongObj(objPtr, i) \ +#define TclSetIntObj(objPtr, i) \ do { \ + Tcl_ObjIntRep ir; \ + ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.longValue = (long)(i); \ - (objPtr)->typePtr = &tclIntType; \ + Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \ } while (0) -#define TclSetIntObj(objPtr, l) \ - TclSetLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set - * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. - * The only "boolean" Tcl_Obj's shall be those holding the cached boolean - * value of strings like: "yes", "no", "true", "false", "on", "off". - */ - -#define TclSetBooleanObj(objPtr, b) \ - TclSetLongObj(objPtr, (b)!=0); - -#ifndef TCL_WIDE_INT_IS_LONG -#define TclSetWideIntObj(objPtr, w) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType; \ - } while (0) -#endif - #define TclSetDoubleObj(objPtr, d) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType; \ + do { \ + Tcl_ObjIntRep ir; \ + ir.doubleValue = (double) d; \ + TclInvalidateStringRep(objPtr); \ + Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \ } while (0) /* @@ -4546,39 +4734,26 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); - * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); - * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); - * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG -#define TclNewLongObj(objPtr, i) \ +#define TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#define TclNewIntObj(objPtr, l) \ - TclNewLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. - * See comment above TclSetBooleanObj macro above. - */ -#define TclNewBooleanObj(objPtr, b) \ - TclNewLongObj((objPtr), (b)!=0) - #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4601,14 +4776,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, i) \ - (objPtr) = Tcl_NewIntObj(i) - -#define TclNewLongObj(objPtr, l) \ - (objPtr) = Tcl_NewLongObj(l) - -#define TclNewBooleanObj(objPtr, b) \ - (objPtr) = Tcl_NewBooleanObj(b) +#define TclNewIntObj(objPtr, w) \ + (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) @@ -4691,7 +4860,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclCleanupCommandMacro(cmdPtr) \ if ((cmdPtr)->refCount-- <= 1) { \ - ckfree((char *) (cmdPtr));\ + ckfree(cmdPtr);\ } /* @@ -4849,7 +5018,7 @@ typedef struct NRE_callback { #else #define TCLNR_ALLOC(interp, ptr) \ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) +#define TCLNR_FREE(interp, ptr) ckfree(ptr) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index eda90b4..03a2ed2 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -28,21 +28,21 @@ # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl @@ -75,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ @@ -113,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp, /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN int TclFormatInt(char *buffer, long n); +EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -173,7 +174,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp); /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - CONST84 char **argv); + const char **argv); /* 54 */ EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, @@ -218,7 +219,8 @@ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -231,7 +233,8 @@ EXTERN char * TclpRealloc(char *ptr, unsigned int size); /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ -EXTERN char * TclPrecTraceProc(ClientData clientData, +TCL_DEPRECATED("") +char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 89 */ @@ -267,7 +270,8 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -284,22 +288,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ @@ -314,23 +318,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); @@ -350,19 +354,18 @@ EXTERN void Tcl_SetNamespaceResolvers( /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -EXTERN CONST84_RETURN char * TclGetEnv(const char *name, - Tcl_DString *valuePtr); +EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ -EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, - Tcl_DString *cwdPtr); +EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, @@ -401,9 +404,11 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -422,9 +427,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -457,16 +464,18 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -570,7 +579,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -615,7 +625,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, +EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, int length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, @@ -652,7 +662,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ @@ -668,7 +678,7 @@ typedef struct TclIntStubs { void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - int (*tclFormatInt) (char *buffer, long n); /* 24 */ + int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); @@ -697,7 +707,7 @@ typedef struct TclIntStubs { void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); @@ -721,7 +731,7 @@ typedef struct TclIntStubs { void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -732,7 +742,7 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ @@ -748,7 +758,7 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -756,36 +766,36 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); - CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ + const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ @@ -802,8 +812,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -811,8 +821,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -822,12 +832,12 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); @@ -880,7 +890,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -895,7 +905,7 @@ 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 */ + int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ @@ -1088,38 +1098,38 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1210,10 +1220,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ @@ -1350,58 +1360,28 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#if defined(USE_TCL_STUBS) +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index ac06787..51d2f65 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,11 +13,6 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef _WIN32 -# define Tcl_DirEntry void -# define DIR void -#endif - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -72,7 +67,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ @@ -98,7 +93,7 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -129,7 +124,7 @@ EXTERN int TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN int TclWinGetPlatformId(void); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -173,7 +168,7 @@ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -206,7 +201,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ @@ -247,7 +242,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -269,7 +264,7 @@ typedef struct TclIntPlatStubs { TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ @@ -288,7 +283,7 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ @@ -302,7 +297,7 @@ typedef struct TclIntPlatStubs { int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ @@ -321,7 +316,7 @@ typedef struct TclIntPlatStubs { void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -335,7 +330,7 @@ typedef struct TclIntPlatStubs { TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ @@ -354,7 +349,7 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; @@ -555,10 +550,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt -# define TclWinNToHS ntohs -# define TclWinGetServByName getservbyname -# define TclWinGetSockOpt getsockopt -# define TclWinSetSockOpt setsockopt +# undef TclWinGetPlatformId +# undef TclWinResetInterfaces +# undef TclWinSetInterfaces +# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ +# define TclWinResetInterfaces() /* nop */ +# define TclWinSetInterfaces(dummy) /* nop */ +# endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8a0d653..b1cc0c8 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -222,9 +222,6 @@ static int AliasDelete(Tcl_Interp *interp, static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int AliasObjCmd(ClientData dummy, - Tcl_Interp *currentInterp, int objc, - Tcl_Obj *const objv[]); static int AliasNRCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); @@ -257,8 +254,6 @@ static int SlaveInvokeHidden(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); static void SlaveObjCmdDeleteProc(ClientData clientData); static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, @@ -331,13 +326,24 @@ TclSetPreInitScript( *---------------------------------------------------------------------- */ +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[4]; +} PkgName; + int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { + PkgName pkgName = {NULL, "Tcl"}; + PkgName **names = TclInitPkgFiles(interp); + int result = TCL_ERROR; + + pkgName.nextPtr = *names; + *names = &pkgName; if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return TCL_ERROR; + if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { + goto end; } } @@ -382,7 +388,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - return Tcl_Eval(interp, + result = Tcl_EvalEx(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -403,6 +409,7 @@ Tcl_Init( " } else {\n" " lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" " }\n" +" lappend scripts {::tcl::zipfs::tcl_library_init}\n" " lappend scripts {\n" "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" "set grandParentDir [file dirname $parentDir]\n" @@ -410,6 +417,7 @@ Tcl_Init( " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" +" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" @@ -444,7 +452,11 @@ Tcl_Init( " error $msg\n" " }\n" "}\n" -"tclInit"); +"tclInit", -1, 0); + +end: + *names = (*names)->nextPtr; + return result; } /* @@ -1402,7 +1414,8 @@ TclPreventAliasLoop( * create or rename the command. */ - if (cmdPtr->objProc != AliasObjCmd) { + if (cmdPtr->objProc != TclAliasObjCmd + && cmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } @@ -1457,7 +1470,8 @@ TclPreventAliasLoop( * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { + if (aliasCmdPtr->objProc != TclAliasObjCmd + && aliasCmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; @@ -1523,12 +1537,12 @@ AliasCreate( if (slaveInterp == masterInterp) { aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, - AliasObjCmdDeleteProc); + TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, + aliasPtr, AliasObjCmdDeleteProc); } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, aliasPtr, - AliasObjCmdDeleteProc); + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + TclGetString(namePtr), TclAliasObjCmd, aliasPtr, + AliasObjCmdDeleteProc); } if (TclPreventAliasLoop(interp, slaveInterp, @@ -1764,7 +1778,7 @@ AliasList( /* *---------------------------------------------------------------------- * - * AliasObjCmd -- + * TclAliasObjCmd, TclLocalAliasObjCmd -- * * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, @@ -1772,6 +1786,11 @@ AliasList( * master interpreter as designated by the Alias record associated with * this command. * + * TclLocalAliasObjCmd is a stripped down version used when the source + * and target interpreters of the alias are the same. That lets a number + * of safety precautions be avoided: the state is much more precisely + * known. + * * Results: * A standard Tcl result. * @@ -1807,7 +1826,7 @@ AliasNRCmd( cmdc = prefc + objc - 1; listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = listPtr->internalRep.twoPtrValue.ptr1; + listRep = ListRepPtr(listPtr); listRep->elemCount = cmdc; cmdv = &listRep->elements; @@ -1831,8 +1850,8 @@ AliasNRCmd( return Tcl_NREvalObj(interp, listPtr, flags); } -static int -AliasObjCmd( +int +TclAliasObjCmd( ClientData clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -1921,6 +1940,73 @@ AliasObjCmd( return result; #undef ALIAS_CMDV_PREALLOC } + +int +TclLocalAliasObjCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ +#define ALIAS_CMDV_PREALLOC 10 + Alias *aliasPtr = clientData; + int result, prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; + Interp *iPtr = (Interp *) interp; + int isRootEnsemble; + + /* + * Append the arguments to the command prefix and invoke the command in + * the global namespace. + */ + + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + if (cmdc <= ALIAS_CMDV_PREALLOC) { + cmdv = cmdArr; + } else { + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + } + + memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + for (i=0; i<cmdc; i++) { + Tcl_IncrRefCount(cmdv[i]); + } + + /* + * Use the ensemble rewriting machinery to ensure correct error messages: + * only the source command should show, not the full target prefix. + */ + + isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv); + + /* + * Execute the target command in the target interpreter. + */ + + result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE); + + /* + * Clean up the ensemble rewrite info if we set it in the first place. + */ + + if (isRootEnsemble) { + TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1); + } + + for (i=0; i<cmdc; i++) { + Tcl_DecrRefCount(cmdv[i]); + } + if (cmdv != cmdArr) { + TclStackFree(interp, cmdv); + } + return result; +#undef ALIAS_CMDV_PREALLOC +} /* *---------------------------------------------------------------------- @@ -2360,10 +2446,10 @@ SlaveCreate( slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, - SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); + TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. @@ -2428,7 +2514,7 @@ SlaveCreate( /* *---------------------------------------------------------------------- * - * SlaveObjCmd -- + * TclSlaveObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to * be evaluated. One such command exists for each slave interpreter. @@ -2442,8 +2528,8 @@ SlaveCreate( *---------------------------------------------------------------------- */ -static int -SlaveObjCmd( +int +TclSlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2475,7 +2561,7 @@ NRSlaveCmd( }; if (slaveInterp == NULL) { - Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); + Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { @@ -3190,12 +3276,8 @@ Tcl_MakeSafe( * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_Eval(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}"); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, - "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, - "::tcl::mathfunc::max", 0, NULL); + (void) Tcl_EvalEx(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); } iPtr->flags |= SAFE_INTERP; @@ -3517,9 +3599,6 @@ Tcl_LimitAddHandler( if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; } - if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { - deleteProc = NULL; - } /* * Allocate a handler record. @@ -4497,7 +4576,7 @@ SlaveCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4514,7 +4593,7 @@ SlaveCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); + (void) TclGetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4706,7 +4785,7 @@ SlaveTimeLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4723,7 +4802,7 @@ SlaveTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); + (void) TclGetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } @@ -4741,7 +4820,7 @@ SlaveTimeLimitCmd( break; case OPT_SEC: secObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &secLen); + (void) TclGetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 6f75849..952df4e 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,8 +36,10 @@ typedef struct Link { unsigned int ui; short s; unsigned short us; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; +#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; @@ -129,6 +131,14 @@ Tcl_LinkVar( Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; +#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ + || defined(_WIN32) || defined(__CYGWIN__)) + if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { + linkPtr->type = TCL_LINK_LONG; + } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { + linkPtr->type = TCL_LINK_ULONG; + } +#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -335,12 +345,14 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: changed = (LinkedVar(long) != linkPtr->lastValue.l); break; case TCL_LINK_ULONG: changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); break; +#endif case TCL_LINK_FLOAT: changed = (LinkedVar(float) != linkPtr->lastValue.f); break; @@ -404,7 +416,8 @@ LinkTraceProc( case TCL_LINK_DOUBLE: if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN - if (valueObj->typePtr != &tclDoubleType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(valueObj, &tclDoubleType); + if (irPtr == NULL) { #endif if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), @@ -413,7 +426,7 @@ LinkTraceProc( } #ifdef ACCEPT_NAN } - linkPtr->lastValue.d = valueObj->internalRep.doubleValue; + linkPtr->lastValue.d = irPtr->doubleValue; #endif } LinkedVar(double) = linkPtr->lastValue.d; @@ -483,6 +496,7 @@ LinkTraceProc( LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) @@ -504,6 +518,7 @@ LinkTraceProc( } LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; +#endif case TCL_LINK_WIDE_UINT: /* @@ -581,7 +596,7 @@ ObjValue( return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); @@ -597,12 +612,14 @@ ObjValue( case TCL_LINK_UINT: linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif case TCL_LINK_FLOAT: linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); @@ -643,17 +660,16 @@ static Tcl_ObjType invalidRealType = { static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { - int length; const char *str; const char *endPtr; - str = TclGetStringFromObj(objPtr, &length); - if ((length == 1) && (str[0] == '.')){ + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')){ objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } - if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { /* If number is followed by [eE][+-]?, then it is an invalid * double, but it could be the start of a valid double. */ @@ -663,7 +679,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { if (*endPtr == 0) { double doubleValue = 0.0; Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); + TclFreeIntRep(objPtr); objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = doubleValue; return TCL_OK; @@ -677,17 +693,16 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { /* * This function checks for integer representations, which are valid * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o" + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" * (upperand lowercase). See bug [39f6304c2e]. */ int -GetInvalidIntFromObj(Tcl_Obj *objPtr, - int *intPtr) +GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) { const char *str = TclGetString(objPtr); if ((objPtr->length == 0) || - ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { + ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { *intPtr = 0; return TCL_OK; } else if ((objPtr->length == 1) && strchr("+-", str[0])) { @@ -716,8 +731,7 @@ GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. */ int -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, - double *doublePtr) +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) { int intValue; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3a1555d..2078989 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" +#include <assert.h> /* * Prototypes for functions defined later in this file: @@ -46,6 +47,27 @@ const Tcl_ObjType tclListType = { SetListFromAny /* setFromAnyProc */ }; +/* Macros to manipulate the List internal rep */ + +#define ListSetIntRep(objPtr, listRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (listRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + (listRepPtr)->refCount++; \ + Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ + } while (0) + +#define ListGetIntRep(objPtr, listRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclListType); \ + (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + +#define ListResetIntRep(objPtr, listRepPtr) \ + Tcl_FetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) + #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif @@ -374,8 +396,7 @@ Tcl_SetListObj( listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; + Tcl_InitStringRep(objPtr, NULL, 0); } } @@ -407,8 +428,10 @@ TclListObjCopy( * to be returned. */ { Tcl_Obj *copyPtr; + List *listRepPtr; - if (listPtr->typePtr != &tclListType) { + ListGetIntRep(listPtr, listRepPtr); + if (NULL == listRepPtr) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } @@ -423,6 +446,87 @@ TclListObjCopy( /* *---------------------------------------------------------------------- * + * TclListObjRange -- + * + * Makes a slice of a list value. + * *listPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + Tcl_Obj **elemPtrs; + int listLen, i, newLen; + List *listRepPtr; + + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= listLen) { + toIdx = listLen-1; + } + if (fromIdx > toIdx) { + return Tcl_NewObj(); + } + + newLen = toIdx - fromIdx + 1; + + if (Tcl_IsShared(listPtr) || + ((ListRepPtr(listPtr)->refCount > 1))) { + return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(listPtr); + + /* + * Delete elements that should not be included. + */ + + for (i = 0; i < fromIdx; i++) { + TclDecrRefCount(elemPtrs[i]); + } + for (i = toIdx + 1; i < listLen; i++) { + TclDecrRefCount(elemPtrs[i]); + } + + if (fromIdx > 0) { + memmove(elemPtrs, &elemPtrs[fromIdx], + (size_t) newLen * sizeof(Tcl_Obj*)); + } + + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = newLen; + + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list @@ -462,10 +566,13 @@ Tcl_ListObjGetElements( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); - if (listPtr->bytes == tclEmptyStringRep) { + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -474,8 +581,8 @@ Tcl_ListObjGetElements( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -572,10 +679,13 @@ Tcl_ListObjAppendElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -583,9 +693,9 @@ Tcl_ListObjAppendElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; needGrow = (numRequired > listRepPtr->maxElemCount); @@ -681,7 +791,11 @@ Tcl_ListObjAppendElement( } listRepPtr = newPtr; } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; /* * Add objPtr to the end of listPtr's array of element pointers. Increment @@ -736,10 +850,12 @@ Tcl_ListObjIndex( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objPtrPtr = NULL; return TCL_OK; } @@ -747,9 +863,9 @@ Tcl_ListObjIndex( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -789,10 +905,12 @@ Tcl_ListObjLength( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *intPtr = 0; return TCL_OK; } @@ -800,9 +918,9 @@ Tcl_ListObjLength( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -862,9 +980,14 @@ Tcl_ListObjReplace( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == tclEmptyStringRep) { - if (!objc) { + + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { + if (objc == 0) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); @@ -875,6 +998,7 @@ Tcl_ListObjReplace( return result; } } + ListGetIntRep(listPtr, listRepPtr); } /* @@ -885,7 +1009,6 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -939,7 +1062,7 @@ Tcl_ListObjReplace( } if (newPtr) { listRepPtr = newPtr; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; @@ -1012,7 +1135,7 @@ Tcl_ListObjReplace( } } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1085,10 +1208,15 @@ Tcl_ListObjReplace( listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old string representation since it no longer - * reflects the list's internal representation. + * Invalidate and free any old representations that may not agree + * with the revised list's internal representation. */ + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1127,6 +1255,7 @@ TclLindexList( int index; /* Index into the list. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether argPtr designates a list or a single index. We have @@ -1134,7 +1263,8 @@ TclLindexList( * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + ListGetIntRep(argPtr, listRepPtr); + if ((listRepPtr == NULL) && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. @@ -1165,19 +1295,12 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - if (indexListCopy->typePtr == &tclListType) { - List *listRepPtr = ListRepPtr(indexListCopy); + ListGetIntRep(indexListCopy, listRepPtr); - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); - } else { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; - /* Array of list indices. */ + assert(listRepPtr != NULL); - Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); - listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); - } + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1312,6 +1435,7 @@ TclLsetList( Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. @@ -1319,7 +1443,8 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (indexArgPtr->typePtr != &tclListType + ListGetIntRep(indexArgPtr, listRepPtr); + if (listRepPtr == NULL && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. @@ -1404,6 +1529,7 @@ TclLsetFlat( { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; + Tcl_ObjIntRep *irPtr; /* * If there are no indices, simply return the new value. (Without @@ -1534,7 +1660,8 @@ TclLsetFlat( * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = chainPtr; + irPtr = Tcl_FetchIntRep(parentList, &tclListType); + irPtr->twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); @@ -1548,22 +1675,32 @@ TclLsetFlat( while (chainPtr) { Tcl_Obj *objPtr = chainPtr; + List *listRepPtr; + + /* + * Clear away our intrep surgery mess. + */ + irPtr = Tcl_FetchIntRep(objPtr, &tclListType); + listRepPtr = irPtr->twoPtrValue.ptr1; + chainPtr = irPtr->twoPtrValue.ptr2; + if (result == TCL_OK) { + /* * We're going to store valuePtr, so spoil string reps of all * containing lists. */ + listRepPtr->refCount++; + TclFreeIntRep(objPtr); + ListSetIntRep(objPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(objPtr); + } else { + irPtr->twoPtrValue.ptr2 = NULL; } - - /* - * Clear away our intrep surgery mess. - */ - - chainPtr = objPtr->internalRep.twoPtrValue.ptr2; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { @@ -1590,8 +1727,8 @@ TclLsetFlat( Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); } - TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } @@ -1647,10 +1784,13 @@ TclListObjSetElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); @@ -1663,9 +1803,9 @@ TclListObjSetElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* @@ -1708,7 +1848,8 @@ TclListObjSetElement( listRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; + listRepPtr = newPtr; + ListResetIntRep(listPtr, listRepPtr); } elemPtrs = &listRepPtr->elements; @@ -1730,6 +1871,18 @@ TclListObjSetElement( elemPtrs[index] = valuePtr; + /* + * Invalidate outdated intreps. + */ + + ListGetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + + TclInvalidateStringRep(listPtr); + return TCL_OK; } @@ -1745,9 +1898,8 @@ TclListObjSetElement( * None. * * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * Frees listPtr's List* internal representation, if no longer shared. + * May decrement the ref counts of element objects, which may free them. * *---------------------------------------------------------------------- */ @@ -1756,7 +1908,10 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr = ListRepPtr(listPtr); + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; @@ -1767,8 +1922,6 @@ FreeListInternalRep( } ckfree(listRepPtr); } - - listPtr->typePtr = NULL; } /* @@ -1793,8 +1946,10 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = ListRepPtr(srcPtr); + List *listRepPtr; + ListGetIntRep(srcPtr, listRepPtr); + assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } @@ -1833,7 +1988,7 @@ SetListFromAny( * describe duplicate keys). */ - if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { + if (!TclHasStringRep(objPtr) && Tcl_FetchIntRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; @@ -1891,28 +2046,37 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; + char *check; int elemSize, literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { + fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } - ckfree((char *) listRepPtr); + ckfree(listRepPtr); return TCL_ERROR; } if (elemStart == limit) { break; } - /* TODO: replace panic with error on alloc failure? */ - if (literal) { - TclNewStringObj(*elemPtrs, elemStart, elemSize); - } else { - TclNewObj(*elemPtrs); - (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); - (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, - (*elemPtrs)->bytes); + TclNewObj(*elemPtrs); + TclInvalidateStringRep(*elemPtrs); + check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct list, out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + goto fail; + } + if (!literal) { + Tcl_InitStringRep(*elemPtrs, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ @@ -1922,12 +2086,11 @@ SetListFromAny( } /* - * Free the old internalRep before setting the new one. We do this as late + * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use that old internalRep. + * Tcl_GetStringFromObj, to use the old internalRep. */ - TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1959,12 +2122,17 @@ UpdateStringOfList( { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - List *listRepPtr = ListRepPtr(listPtr); - int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; + int numElems, i, length, bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **elemPtrs; + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + + assert(listRepPtr != NULL); + + numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string @@ -1979,8 +2147,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = tclEmptyStringRep; - listPtr->length = 0; + Tcl_InitStringRep(listPtr, NULL, 0); return; } @@ -2009,22 +2176,21 @@ UpdateStringOfList( if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - bytesNeeded += numElems; + bytesNeeded += numElems - 1; /* * Pass 2: copy into string rep buffer. */ - listPtr->length = bytesNeeded - 1; - listPtr->bytes = ckalloc(bytesNeeded); - dst = listPtr->bytes; + dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - listPtr->bytes[listPtr->length] = '\0'; + (void) Tcl_InitStringRep(listPtr, NULL, bytesNeeded); if (flagPtr != localFlags) { ckfree(flagPtr); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 4ae94a0..003884d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -174,7 +174,7 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - char *bytes, /* The start of the string. Note that this is + const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ int length, /* Number of bytes in the string. */ unsigned hash, /* The string's hash. If -1, it will be @@ -186,7 +186,7 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - int globalHash; + unsigned int globalHash; Tcl_Obj *objPtr; /* @@ -229,20 +229,22 @@ TclCreateLiteral( } /* - * The literal is new to the interpreter. Add it to the global literal - * table. + * The literal is new to the interpreter. */ TclNewObj(objPtr); if ((flags & LITERAL_ON_HEAP)) { - objPtr->bytes = bytes; + objPtr->bytes = (char *) bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } + /* Should the new literal be shared globally? */ + if ((flags & LITERAL_UNSHARED)) { /* + * No, do *not* add it the global literal table * Make clear, that no global value is returned */ if (globalPtrPtr != NULL) { @@ -251,6 +253,9 @@ TclCreateLiteral( return objPtr; } + /* + * Yes, add it to the global literal table. + */ #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", @@ -370,7 +375,7 @@ int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register char *bytes, /* Points to string for which to find or + register const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ int length, /* Number of bytes in the string. If < 0, the @@ -388,7 +393,8 @@ TclRegisterLiteral( LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; - int localHash, objIndex, new; + unsigned int localHash; + int objIndex, new; Namespace *nsPtr; if (length < 0) { @@ -532,7 +538,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; + unsigned int localHash; + int length; const char *bytes; Tcl_Obj *newObjPtr; @@ -551,7 +558,7 @@ TclHideLiteral( lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); + localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { @@ -607,7 +614,7 @@ TclAddLiteralObj( lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = -1; /* i.e., unused */ + lPtr->refCount = (size_t)-1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { @@ -682,7 +689,7 @@ AddLocalLiteralEntry( } if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } @@ -804,7 +811,8 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + int length; + unsigned int index; if (iPtr == NULL) { goto done; @@ -823,15 +831,13 @@ TclReleaseLiteral( for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { - entryPtr->refCount--; - /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ - if (entryPtr->refCount == 0) { + if (entryPtr->refCount-- <= 1) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { @@ -949,8 +955,8 @@ RebuildLiteralTable( register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - unsigned int oldSize; - int count, index, length; + unsigned int oldSize, index; + int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1036,7 +1042,7 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { @@ -1158,7 +1164,7 @@ TclVerifyLocalLiteralTable( localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); @@ -1209,7 +1215,7 @@ TclVerifyGlobalLiteralTable( globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + bytes = TclGetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f1bd248..77e6425 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -470,6 +470,19 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 + Interp *iPtr = (Interp *) target; + if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); + iPtr->result = &tclEmptyString; + iPtr->freeProc = NULL; + } +#endif /* defined(TCL_NO_DEPRECATED) */ Tcl_TransferResult(target, code, interp); goto done; } @@ -998,7 +1011,7 @@ Tcl_StaticPackage( } /* - * Package isn't loade in the current interp yet. Mark it as now being + * Package isn't loaded in the current interp yet. Mark it as now being * loaded. */ @@ -1012,10 +1025,10 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages -- + * TclGetLoadedPackages, TclGetLoadedPackagesEx -- * * This function returns information about all of the files that are - * loaded (either in a particular intepreter, or for all interpreters). + * loaded (either in a particular interpreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a @@ -1039,16 +1052,27 @@ TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { + return TclGetLoadedPackagesEx(interp, targetName, NULL); +} + +int +TclGetLoadedPackagesEx( + Tcl_Interp *interp, /* Interpreter in which to return information + * or error message. */ + const char *targetName, /* Name of target interpreter or NULL. If + * NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ + const char *packageName) /* Package name or NULL. If NULL, return info + * for all packages. + */ +{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - /* - * Return information about all of the available packages. - */ - resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; @@ -1063,16 +1087,38 @@ TclGetLoadedPackages( return TCL_OK; } - /* - * Return information about only the packages that are loaded in a given - * interpreter. - */ - target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + + /* + * Return information about all of the available packages. + */ + if (packageName) { + resultObj = NULL; + + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + + if (!strcmp(packageName, pkgPtr->packageName)) { + resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + break; + } + } + + if (resultObj) { + Tcl_SetObjResult(interp, resultObj); + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in a given + * interpreter. + */ + resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; diff --git a/generic/tclMain.c b/generic/tclMain.c index 927de7e..9380fb2 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -112,7 +112,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -246,7 +246,7 @@ Tcl_SourceRCFile( const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; @@ -283,7 +283,7 @@ Tcl_SourceRCFile( /*---------------------------------------------------------------------- * - * Tcl_Main, Tcl_MainEx -- + * Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -532,7 +532,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(is.commandPtr, &length); + TclGetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -549,7 +549,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -634,21 +634,6 @@ Tcl_MainEx( Tcl_Exit(exitCode); } - -#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE) -#undef Tcl_Main -extern DLLEXPORT void -Tcl_Main( - int argc, /* Number of arguments. */ - char **argv, /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc) - /* Application-specific initialization - * function to call after most initialization - * but before starting to execute commands. */ -{ - Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); -} -#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -808,7 +793,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - Tcl_GetStringFromObj(commandPtr, &length); + TclGetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -839,7 +824,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index ba8e8ce..27aafc3 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -25,14 +25,15 @@ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ +#include <assert.h> /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ -typedef struct ThreadSpecificData { - long numNsCreated; /* Count of the number of namespaces created +typedef struct { + unsigned long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to @@ -59,7 +60,7 @@ typedef struct ResolvedNsName { * the name was resolved. NULL if the name is * fully qualified and thus the resolution * does not depend on the context. */ - int refCount; /* Reference count: 1 for each nsName object + size_t refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount @@ -89,8 +90,6 @@ static char * EstablishErrorInfoTraces(ClientData clientData, static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -static int InvokeImportedCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, @@ -154,6 +153,22 @@ static const Tcl_ObjType nsNameType = { SetNsNameFromAny /* setFromAnyProc */ }; +#define NsNameSetIntRep(objPtr, nnPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (nnPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (nnPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ + } while (0) + +#define NsNameGetIntRep(objPtr, nnPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &nsNameType); \ + (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. @@ -402,7 +417,7 @@ Tcl_PopCallFrame( } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (--framePtr->localCachePtr->refCount == 0) { + if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; @@ -1323,8 +1338,7 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } } @@ -1767,7 +1781,7 @@ DoImport( dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; @@ -1988,7 +2002,7 @@ TclGetOriginalCommand( /* *---------------------------------------------------------------------- * - * InvokeImportedCmd -- + * TclInvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another @@ -2019,8 +2033,8 @@ InvokeImportedNRCmd( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } -static int -InvokeImportedCmd( +int +TclInvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -2422,6 +2436,35 @@ TclGetNamespaceForQualName( /* *---------------------------------------------------------------------- * + * TclEnsureNamespace -- + * + * Provide a namespace that is not deleted. + * + * Value + * + * namespacePtr, if it is not scheduled for deletion, or a pointer to a + * new namespace with the same name otherwise. + * + * Effect + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Namespace * +TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + if (!(nsPtr->flags & NS_DYING)) { + return namespacePtr; + } + return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FindNamespace -- * * Searches for a namespace. @@ -2636,7 +2679,7 @@ Tcl_FindCommand( Namespace *nsPtr[2]; register int search; - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* @@ -2872,26 +2915,29 @@ GetNamespaceFromObj( Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; - Namespace *nsPtr, *refNsPtr; - if (objPtr->typePtr == &nsNameType) { + NsNameGetIntRep(objPtr, resNamePtr); + if (resNamePtr) { + Namespace *nsPtr, *refNsPtr; + /* * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && - (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) + && (!refNsPtr || (refNsPtr == + (Namespace *) TclGetCurrentNamespace(interp)))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } + Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } @@ -4661,15 +4707,17 @@ FreeNsNameInternalRep( register Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); + /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + if (resNamePtr->refCount-- <= 1) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free @@ -4679,7 +4727,6 @@ FreeNsNameInternalRep( TclNsDecrRefCount(resNamePtr->nsPtr); ckfree(resNamePtr); } - objPtr->typePtr = NULL; } /* @@ -4706,11 +4753,11 @@ DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; - copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - resNamePtr->refCount++; - copyPtr->typePtr = &nsNameType; + NsNameGetIntRep(srcPtr, resNamePtr); + assert(resNamePtr != NULL); + NsNameSetIntRep(copyPtr, resNamePtr); } /* @@ -4755,36 +4802,25 @@ SetNsNameFromAny( TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + return TCL_ERROR; + } + /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { - /* - * Our failed lookup proves any previously cached nsName intrep is no - * longer valid. Get rid of it so we no longer waste memory storing - * it, nor time determining its invalidity again and again. - */ - - if (objPtr->typePtr == &nsNameType) { - TclFreeIntRep(objPtr); - } - return TCL_ERROR; - } - nsPtr->refCount++; resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - resNamePtr->refCount = 1; - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - objPtr->typePtr = &nsNameType; + resNamePtr->refCount = 0; + NsNameSetIntRep(objPtr, resNamePtr); return TCL_OK; } diff --git a/generic/tclOO.c b/generic/tclOO.c index f236ac9..01be0fc 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -4,6 +4,7 @@ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -30,6 +31,7 @@ static const struct { {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, @@ -40,7 +42,9 @@ static const struct { {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -55,11 +59,8 @@ static const struct { * Function declarations for things defined in this file. */ -static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - const char *nsNameStr); -static void ClearMixins(Class *clsPtr); -static void ClearSuperclasses(Class *clsPtr); + Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -71,6 +72,9 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -79,22 +83,20 @@ static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); -static void SquelchedNsFirst(ClientData clientData); -static int PublicObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateObjectCmd(ClientData clientData, +static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(ClientData clientData, +static int MyClassNRObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static void MyClassDeleted(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -145,65 +147,10 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of slots. + * The scripted part of the definitions of TclOO. */ -static const char *slotScript = -"::oo::define ::oo::Slot {\n" -" method Get {} {error unimplemented}\n" -" method Set list {error unimplemented}\n" -" method -set args {\n" -" uplevel 1 [list [namespace which my] Set $args]\n" -" }\n" -" method -append args {\n" -" uplevel 1 [list [namespace which my] Set [list" -" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" -" }\n" -" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" -" forward --default-operation my -append\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" return [uplevel 1 [list [namespace which my] $def]]\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" -" }\n" -" next {*}$args\n" -" }\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; - -/* - * The body of the <cloned> method of oo::object. - */ - -static const char *clonedBody = -"foreach p [info procs [info object namespace $originObject]::*] {" -" set args [info args $p];" -" set idx -1;" -" foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" -" };" -" set b [info body $p];" -" set p [namespace tail $p];" -" proc $p $args $b;" -"};" -"foreach v [info vars [info object namespace $originObject]::*] {" -" upvar 0 $v vOrigin;" -" namespace upvar [namespace current] [namespace tail $v] vNew;" -" if {[info exists vOrigin]} {" -" if {[array exists vOrigin]} {" -" array set vNew [array get vOrigin];" -" } else {" -" set vNew $vOrigin;" -" }" -" }" -"}"; +#include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. @@ -227,10 +174,52 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; * ROOT_CLASS respectively. */ -#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +#define RemoveItem(type, lst, i) \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ + } while (0) + +/* + * ---------------------------------------------------------------------- + * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} /* * ---------------------------------------------------------------------- @@ -266,7 +255,7 @@ TclOOInit( * to be fully provided. */ - if (Tcl_Eval(interp, initScript) != TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { return TCL_ERROR; } @@ -311,7 +300,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -374,28 +363,10 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ - fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "::oo::object", NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "::oo::class", NULL)); - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->objectCls); + InitClassSystemRoots(interp, fPtr); /* * Basic method declarations for the core classes. @@ -409,18 +380,6 @@ InitFoundation( } /* - * Create the default <cloned> method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. - */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. @@ -460,7 +419,86 @@ InitFoundation( if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - return Tcl_Eval(interp, slotScript); + + /* + * Evaluate the remaining definitions, which are a compiled-in Tcl script. + */ + + return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); +} + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in TclOOAllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = TclOOAllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ + AddRef(fPtr->objectCls->thisPtr); + + /* This is why it is unnecessary in this routine to replace the + * incremented reference count of fPtr->objectCls that was swallowed by + * fakeObject. */ + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + + /* special initialization for the primordial objects */ + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + + fPtr->classCls = TclOOAllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ + AddRef(fPtr->classCls->thisPtr); + + /* + * Increment reference counts for each reference because these + * relationships can be dynamically changed. + * + * Corresponding TclOODecrRefCount for all incremented refcounts is in + * KillFoundation. + */ + + /* Rewire bootstrapped objects. */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + + /* Standard initialization for new Objects */ + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + + /* + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. + */ } /* @@ -521,13 +559,14 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->objectCls); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); + TclOODecrRefCount(fPtr->objectCls->thisPtr); + TclOODecrRefCount(fPtr->classCls->thisPtr); + ckfree(fPtr); } @@ -537,8 +576,11 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. The caller must set the classPtr on the object, - * either to a class or to NULL. + * class's instance list. The caller must set the classPtr on the object + * to either a class or NULL, call TclOOAddToInstances to add the object + * to the class's instance list, and if the object itself is a class, use + * call TclOOAddToSubclasses() to add it to the right class's list of + * subclasses. * * ---------------------------------------------------------------------- */ @@ -551,6 +593,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -561,7 +605,7 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch, ignored; + int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -579,8 +623,7 @@ AllocObject( */ if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; @@ -592,8 +635,7 @@ AllocObject( char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; @@ -608,12 +650,16 @@ AllocObject( Tcl_ResetResult(interp); } + + configNamespace: + + ((Namespace *)oPtr->namespacePtr)->refCount++; + /* * Make the namespace know about the helper commands. This grants access * to the [self] and [next] commands. */ - configNamespace: if (fPtr->helpersNs != NULL) { TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); } @@ -633,16 +679,22 @@ AllocObject( * access variables in it. [Bug 2950259] */ - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. */ oPtr->fPtr = fPtr; - oPtr->selfCls = fPtr->objectCls; oPtr->creationEpoch = creationEpoch; - oPtr->refCount = 1; + + /* + * An object starts life with a refCount of 2 to mark the two stages of + * destruction it occur: A call to ObjectRenamedTrace(), and a call to + * ObjectNamespaceDeleted(). + */ + + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -652,23 +704,14 @@ AllocObject( */ if (!nameStr) { - oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); - } else if (nameStr[0] == ':' && nameStr[1] == ':') { - oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - PublicObjectCmd, oPtr, NULL); - } else { - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, - Tcl_GetCurrentNamespace(interp)->fullName, -1); - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, nameStr, -1); - oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); - Tcl_DStringFree(&buffer); + nameStr = oPtr->namespacePtr->name; + nsPtr = (Namespace *)oPtr->namespacePtr; + if (nsPtr->parentPtr != NULL) { + nsPtr = nsPtr->parentPtr; + } } + oPtr->command = TclCreateObjCommandInNs(interp, nameStr, + (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of @@ -684,26 +727,11 @@ AllocObject( tracePtr->nextPtr = NULL; tracePtr->refCount = 1; - /* - * Access the namespace command table directly when creating "my" to avoid - * a bottleneck in string manipulation. Another abstraction-buster. - */ - - cmdPtr = ckalloc(sizeof(Command)); - memset(cmdPtr, 0, sizeof(Command)); - cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; - cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", - &ignored); - cmdPtr->refCount = 1; - cmdPtr->objProc = PrivateObjectCmd; - cmdPtr->deleteProc = MyDeleted; - cmdPtr->objClientData = cmdPtr->deleteData = oPtr; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->nreProc = PrivateNRObjectCmd; - Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); - oPtr->myCommand = (Tcl_Command) cmdPtr; - + oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, + TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", + oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, + MyClassDeleted); return oPtr; } @@ -731,12 +759,12 @@ SquelchCachedName( /* * ---------------------------------------------------------------------- * - * MyDeleted -- + * MyDeleted, MyClassDeleted -- * - * This callback is triggered when the object's [my] command is deleted - * by any mechanism. It just marks the object as not having a [my] - * command, and so prevents cleanup of that when the object itself is - * deleted. + * These callbacks are triggered when the object's [my] or [myclass] + * commands are deleted by any mechanism. They just mark the object as + * not having a [my] command or [myclass] command, and so prevent cleanup + * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ @@ -750,29 +778,13 @@ MyDeleted( oPtr->myCommand = NULL; } - -/* - * ---------------------------------------------------------------------- - * - * SquelchedNsFirst -- - * - * This callback is triggered when the object's namespace is deleted by - * any mechanism. It deletes the object's public command if it has not - * already been deleted, so ensuring that destructors get run at an - * appropriate time. [Bug 2950259] - * - * ---------------------------------------------------------------------- - */ static void -SquelchedNsFirst( +MyClassDeleted( ClientData clientData) { Object *oPtr = clientData; - - if (oPtr->command) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } + oPtr->myclassCommand = NULL; } /* @@ -797,7 +809,6 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Foundation *fPtr = oPtr->fPtr; /* * If this is a rename and not a delete of the object, we just flush the @@ -810,142 +821,109 @@ ObjectRenamedTrace( } /* - * Oh dear, the object really is being deleted. Handle this by running the - * destructors and deleting the object's namespace, which in turn causes - * the real object structures to be deleted. - * - * Note that it is possible for the namespace to be deleted before the - * command. Because of that case, we must take care here to mark the - * command as being deleted so that if we return here we don't run into - * reentrancy problems. - * - * We also do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] - */ - - AddRef(oPtr); - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); - oPtr->command = NULL; - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - int result; - Tcl_InterpState state; - - oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); - } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); - } - } - - /* - * OK, the destructor's been run. Time to splat the class data (if any) - * and nuke the namespace (which triggers the final crushing of the object - * structure itself). - * - * The class of objects needs some special care; if it is deleted (and - * we're not killing the whole interpreter) we force the delete of the - * class of classes now as well. Due to the incestuous nature of those two - * classes, if one goes the other must too and yet the tangle can - * sometimes not go away automatically; we force it here. [Bug 2962664] - */ - - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); - } - - if (oPtr->classPtr != NULL) { - AddRef(oPtr->classPtr); - ReleaseClassContents(interp, oPtr); - } - - /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259] + * 2950259]. */ - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + if (!Deleted(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } - if (oPtr->classPtr) { - DelRef(oPtr->classPtr); - } - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - DelRef(oPtr); + oPtr->command = NULL; + TclOODecrRefCount(oPtr); + return; } /* * ---------------------------------------------------------------------- * - * ClearMixins, ClearSuperclasses -- + * TclOODeleteDescendants -- * - * Utility functions for correctly clearing the list of mixins or - * superclasses of a class. Will ckfree() the list storage. + * Delete all descendants of a particular class. * * ---------------------------------------------------------------------- */ -static void -ClearMixins( - Class *clsPtr) +void +TclOODeleteDescendants( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ { - int i; - Class *mixinPtr; + Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; + Object *instancePtr; - if (clsPtr->mixins.num == 0) { - return; - } + /* + * Squelch classes that this class has been mixed into. + */ - FOREACH(mixinPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); + if (clsPtr->mixinSubs.num > 0) { + while (clsPtr->mixinSubs.num > 0) { + mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; + /* This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + if (!Deleted(mixinSubclassPtr->thisPtr) + && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); + } + } + if (clsPtr->mixinSubs.size > 0) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.size = 0; } - ckfree(clsPtr->mixins.list); - clsPtr->mixins.list = NULL; - clsPtr->mixins.num = 0; -} -static void -ClearSuperclasses( - Class *clsPtr) -{ - int i; - Class *superPtr; + /* + * Squelch subclasses of this class. + */ - if (clsPtr->superclasses.num == 0) { - return; + if (clsPtr->subclasses.num > 0) { + while (clsPtr->subclasses.num > 0) { + subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) + && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { + Tcl_DeleteCommandFromToken(interp, + subclassPtr->thisPtr->command); + } + TclOORemoveFromSubclasses(subclassPtr, clsPtr); + } + } + if (clsPtr->subclasses.size > 0) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.size = 0; } - FOREACH(superPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, superPtr); + /* + * Squelch instances of this class (includes objects we're mixed into). + */ + + if (clsPtr->instances.num > 0) { + while (clsPtr->instances.num > 0) { + instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; + /* + * This condition also covers the case where instancePtr == oPtr + */ + + if (!Deleted(instancePtr) && !IsRoot(instancePtr) && + !(instancePtr->flags & DONT_DELETE)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + } + TclOORemoveFromInstances(instancePtr, clsPtr); + } + } + if (clsPtr->instances.size > 0) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.size = 0; } - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.list = NULL; - clsPtr->superclasses.num = 0; } /* * ---------------------------------------------------------------------- * - * ReleaseClassContents -- + * TclOOReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. @@ -953,16 +931,18 @@ ClearSuperclasses( * ---------------------------------------------------------------------- */ -static void -ReleaseClassContents( +void +TclOOReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { FOREACH_HASH_DECLS; int i; - Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; - Object *instancePtr; + Class *clsPtr = oPtr->classPtr, *tmpClsPtr; + Method *mPtr; Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; + PrivateVariableMapping *privateVariable; /* * Sanity check! @@ -975,121 +955,8 @@ ReleaseClassContents( } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); - } else { - Tcl_Panic("deleting class structure for non-deleted %s", - "general object"); - } - } - - /* - * Lock a number of dependent objects until we've stopped putting our - * fingers in them. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != NULL) { - AddRef(mixinSubclassPtr); - AddRef(mixinSubclassPtr->thisPtr); - } - } - FOREACH(subclassPtr, clsPtr->subclasses) { - if (subclassPtr != NULL && !IsRoot(subclassPtr)) { - AddRef(subclassPtr); - AddRef(subclassPtr->thisPtr); - } - } - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; j<instancePtr->mixins.num ; j++) { - Class *mixin = instancePtr->mixins.list[j]; - if (mixin == clsPtr) { - instancePtr->mixins.list[j] = NULL; - } - } - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); - } - } - } - - /* - * Squelch classes that this class has been mixed into. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); - } - ClearMixins(mixinSubclassPtr); - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); - } - if (clsPtr->mixinSubs.list != NULL) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - - /* - * Squelch subclasses of this class. - */ - - FOREACH(subclassPtr, clsPtr->subclasses) { - if (IsRoot(subclassPtr)) { - continue; - } - if (!Deleted(subclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); - } - ClearSuperclasses(subclassPtr); - DelRef(subclassPtr->thisPtr); - DelRef(subclassPtr); - } - if (clsPtr->subclasses.list != NULL) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - } - - /* - * Squelch instances of this class (includes objects we're mixed into). - */ - - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - /* - * Tcl_DeleteCommandFromToken() may have done to whole - * job for us. Roll back and check again. - */ - i--; - continue; - } - DelRef(instancePtr); } } - if (clsPtr->instances.list != NULL) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - - /* - * Special: We delete these after everything else. - */ - - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); - } /* * Squelch method implementation chain caches. @@ -1125,6 +992,7 @@ ReleaseClassContents( TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); + clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } @@ -1143,6 +1011,52 @@ ReleaseClassContents( ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } + + if (clsPtr->mixins.num) { + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->mixins.list); + clsPtr->mixins.list = NULL; + clsPtr->mixins.num = 0; + } + + if (clsPtr->superclasses.num > 0) { + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.num = 0; + clsPtr->superclasses.list = NULL; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(clsPtr->privateVariables.list); + } + + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } } /* @@ -1164,22 +1078,90 @@ ObjectNamespaceDeleted( * being deleted. */ { Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; - Class *clsPtr = oPtr->classPtr, *mixinPtr; + Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; + PrivateVariableMapping *privateVariable; + Tcl_Interp *interp = oPtr->fPtr->interp; int i; + if (Deleted(oPtr)) { + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this + * guard could be removed. + */ + + return; + } + + /* + * One rule for the teardown routines is that if an object is in the + * process of being deleted, nothing else may modify its bookeeping + * records. This is the flag that + */ + + oPtr->flags |= OBJECT_DELETED; + + /* Let the dominoes fall */ + if (oPtr->classPtr) { + TclOODeleteDescendants(interp, oPtr); + } + + /* + * We do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); + int result; + + Tcl_InterpState state; + oPtr->flags |= DESTRUCTOR_CALLED; + + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the commands that refer to the object at this point (if - * they still exist) because otherwise their references to the object - * point into freed memory, allowing crashes. + * Also delete the command that refers to the object at this point (if + * it still exists) because otherwise its pointer to the object + * points into freed memory. */ - if (oPtr->command) { + if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { + /* + * Something has already started the command deletion process. We can + * go ahead and clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + + if (oPtr->myclassCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); + } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } @@ -1189,17 +1171,20 @@ ObjectNamespaceDeleted( * methods on the object. */ - if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - } + /* + * TODO: Should this be protected with a * !IsRoot() condition? + */ - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { + TclOORemoveFromInstances(oPtr, oPtr->selfCls); + + if (oPtr->mixins.num > 0) { + FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } + if (oPtr->mixins.list != NULL) { + ckfree(oPtr->mixins.list); } - } - if (i) { - ckfree(oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { @@ -1224,6 +1209,14 @@ ObjectNamespaceDeleted( ckfree(oPtr->variables.list); } + FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(oPtr->privateVariables.list); + } + if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } @@ -1243,69 +1236,63 @@ ObjectNamespaceDeleted( } /* - * If this was a class, there's additional deletion work to do. + * Because an object can be a class that is an instance of itself, the + * class object's class structure should only be cleaned after most of + * the cleanup on the object is done. + * + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (clsPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - - if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - metadataTypePtr->deleteProc(value); - } - Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - ckfree(clsPtr->filters.list); - clsPtr->filters.num = 0; - } - - ClearMixins(clsPtr); - - ClearSuperclasses(clsPtr); - - if (clsPtr->subclasses.list) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.num = 0; - } - if (clsPtr->instances.list) { - ckfree(clsPtr->instances.list); - clsPtr->instances.num = 0; - } - if (clsPtr->mixinSubs.list) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.num = 0; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); - - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - ckfree(clsPtr->variables.list); - } + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } - DelRef(clsPtr); + if (oPtr->classPtr != NULL) { + TclOOReleaseClassContents(interp, oPtr); } /* * Delete the object structure itself. */ - DelRef(oPtr); + TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); + oPtr->namespacePtr = NULL; + TclOODecrRefCount(oPtr->selfCls->thisPtr); + oPtr->selfCls = NULL; + TclOODecrRefCount(oPtr); + return; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODecrRefCount -- + * + * Decrement the refcount of an object and deallocate storage then object + * is no longer referenced. Returns 1 if storage was deallocated, and 0 + * otherwise. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODecrRefCount( + Object *oPtr) +{ + if (oPtr->refCount-- <= 1) { + + if (oPtr->classPtr != NULL) { + ckfree(oPtr->classPtr); + } + ckfree(oPtr); + return 1; + } + return 0; } /* @@ -1319,36 +1306,24 @@ ObjectNamespaceDeleted( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { - int i; + int i, res = 0; Object *instPtr; FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { - goto removeInstance; - } - } - return; - - removeInstance: - if (Deleted(clsPtr->thisPtr)) { - if (!IsRootClass(clsPtr)) { - DelRef(clsPtr->instances.list[i]); - } - clsPtr->instances.list[i] = NULL; - } else { - clsPtr->instances.num--; - if (i < clsPtr->instances.num) { - clsPtr->instances.list[i] = - clsPtr->instances.list[clsPtr->instances.num]; + RemoveItem(Object, clsPtr->instances, i); + TclOODecrRefCount(oPtr); + res++; + break; } - clsPtr->instances.list[clsPtr->instances.num] = NULL; } + return res; } /* @@ -1369,9 +1344,6 @@ TclOOAddToInstances( * assumed that the class is not already * present as an instance in the class. */ { - if (Deleted(clsPtr->thisPtr)) { - return; - } if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { @@ -1382,6 +1354,42 @@ TclOOAddToInstances( } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; + AddRef(oPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOORemoveFromMixins -- + * + * Utility function to remove a class from the list of mixins within an + * object. + * + * ---------------------------------------------------------------------- + */ + +int +TclOORemoveFromMixins( + Class *mixinPtr, /* The mixin to remove. */ + Object *oPtr) /* The object (possibly) containing the + * reference to the mixin. */ +{ + int i, res = 0; + Class *mixPtr; + + FOREACH(mixPtr, oPtr->mixins) { + if (mixinPtr == mixPtr) { + RemoveItem(Class, oPtr->mixins, i); + TclOODecrRefCount(mixPtr->thisPtr); + res++; + break; + } + } + if (oPtr->mixins.num == 0) { + ckfree(oPtr->mixins.list); + oPtr->mixins.list = NULL; + } + return res; } /* @@ -1390,36 +1398,28 @@ TclOOAddToInstances( * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within - * another class. + * another class. Returns the number of removals performed. * * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->subclasses.num--; - if (i < superPtr->subclasses.num) { - superPtr->subclasses.list[i] = - superPtr->subclasses.list[superPtr->subclasses.num]; + RemoveItem(Class, superPtr->subclasses, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } + return res; } /* @@ -1446,13 +1446,14 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1466,31 +1467,24 @@ TclOOAddToSubclasses( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + RemoveItem(Class, superPtr->mixinSubs, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; + break; } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } + return res; } /* @@ -1524,44 +1518,26 @@ TclOOAddToMixinSubs( } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* * ---------------------------------------------------------------------- * - * AllocClass -- + * TclOOAllocClass -- * - * Allocate a basic class. Does not splice the class object into its - * class's instance list. + * Allocate a basic class. Does not add class to its class's instance + * list. * * ---------------------------------------------------------------------- */ -static Class * -AllocClass( - Tcl_Interp *interp, /* Interpreter within which to allocate the - * class. */ - Object *useThisObj) /* Object that is to act as the class - * representation, or NULL if a new object - * (with automatic name) is to be used. */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = ckalloc(sizeof(Class)); - - /* - * Make an object if we haven't been given one. - */ - - memset(clsPtr, 0, sizeof(Class)); - if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL); - } else { - clsPtr->thisPtr = useThisObj; - } - - /* - * Configure the namespace path for the class's object. - */ if (fPtr->helpersNs != NULL) { Tcl_Namespace *path[2]; @@ -1573,13 +1549,26 @@ AllocClass( TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, &fPtr->ooNs); } +} + +Class * +TclOOAllocClass( + Tcl_Interp *interp, /* Interpreter within which to allocate the + * class. */ + Object *useThisObj) /* Object that is to act as the class + * representation. */ +{ + Foundation *fPtr = GetFoundation(interp); + Class *clsPtr = ckalloc(sizeof(Class)); + + memset(clsPtr, 0, sizeof(Class)); + clsPtr->thisPtr = useThisObj; /* - * Class objects inherit from the class of classes unless they inherit - * from some subclass of it. Enforce this right now. + * Configure the namespace path for the class's object. */ - clsPtr->thisPtr->selfCls = fPtr->classCls; + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1589,6 +1578,7 @@ AllocClass( clsPtr->superclasses.num = 1; clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; + AddRef(fPtr->objectCls->thisPtr); /* * Finish connecting the class structure to the object structure. @@ -1601,7 +1591,6 @@ AllocClass( * fields. */ - clsPtr->refCount = 1; Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } @@ -1615,7 +1604,6 @@ AllocClass( * * ---------------------------------------------------------------------- */ - Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ @@ -1632,59 +1620,22 @@ Tcl_NewObjectInstance( * constructor. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); Object *oPtr; + ClientData clientData[4]; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return NULL; } /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } else { - oPtr->classPtr = NULL; - } - - /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). + * Run constructors, except when objc < 0, which is a special flag case + * used for object cloning only. */ if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { int isRoot, result; @@ -1695,7 +1646,7 @@ Tcl_NewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); @@ -1706,36 +1657,15 @@ Tcl_NewObjectInstance( TclResetRewriteEnsemble(interp, 1); } - /* - * It's an error if the object was whacked in the constructor. - * Force this if it isn't already an error (don't want to lose - * errors by accident...) [Bug 2903011] - */ + clientData[0] = contextPtr; + clientData[1] = oPtr; + clientData[2] = state; + clientData[3] = &oPtr; - if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); - result = TCL_ERROR; - } - TclOODeleteContext(contextPtr); + result = FinalizeAlloc(clientData, interp, result); if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - - /* - * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] Also take care to make sure that we have - * the name of the command before we delete it. [Bug - * 9dd1bd7a74] - */ - - if (!Deleted(oPtr)) { - (void) TclOOObjectName(interp, oPtr); - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } return NULL; } - Tcl_RestoreInterpState(interp, state); } } @@ -1760,52 +1690,16 @@ TclNRNewObjectInstance( * successful allocation. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return TCL_ERROR; } /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } - - /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -1814,7 +1708,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -1825,7 +1719,7 @@ TclNRNewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { @@ -1836,13 +1730,85 @@ TclNRNewObjectInstance( * Fire off the constructors non-recursively. */ - AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } + +Object * +TclNewObjectInstanceCommon( + Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr) +{ + Tcl_HashEntry *hPtr; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + const char *simpleName = NULL; + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + int isNew; + + if (nameStr) { + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); + + /* + * Disallow creation of an object over an existing command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + + /* + * We could make a hash entry! Don't actually want to do that here so + * nuke it immediately because we'll create it properly soon. + */ + + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); + oPtr->selfCls = classPtr; + AddRef(classPtr->thisPtr); + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the + * TclOOAllocClass function splices the structure into the object, so + * we don't have to. Once that's done, we need to repatch the object + * to have the right class since TclOOAllocClass interferes with that. + */ + + TclOOAllocClass(interp, oPtr); + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + return oPtr; +} + + + static int FinalizeAlloc( ClientData data[], @@ -1855,9 +1821,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * It's an error if the object was whacked in the constructor. Force this - * if it isn't already an error (don't want to lose errors by accident...) - * [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1866,7 +1831,6 @@ FinalizeAlloc( Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } - TclOODeleteContext(contextPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1880,12 +1844,22 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - DelRef(oPtr); + + /* + * This decrements the refcount of oPtr. + */ + + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - DelRef(oPtr); + + /* + * This decrements the refcount of oPtr. + */ + + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1914,6 +1888,7 @@ Tcl_CopyObjectInstance( Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + PrivateVariableMapping *privateVariable; int i, result; /* @@ -1955,16 +1930,22 @@ Tcl_CopyObjectInstance( * Copy the object's mixin references to the new object. */ - FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr && mixinPtr != o2Ptr->selfCls) { - TclOORemoveFromInstances(o2Ptr, mixinPtr); + if (o2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { + TclOORemoveFromInstances(o2Ptr, mixinPtr); + } + TclOODecrRefCount(mixinPtr->thisPtr); } + ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } + /* For the reference just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* @@ -1977,7 +1958,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the object's variable resolution list to the new object. + * Copy the object's variable resolution lists to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); @@ -1985,6 +1966,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is @@ -1994,7 +1982,6 @@ Tcl_CopyObjectInstance( o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); - /* * Copy the object's metadata. */ @@ -2043,6 +2030,7 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, @@ -2056,6 +2044,11 @@ Tcl_CopyObjectInstance( cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); + + /* For the new item in cls2Ptr->superclasses that memcpy just + * created + */ + AddRef(superPtr->thisPtr); } /* @@ -2068,7 +2061,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the source class's variable resolution list. + * Copy the source class's variable resolution lists. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); @@ -2076,20 +2069,30 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ - FOREACH(mixinPtr, cls2Ptr->mixins) { - TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); - } if (cls2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); + /* For the copy just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* @@ -2145,7 +2148,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2433,9 +2437,9 @@ Tcl_ObjectSetMetadata( /* * ---------------------------------------------------------------------- * - * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- * - * Main entry point for object invokations. The Public* and Private* + * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. @@ -2443,8 +2447,8 @@ Tcl_ObjectSetMetadata( * ---------------------------------------------------------------------- */ -static int -PublicObjectCmd( +int +TclOOPublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2464,8 +2468,8 @@ PublicNRObjectCmd( NULL); } -static int -PrivateObjectCmd( +int +TclOOPrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2518,10 +2522,47 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * + * TclOOMyClassObjCmd, MyClassNRObjCmd -- + * + * Special trap door to allow an object to delegate simply to its class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOMyClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); +} + +static int +MyClassNRObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, + NULL); +} + +/* + * ---------------------------------------------------------------------- + * * TclOOObjectCmdCore, FinalizeObjectCall -- * - * Main function for object invokations. Does call chain creation, - * management and invokation. The function FinalizeObjectCall exists to + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- @@ -2533,7 +2574,7 @@ TclOOObjectCmdCore( Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invokation through the + int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with @@ -2542,6 +2583,9 @@ TclOOObjectCmdCore( { CallContext *contextPtr; Tcl_Obj *methodNamePtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2556,6 +2600,24 @@ TclOOObjectCmdCore( } /* + * Determine if we're in a context that can see the extra, private methods + * in this class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContextPtr = framePtr->clientData; + Method *callerMethodPtr = + callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; + + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; + } + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; + } + } + + /* * Give plugged in code a chance to remap the method name. */ @@ -2582,7 +2644,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2599,7 +2662,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" @@ -2722,7 +2786,7 @@ Tcl_ObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2791,7 +2855,7 @@ TclNRObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2849,9 +2913,9 @@ Tcl_GetObjectFromObj( if (cmdPtr == NULL) { goto notAnObject; } - if (cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr->objProc != TclOOPublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { goto notAnObject; } } @@ -3006,7 +3070,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted(object) ? 1 : 0; + return ((Object *)object)->command == NULL; } Tcl_Object diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 265ba88..f1bb320 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -58,12 +58,12 @@ declare 10 { } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 13 { @@ -126,6 +126,9 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } +declare 29 { + int Tcl_MethodIsPrivate(Tcl_Method method) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOO.h b/generic/tclOO.h index 32afbf1..9c1dd1e 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.1.0" +#define TCLOO_VERSION "1.2.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" @@ -99,6 +99,15 @@ typedef struct { */ #define TCL_OO_METHOD_VERSION_CURRENT 1 + +/* + * Visibility constants for the flags parameter to Tcl_NewMethod and + * Tcl_NewInstanceMethod. + */ + +#define TCL_OO_METHOD_PUBLIC 1 +#define TCL_OO_METHOD_UNEXPORTED 0 +#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b2c06a7..13c98f4 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -83,7 +83,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke; + Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -94,6 +94,17 @@ TclOO_Class_Constructor( } /* + * Make the class definition delegate. This is special; it doesn't reenter + * here (and the class definition delegate doesn't run any constructors). + */ + + nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); + Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, + TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_DecrRefCount(nameObj); + + /* * Delegate to [oo::define] to do the work. */ @@ -111,7 +122,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, NULL, NULL, NULL); + invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -128,12 +139,27 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Object *oPtr = data[1]; + Tcl_InterpState saved; + int code; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[1] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + saved = Tcl_SaveInterpState(interp, result); + code = Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); ckfree(invoke); - return result; + if (code != TCL_OK) { + Tcl_DiscardInterpState(saved); + return code; + } + return Tcl_RestoreInterpState(interp, saved); } /* @@ -347,7 +373,8 @@ TclOO_Object_Destroy( } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, + NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; @@ -499,9 +526,12 @@ TclOO_Object_Unknown( Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; + Object *callerObj = NULL; + Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; /* @@ -516,10 +546,31 @@ TclOO_Object_Unknown( } /* + * Determine if the calling context should know about extra private + * methods, and if so, which. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + + if (mPtr->declaringObjectPtr) { + if (oPtr == mPtr->declaringObjectPtr) { + callerObj = mPtr->declaringObjectPtr; + } + } else { + if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { + callerCls = mPtr->declaringClassPtr; + } + } + } + + /* * Get the list of methods that we want to know about. */ - numMethodNames = TclOOGetSortedMethodList(oPtr, + numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); /* @@ -684,6 +735,7 @@ TclOO_Object_VarName( { Var *varPtr, *aryVar; Tcl_Obj *varNamePtr, *argPtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -709,6 +761,58 @@ TclOO_Object_VarName( Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); + /* + * Private method handling. [TIP 500] + * + * If we're in a context that can see some private methods of an + * object, we may need to precede a variable name with its prefix. + * This is a little tricky as we need to check through the inheritance + * hierarchy when the method was declared by a class to see if the + * current object is an instance of that class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + PrivateVariableMapping *pvPtr; + int i; + + if (mPtr->declaringObjectPtr == oPtr) { + FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } else if (mPtr->declaringClassPtr && + mPtr->declaringClassPtr->privateVariables.num) { + Class *clsPtr = mPtr->declaringClassPtr; + int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls); + Class *mixinCls; + + if (!isInstance) { + FOREACH(mixinCls, oPtr->mixins) { + if (TclOOIsReachable(clsPtr, mixinCls)) { + isInstance = 1; + break; + } + } + } + if (isInstance) { + FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } + } + } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); Tcl_AppendToObj(varNamePtr, "::", 2); Tcl_AppendObjToObj(varNamePtr, argPtr); @@ -729,26 +833,16 @@ TclOO_Object_VarName( varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); /* * WARNING! This code pokes inside the implementation of hash tables! */ - hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr, - &search); - while (hPtr != NULL) { - if (varPtr == Tcl_GetHashValue(hPtr)) { - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - break; - } - hPtr = Tcl_NextHashEntry(&search); - } + Tcl_AppendToObj(varNamePtr, "(", -1); + Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) + varPtr)->entry.key.objPtr); + Tcl_AppendToObj(varNamePtr, ")", -1); } else { Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); } @@ -1206,22 +1300,10 @@ TclOOCopyObjectCmd( o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { const char *name, *namespaceName; - Tcl_DString buffer; name = TclGetString(objv[2]); - Tcl_DStringInit(&buffer); if (name[0] == '\0') { name = NULL; - } else if (name[0]!=':' || name[1]!=':') { - Interp *iPtr = (Interp *) interp; - - if (iPtr->varFramePtr != NULL) { - Tcl_DStringAppend(&buffer, - iPtr->varFramePtr->nsPtr->fullName, -1); - } - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, name, -1); - name = Tcl_DStringValue(&buffer); } /* @@ -1243,7 +1325,6 @@ TclOOCopyObjectCmd( } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); - Tcl_DStringFree(&buffer); } if (o2Ptr == NULL) { diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 3e4f561..50a9c80 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -15,6 +15,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" +#include <assert.h> /* * Structure containing a CallContext and any other values needed only during @@ -46,6 +47,28 @@ struct ChainBuilder { !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) /* + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for + * Itcl's special type of private. + */ + +#define IS_PUBLIC(mPtr) \ + (((mPtr)->flags & PUBLIC_METHOD) != 0) +#define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & SCOPE_FLAGS) == 0) +#define IS_ITCLPRIVATE(mPtr) \ + (((mPtr)->flags & PRIVATE_METHOD) != 0) +#define IS_PRIVATE(mPtr) \ + (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) +#define WANT_PUBLIC(flags) \ + (((flags) & PUBLIC_METHOD) != 0) +#define WANT_UNEXPORTED(flags) \ + (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) +#define WANT_ITCLPRIVATE(flags) \ + (((flags) & PRIVATE_METHOD) != 0) +#define WANT_PRIVATE(flags) \ + (((flags) & TRUE_PRIVATE_METHOD) != 0) + +/* * Function declarations for things defined in this file. */ @@ -59,12 +82,26 @@ static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); -static inline void AddSimpleChainToCallContext(Object *const oPtr, +static inline int AddInstancePrivateToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, int flags); +static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, + Method *mPtr, Tcl_HashTable *namesPtr); +static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr); +static inline int AddSimpleChainToCallContext(Object *const oPtr, + Class *const contextCls, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static int AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddSimpleClassChainToCallContext(Class *classPtr, +static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, @@ -77,6 +114,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, + const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* @@ -90,6 +129,7 @@ static const Tcl_ObjType methodNameType = { NULL, NULL }; + /* * ---------------------------------------------------------------------- @@ -110,7 +150,12 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + + TclOODecrRefCount(oPtr); } } @@ -179,11 +224,12 @@ StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { + Tcl_ObjIntRep ir; + callPtr->refCount++; TclGetString(objPtr); - TclFreeIntRep(objPtr); - objPtr->typePtr = &methodNameType; - objPtr->internalRep.twoPtrValue.ptr1 = callPtr; + ir.twoPtrValue.ptr1 = callPtr; + Tcl_StoreIntRep(objPtr, &methodNameType, &ir); } void @@ -210,21 +256,16 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; - - dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; - callPtr->refCount++; + StashCallChain(dstPtr, + Tcl_FetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; - - TclOODeleteChain(callPtr); - objPtr->typePtr = NULL; + TclOODeleteChain( + Tcl_FetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* @@ -233,7 +274,7 @@ FreeMethodNameRep( * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the - * invokation of a step along the chain can cause further steps along the + * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * @@ -361,6 +402,14 @@ FinalizeMethodRefs( int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ + Object *contextObj, /* From what context object we are inquiring. + * NULL when the context shouldn't see + * object-level private methods. Note that + * flags can override this. */ + Class *contextCls, /* From what context class we are inquiring. + * NULL when the context shouldn't see + * class-level private methods. Note that + * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of @@ -373,12 +422,10 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; - int isWantedIn; - void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -395,18 +442,13 @@ TclOOGetSortedMethodList( if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - int isNew; - - if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + if (IS_PRIVATE(mPtr)) { continue; } - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = ((!(flags & PUBLIC_METHOD) - || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); - isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { + continue; } + AddStandardMethodName(flags, namePtr, mPtr, &names); } } @@ -414,84 +456,46 @@ TclOOGetSortedMethodList( * Process method names due to private methods on the object's class. */ - if (flags & PRIVATE_METHOD) { + if (WANT_UNEXPORTED(flags)) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (mPtr->flags & PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = IN_LIST; - if (mPtr->typePtr == NULL) { - isWantedIn |= NO_IMPLEMENTATION; - } - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } else if (mPtr->typePtr != NULL) { - isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); - if (isWantedIn & NO_IMPLEMENTATION) { - isWantedIn &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } - } + if (IS_UNEXPORTED(mPtr)) { + AddStandardMethodName(flags, namePtr, mPtr, &names); } } } /* + * Process method names due to private methods on the context's object or + * class. Which must be correct if either are not NULL. + */ + + if (contextObj && contextObj->methodsPtr) { + AddPrivateMethodNames(contextObj->methodsPtr, &names); + } + if (contextCls) { + AddPrivateMethodNames(&contextCls->classMethods, &names); + } + + /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names, + AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, &examinedClasses); } - Tcl_DeleteHashTable(&examinedClasses); - /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). */ - i = 0; - if (names.numEntries != 0) { - const char **strings; - - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ - - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); - } - } - + Tcl_DeleteHashTable(&examinedClasses); + numStrings = SortMethodNames(&names, flags, stringsPtr); Tcl_DeleteHashTable(&names); - return i; + return numStrings; } int @@ -508,10 +512,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - FOREACH_HASH_DECLS; - int i; - Tcl_Obj *namePtr; - void *isWanted; + int numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -524,50 +525,100 @@ TclOOGetSortedClassMethodList( Tcl_DeleteHashTable(&examinedClasses); /* + * Process private method names if we should. [TIP 500] + */ + + if (WANT_PRIVATE(flags)) { + AddPrivateMethodNames(&clsPtr->classMethods, &names); + flags &= ~TRUE_PRIVATE_METHOD; + } + + /* + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). + */ + + numStrings = SortMethodNames(&names, flags, stringsPtr); + Tcl_DeleteHashTable(&names); + return numStrings; +} + +/* + * ---------------------------------------------------------------------- + * + * SortMethodNames -- + * + * Shared helper for TclOOGetSortedMethodList etc. that knows the method + * sorting rules. + * + * Returns: + * The length of the sorted list. + * + * ---------------------------------------------------------------------- + */ + +static int +SortMethodNames( + Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains + * whether the names are wanted and under what + * circumstances. */ + int flags, /* Whether we are looking for unexported + * methods. Full private methods are handled + * on insertion to the table. */ + const char ***stringsPtr) /* Where to store the sorted list of strings + * that we produce. ckalloced() */ +{ + const char **strings; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + void *isWanted; + int i = 0; + + /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ - i = 0; - if (names.numEntries != 0) { - const char **strings; + if (namesPtr->numEntries == 0) { + *stringsPtr = NULL; + return 0; + } - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ + /* + * We need to build the list of methods to sort. We will be using qsort() + * for this, because it is very unlikely that the list will be heavily + * sorted when it is long enough to matter. + */ - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); + strings = ckalloc(sizeof(char *) * namesPtr->numEntries); + FOREACH_HASH(namePtr, isWanted, namesPtr) { + if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; } + strings[i++] = TclGetString(namePtr); } + } - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. We don't sort unless there's at least + * two method names. + */ - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); + if (i > 0) { + if (i > 1) { + qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); } + *stringsPtr = strings; + } else { + ckfree(strings); + *stringsPtr = NULL; } - - Tcl_DeleteHashTable(&names); return i; } -/* Comparator for GetSortedMethodList */ +/* Comparator for SortMethodNames */ static int CmpStr( const void *ptr1, @@ -576,7 +627,7 @@ CmpStr( const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; - return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1); + return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); } /* @@ -609,6 +660,8 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { + int i; + /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. @@ -639,7 +692,6 @@ AddClassMethodNames( if (clsPtr->mixins.num != 0) { Class *mixinPtr; - int i; FOREACH(mixinPtr, clsPtr->mixins) { if (mixinPtr != clsPtr) { @@ -650,20 +702,7 @@ AddClassMethodNames( } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - if (isNew) { - int isWanted = (!(flags & PUBLIC_METHOD) - || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; - - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } + AddStandardMethodName(flags, namePtr, mPtr, namesPtr); } if (clsPtr->superclasses.num != 1) { @@ -673,7 +712,6 @@ AddClassMethodNames( } if (clsPtr->superclasses.num != 0) { Class *superPtr; - int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr, @@ -685,19 +723,121 @@ AddClassMethodNames( /* * ---------------------------------------------------------------------- * + * AddPrivateMethodNames, AddStandardMethodName -- + * + * Factored-out helpers for the sorted name list production functions. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddPrivateMethodNames( + Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr) +{ + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; + + FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { + if (IS_PRIVATE(mPtr)) { + int isNew; + + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } +} + +static inline void +AddStandardMethodName( + int flags, + Tcl_Obj *namePtr, + Method *mPtr, + Tcl_HashTable *namesPtr) +{ + if (!IS_PRIVATE(mPtr)) { + int isNew; + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + + if (isNew) { + int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) + ? IN_LIST : 0; + + isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } + } +} + +#undef IN_LIST +#undef NO_IMPLEMENTATION + +/* + * ---------------------------------------------------------------------- + * + * AddInstancePrivateToCallContext -- + * + * Add private methods from the instance. Called when the calling Tcl + * context is a TclOO method declared by an object that is the same as + * the current object. Returns true iff a private method was actually + * found and added to the call chain (as this suppresses caching). + * + * ---------------------------------------------------------------------- + */ + +static inline int +AddInstancePrivateToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + int flags) /* What sort of call chain are we building. */ +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + int donePrivate = 0; + + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + if (hPtr != NULL) { + mPtr = Tcl_GetHashValue(hPtr); + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); + donePrivate = 1; + } + } + } + return donePrivate; +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleChainToCallContext -- * * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this - * function. + * function. Returns true if a private method was one of those found. * * ---------------------------------------------------------------------- */ -static inline void +static inline int AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -711,44 +851,62 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0, blockedUnexported = 0; + Tcl_HashEntry *hPtr; + Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, - (char *) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { - Method *mPtr = Tcl_GetHashValue(hPtr); - - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return; + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + if (WANT_PUBLIC(flags)) { + if (!IS_PUBLIC(mPtr)) { + blockedUnexported = 1; + } else { + flags |= DEFINITE_PUBLIC; + } } else { - flags |= DEFINITE_PUBLIC; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { - Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext( + mixinPtr, contextCls, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + } + foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, + methodNameObj, cbPtr, doneFilters, + flags | TRAVERSED_MIXIN, filterDecl); } - if (oPtr->methodsPtr) { + if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl, flags); + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } } - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, + contextCls, methodNameObj, cbPtr, doneFilters, flags, + filterDecl); + } + if (!blockedUnexported) { + foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + return foundPrivate; } /* @@ -811,8 +969,8 @@ AddMethodToCallChain( * should be sufficient for [incr Tcl] support though. */ - if (!(callPtr->flags & PRIVATE_METHOD) - && (mPtr->flags & PRIVATE_METHOD) + if (!WANT_UNEXPORTED(callPtr->flags) + && IS_UNEXPORTED(mPtr) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; @@ -830,7 +988,7 @@ AddMethodToCallChain( * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of - * method invokations in the call chain; it just rearranges them. + * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; @@ -853,7 +1011,7 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1)); + ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { @@ -900,6 +1058,7 @@ InitCallChain( * ---------------------------------------------------------------------- * * IsStillValid -- + * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: @@ -935,7 +1094,7 @@ IsStillValid( * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invokation. + * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- @@ -951,6 +1110,12 @@ TclOOGetCallContext( * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Object *contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ @@ -958,7 +1123,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters; + int i, count, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -998,15 +1163,16 @@ TclOOGetCallContext( * the object, and in the class). */ - const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const Tcl_ObjIntRep *irPtr; + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); - if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(cacheInThisObj, &methodNameType))) { + callPtr = irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - FreeMethodNameRep(cacheInThisObj); + Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); } if (oPtr->flags & USE_CLASS_CACHE) { @@ -1050,10 +1216,11 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1082,10 +1249,10 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, - BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); @@ -1100,9 +1267,15 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + if (oPtr == contextObj) { + donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, + &cb, flags); + donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); + } + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1120,17 +1293,18 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters) { + } else if (doFilters && !donePrivate) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { @@ -1171,6 +1345,11 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; @@ -1231,8 +1410,7 @@ TclOOGetStereotypeCallChain( hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = - ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { @@ -1276,9 +1454,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, + NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1287,10 +1466,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1370,9 +1549,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1399,6 +1578,87 @@ AddClassFiltersToCallContext( /* * ---------------------------------------------------------------------- * + * AddPrivatesFromClassChainToCallContext -- + * + * Helper for AddSimpleChainToCallContext that is used to find private + * methds and add them to the call chain. Returns true when a private + * method is found and added. [TIP 500] + * + * ---------------------------------------------------------------------- + */ + +static int +AddPrivatesFromClassChainToCallContext( + Class *classPtr, /* Class to add the call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + Tcl_HashTable *const doneFilters, + /* Where to record what call chain entries + * have been processed. */ + int flags, /* What sort of call chain are we building. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + * + * Note that mixins must be processed before the main class hierarchy. + * [Bug 1998221] + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl)) { + return 1; + } + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + (char *) methodName); + + if (hPtr != NULL) { + register Method *mPtr = Tcl_GetHashValue(hPtr); + + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + return 1; + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags, filterDecl)) { + return 1; + } + } + case 0: + return 0; + } +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleClassChainToCallContext -- * * Construct a call-chain from a class hierarchy. @@ -1406,7 +1666,7 @@ AddClassFiltersToCallContext( * ---------------------------------------------------------------------- */ -static void +static int AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Tcl_Obj *const methodNameObj, @@ -1422,7 +1682,7 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, privateDanger = 0; Class *superPtr; /* @@ -1435,14 +1695,14 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, + filterDecl); } if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, filterDecl, flags); - } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, filterDecl, flags); @@ -1450,21 +1710,26 @@ AddSimpleClassChainToCallContext( Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); + if (classPtr->flags & HAS_PRIVATE_METHODS) { + privateDanger |= 1; + } if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (mPtr->flags & PUBLIC_METHOD) { + if (!IS_PRIVATE(mPtr)) { + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (!IS_PUBLIC(mPtr)) { + return privateDanger; + } flags |= DEFINITE_PUBLIC; } else { - return; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } @@ -1474,11 +1739,11 @@ AddSimpleClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); } case 0: - return; + return privateDanger; } } @@ -1498,7 +1763,7 @@ TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; @@ -1507,17 +1772,19 @@ TclOORenderCallChain( * Allocate the literals (potentially) used in our description. */ - filterLiteral = Tcl_NewStringObj("filter", -1); + TclNewLiteralStringObj(filterLiteral, "filter"); Tcl_IncrRefCount(filterLiteral); - methodLiteral = Tcl_NewStringObj("method", -1); + TclNewLiteralStringObj(methodLiteral, "method"); Tcl_IncrRefCount(methodLiteral); - objectLiteral = Tcl_NewStringObj("object", -1); + TclNewLiteralStringObj(objectLiteral, "object"); Tcl_IncrRefCount(objectLiteral); + TclNewLiteralStringObj(privateLiteral, "private"); + Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invokation ("method" is + * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of @@ -1530,16 +1797,15 @@ TclOORenderCallChain( for (i=0 ; i<callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; - descObjs[0] = miPtr->isFilter - ? filterLiteral - : callPtr->flags & OO_UNKNOWN_METHOD - ? fPtr->unknownMethodNameObj - : methodLiteral; - descObjs[1] = callPtr->flags & CONSTRUCTOR - ? fPtr->constructorName - : callPtr->flags & DESTRUCTOR - ? fPtr->destructorName - : miPtr->mPtr->namePtr; + descObjs[0] = + miPtr->isFilter ? filterLiteral : + callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : + IS_PRIVATE(miPtr->mPtr) ? privateLiteral : + methodLiteral; + descObjs[1] = + callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : + callPtr->flags & DESTRUCTOR ? fPtr->destructorName : + miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) @@ -1557,6 +1823,7 @@ TclOORenderCallChain( Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); + Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9fd62ec..928d07e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -59,11 +59,11 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int isPublic, const Tcl_MethodType *typePtr, + int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ @@ -116,6 +116,8 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, /* 28 */ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); +/* 29 */ +TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -136,8 +138,8 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ @@ -154,6 +156,7 @@ typedef struct TclOOStubs { void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ + int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -226,6 +229,8 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ +#define Tcl_MethodIsPrivate \ + (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 47b34bb..3e8dd11 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -17,6 +17,12 @@ #include "tclOOInt.h" /* + * The actual value used to mark private declaration frames. + */ + +#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) + +/* * The maximum length of fully-qualified object name to use in an errorinfo * message. Longer than this will be curtailed. */ @@ -31,14 +37,17 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; + const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} + setter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ + resolver, NULL, NULL}} /* * Forward declarations. @@ -103,26 +112,59 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int ResolveClass(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), + SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; + +/* + * How to build the in-namespace name of a private variable. This is a pattern + * used with Tcl_ObjPrintf(). + */ + +#define PRIVATE_VARIABLE_PATTERN "%d : %s" + +/* + * ---------------------------------------------------------------------- + * + * IsPrivateDefine -- + * + * Extracts whether the current context is handling private definitions. + * + * ---------------------------------------------------------------------- + */ + +static inline int +IsPrivateDefine( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (!iPtr->varFramePtr) { + return 0; + } + return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; +} /* * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- + * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in @@ -167,6 +209,7 @@ BumpGlobalEpoch( * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * @@ -189,6 +232,7 @@ RecomputeClassCacheFlag( * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- @@ -247,6 +291,7 @@ TclOOObjectSetFilters( * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- @@ -309,6 +354,7 @@ TclOOClassSetFilters( * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- @@ -326,9 +372,8 @@ TclOOObjectSetMixins( if (numMixins == 0) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; @@ -340,6 +385,7 @@ TclOOObjectSetMixins( if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } + TclOODecrRefCount(mixinPtr->thisPtr); } oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); @@ -352,6 +398,8 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } } @@ -362,6 +410,7 @@ TclOOObjectSetMixins( * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- @@ -381,6 +430,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; @@ -389,6 +439,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); @@ -399,6 +450,8 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } BumpGlobalEpoch(interp, classPtr); @@ -407,7 +460,125 @@ TclOOClassSetMixins( /* * ---------------------------------------------------------------------- * + * InstallStandardVariableMapping, InstallPrivateVariableMapping -- + * + * Helpers for installing standard and private variable maps. + * + * ---------------------------------------------------------------------- + */ +static inline void +InstallStandardVariableMapping( + VariableNameList *vnlPtr, + int varc, + Tcl_Obj *const *varv) +{ + Tcl_Obj *variableObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, *vnlPtr) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(vnlPtr->list); + } else if (i) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + } else { + vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + vnlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + vnlPtr->list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + vnlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static inline void +InstallPrivateVariableMapping( + PrivateVariableList *pvlPtr, + int varc, + Tcl_Obj *const *varv, + int creationEpoch) +{ + PrivateVariableMapping *privatePtr; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH_STRUCT(privatePtr, *pvlPtr) { + Tcl_DecrRefCount(privatePtr->variableObj); + Tcl_DecrRefCount(privatePtr->fullNameObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(pvlPtr->list); + } else if (i) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * varc); + } else { + pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc); + } + } + + pvlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + privatePtr = &(pvlPtr->list[n++]); + privatePtr->variableObj = varv[i]; + privatePtr->fullNameObj = Tcl_ObjPrintf( + PRIVATE_VARIABLE_PATTERN, + creationEpoch, Tcl_GetString(varv[i])); + Tcl_IncrRefCount(privatePtr->fullNameObj); + } else { + Tcl_DecrRefCount(varv[i]); + } + } + pvlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +/* + * ---------------------------------------------------------------------- + * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- @@ -497,6 +668,7 @@ RenameDeleteMethod( * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- + * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique @@ -528,7 +700,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); + soughtStr = TclGetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -575,6 +747,7 @@ TclOOUnknownDefinition( * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * @@ -588,7 +761,7 @@ FindCommand( Tcl_Namespace *const namespacePtr) { int length; - const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); + const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -635,6 +808,7 @@ FindCommand( * ---------------------------------------------------------------------- * * InitDefineContext -- + * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. @@ -660,7 +834,9 @@ InitDefineContext( return TCL_ERROR; } - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. + */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); @@ -675,6 +851,7 @@ InitDefineContext( * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * @@ -689,7 +866,8 @@ TclOOGetDefineCmdContext( Tcl_Object object; if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE + && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); @@ -711,6 +889,7 @@ TclOOGetDefineCmdContext( * ---------------------------------------------------------------------- * * GetClassInOuterContext -- + * * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the * context that called oo::define (or equivalent). Note that this may * have to go up multiple levels to get the level that we started doing @@ -729,7 +908,8 @@ GetClassInOuterContext( Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } @@ -753,6 +933,7 @@ GetClassInOuterContext( * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- @@ -777,7 +958,7 @@ GenerateErrorInfo( int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + const char *objName = TclGetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); @@ -791,6 +972,7 @@ GenerateErrorInfo( * ---------------------------------------------------------------------- * * MagicDefinitionInvoke -- + * * Part of the implementation of the "oo::define" and "oo::objdefine" * commands that is used to implement the more-than-one-argument case, * applying ensemble-like tricks with dispatch so that error messages are @@ -854,6 +1036,7 @@ MagicDefinitionInvoke( * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- + * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target @@ -914,7 +1097,7 @@ TclOODefineObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -928,6 +1111,7 @@ TclOODefineObjCmd( * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- + * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target @@ -981,7 +1165,7 @@ TclOOObjDefObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -995,6 +1179,7 @@ TclOOObjDefObjCmd( * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the @@ -1013,18 +1198,20 @@ TclOODefineSelfObjCmd( { Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; - int result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); - return TCL_ERROR; - } + int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } + if (objc < 2) { + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; + } + + private = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1033,6 +1220,9 @@ TclOODefineSelfObjCmd( if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } + if (private) { + ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + } AddRef(oPtr); if (objc == 2) { @@ -1040,7 +1230,7 @@ TclOODefineSelfObjCmd( Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 2); + ((Interp *)interp)->cmdFramePtr, 1); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } @@ -1048,7 +1238,7 @@ TclOODefineSelfObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1061,7 +1251,115 @@ TclOODefineSelfObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineObjSelfObjCmd -- + * + * Implementation of the "self" subcommand of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineObjSelfObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefinePrivateObjCmd -- + * + * Implementation of the "private" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefinePrivateObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstancePrivate = (clientData != NULL); + /* Just so that we can generate the correct + * error message depending on the context of + * usage of this function. */ + Interp *iPtr = (Interp *) interp; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int saved; /* The saved flag. We restore it on exit so + * that [private private ...] doesn't make + * things go weird. */ + int result; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; + } + + /* + * Change the frame type flag while evaluating the body. + */ + + saved = iPtr->varFramePtr->isProcCallFrame; + iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + + /* + * Evaluate the body; standard pattern. + */ + + AddRef(oPtr); + if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); + if (result == TCL_ERROR) { + GenerateErrorInfo(interp, oPtr, objNameObj, + isInstancePrivate ? "object" : "class"); + } + TclDecrRefCount(objNameObj); + } else { + result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), + 1, objc, objv); + } + TclOODecrRefCount(oPtr); + + /* + * Restore the frame type flag to what it was previously. + */ + + iPtr->varFramePtr->isProcCallFrame = saved; + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * @@ -1077,6 +1375,8 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; + Foundation *fPtr = TclOOGetFoundation(interp); + int wasClass, willBeClass; /* * Parse the context to get the object to operate on. @@ -1112,19 +1412,49 @@ TclOODefineClassObjCmd( if (clsPtr == NULL) { return TCL_ERROR; } - + if (oPtr == clsPtr->thisPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not change classes into an instance of themselves", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } /* * Set the object's class. */ + wasClass = (oPtr->classPtr != NULL); + willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr)); + if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); + TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = clsPtr; + AddRef(oPtr->selfCls->thisPtr); TclOOAddToInstances(oPtr, oPtr->selfCls); - if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) { - oPtr->flags &= ~CLASS_GONE; + + /* + * Create or delete the class guts if necessary. + */ + + if (wasClass && !willBeClass) { + /* + * This is the most global of all epochs. Bump it! No cache can be + * trusted! + */ + + TclOORemoveFromMixins(oPtr->classPtr, oPtr); + oPtr->fPtr->epoch++; + oPtr->flags |= DONT_DELETE; + TclOODeleteDescendants(interp, oPtr); + oPtr->flags &= ~DONT_DELETE; + TclOOReleaseClassContents(interp, oPtr); + ckfree(oPtr->classPtr); + oPtr->classPtr = NULL; + } else if (!wasClass && willBeClass) { + TclOOAllocClass(interp, oPtr); } + if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { @@ -1138,6 +1468,7 @@ TclOODefineClassObjCmd( * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * @@ -1172,7 +1503,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[2], &bodyLength); + TclGetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1206,6 +1537,7 @@ TclOODefineConstructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1262,6 +1594,7 @@ TclOODefineDeleteMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * @@ -1291,7 +1624,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[1], &bodyLength); + TclGetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1326,6 +1659,7 @@ TclOODefineDestructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1396,8 +1730,9 @@ TclOODefineExportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; changed = 1; } } @@ -1420,6 +1755,7 @@ TclOODefineExportObjCmd( * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1456,6 +1792,9 @@ TclOODefineForwardObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method structure. @@ -1480,6 +1819,7 @@ TclOODefineForwardObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1514,6 +1854,9 @@ TclOODefineMethodObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method by using the right back-end API. @@ -1536,70 +1879,8 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineMixinObjCmd -- - * Implementation of the "mixin" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMixinObjCmd( - ClientData clientData, - Tcl_Interp *interp, - const int objc, - Tcl_Obj *const *objv) -{ - int isInstanceMixin = (clientData != NULL); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class **mixins; - int i; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); - - for (i=1 ; i<objc ; i++) { - Class *clsPtr = GetClassInOuterContext(interp, objv[i], - "may only mix in classes"); - - if (clsPtr == NULL) { - goto freeAndError; - } - if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - mixins[i-1] = clsPtr; - } - - if (isInstanceMixin) { - TclOOObjectSetMixins(oPtr, objc-1, mixins); - } else { - TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); - } - - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1656,6 +1937,7 @@ TclOODefineRenameMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1726,8 +2008,8 @@ TclOODefineUnexportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); changed = 1; } } @@ -1750,6 +2032,7 @@ TclOODefineUnexportObjCmd( * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * @@ -1804,6 +2087,7 @@ Tcl_ClassSetDestructor( * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * @@ -1817,6 +2101,7 @@ TclOODefineSlots( const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) @@ -1826,9 +2111,10 @@ TclOODefineSlots( } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); + Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; @@ -1837,9 +2123,14 @@ TclOODefineSlots( &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); + if (slotInfoPtr->resolverType.callProc) { + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + &slotInfoPtr->resolverType, NULL); + } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); + Tcl_DecrRefCount(resolveName); return TCL_OK; } @@ -1847,6 +2138,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * @@ -1926,6 +2218,7 @@ ClassFilterSet( * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * @@ -2007,6 +2300,7 @@ ClassMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { @@ -2030,6 +2324,7 @@ ClassMixinSet( * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * @@ -2124,16 +2419,19 @@ ClassSuperSet( if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); - superclasses[0] = oPtr->fPtr->objectCls; - superc = 1; if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; + } else { + superclasses[0] = oPtr->fPtr->objectCls; } + superc = 1; + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i<superc ; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { + i--; goto failedAfterAlloc; } for (j=0 ; j<i ; j++) { @@ -2150,9 +2448,19 @@ ClassSuperSet( "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: - ckfree((char *) superclasses); + for (; i > 0; i--) { + TclOODecrRefCount(superclasses[i]->thisPtr); + } + ckfree(superclasses); return TCL_ERROR; } + + /* + * Corresponding TclOODecrRefCount() is near the end of this + * function. + */ + + AddRef(superclasses[i]->thisPtr); } } @@ -2166,8 +2474,9 @@ ClassSuperSet( if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } - ckfree((char *) oPtr->classPtr->superclasses.list); + ckfree(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; @@ -2183,6 +2492,7 @@ ClassSuperSet( * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * @@ -2198,7 +2508,7 @@ ClassVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2216,8 +2526,18 @@ ClassVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2233,7 +2553,7 @@ ClassVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; int i; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -2256,7 +2576,7 @@ ClassVarsSet( } for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2274,49 +2594,11 @@ ClassVarsSet( } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - - oPtr->classPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->classPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->classPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, + varc, varv, oPtr->classPtr->thisPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); } return TCL_OK; } @@ -2325,6 +2607,7 @@ ClassVarsSet( * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * @@ -2392,6 +2675,7 @@ ObjFilterSet( * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * @@ -2477,6 +2761,7 @@ ObjMixinSet( * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * @@ -2492,7 +2777,7 @@ ObjVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2504,8 +2789,18 @@ ObjVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2521,7 +2816,7 @@ ObjVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc, i; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2537,7 +2832,7 @@ ObjVarsSet( } for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2554,50 +2849,66 @@ ObjVarsSet( return TCL_ERROR; } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, + oPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->variables, varc, varv); } - oPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ResolveClass -- + * + * Implementation of the "Resolve" support method for some slots (those + * that are slots around a list of classes). This resolves possible class + * names to their fully-qualified names if possible. + * + * ---------------------------------------------------------------------- + */ - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->variables.num = n; +static int +ResolveClass( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + int idx = Tcl_ObjectContextSkippedArgs(context); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Class *clsPtr; - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ + /* + * Check if were called wrongly. The definition context isn't used... + * except that GetClassInOuterContext() assumes that it is there. + */ - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (oPtr == NULL) { + return TCL_ERROR; + } else if (objc != idx + 1) { + Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); + return TCL_ERROR; + } + + /* + * Resolve the class if possible. If not, remove any resolution error and + * return what we've got anyway as the failure might not be fatal overall. + */ + + clsPtr = GetClassInOuterContext(interp, objv[idx], + "USER SHOULD NOT SEE THIS MESSAGE"); + if (clsPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, objv[idx]); + } else { + Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } + return TCL_OK; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 76eaef5..fe433e4 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; @@ -50,6 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -58,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -80,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -517,15 +519,22 @@ InfoObjectMethodsCmd( Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + SCOPE_LOCALPRIVATE }; if (objc < 2) { @@ -554,14 +563,45 @@ InfoObjectMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, + &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -572,7 +612,7 @@ InfoObjectMethodsCmd( } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -684,6 +724,38 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectIdCmd -- + * + * Implements [info object creationid $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIdCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] @@ -719,7 +791,7 @@ InfoObjectNsCmd( * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName] + * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ @@ -732,21 +804,37 @@ InfoObjectVariablesCmd( Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1128,7 +1216,7 @@ InfoClassInstancesCmd( * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?-private?] + * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ @@ -1140,15 +1228,21 @@ InfoClassMethodsCmd( int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -1177,9 +1271,36 @@ InfoClassMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { @@ -1197,7 +1318,7 @@ InfoClassMethodsCmd( FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -1399,7 +1520,7 @@ InfoClassSupersCmd( * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName] + * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ @@ -1412,21 +1533,37 @@ InfoClassVariablesCmd( Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1465,7 +1602,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index b75ffdb..47e5cf0 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -125,6 +125,18 @@ typedef struct ForwardMethod { } ForwardMethod; /* + * Structure used in private variable mappings. Describes the mapping of a + * single variable from the user's local name to the system's storage name. + * [TIP #500] + */ + +typedef struct { + Tcl_Obj *variableObj; /* Name used within methods. This is the part + * that is properly under user control. */ + Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ +} PrivateVariableMapping; + +/* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is @@ -142,6 +154,13 @@ typedef struct ForwardMethod { struct { int num, size; listType_t *list; } /* + * These types are needed in function arguments. + */ + +typedef LIST_STATIC(Tcl_Obj *) VariableNameList; +typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; + +/* * Now, the definition of what an object actually is. */ @@ -149,8 +168,8 @@ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path - * for object invokation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ + * for object invocation and creation. */ + Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal @@ -162,12 +181,12 @@ typedef struct Object { /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ - struct Class *classPtr; /* All classes have this non-NULL; it points - * to the class structure. Everything else has - * this NULL. */ + struct Class *classPtr; /* This is non-NULL for all classes, and NULL + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak - * references; this mechanism is there to + * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; int creationEpoch; /* Unique value to make comparisons of objects @@ -186,16 +205,22 @@ typedef struct Object { Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ + Tcl_Command myclassCommand; /* Reference to this object's class dispatcher + * command. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ -#define CLASS_GONE 4 /* Indicates that the class of this object has - * been deleted, and so the object should not - * attempt to remove itself from its class. */ +#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this + * object has been deleted, and so the object + * should not attempt to remove itself from its + * class. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ @@ -213,6 +238,14 @@ typedef struct Object { * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ +#define HAS_PRIVATE_METHODS 0x20000 + /* Object/class has (or had) private methods, + * and so shouldn't be cached so + * aggressively. */ +#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used + * during fundamental object type mutation to + * make sure that the object actually survives + * to the end of the operation. */ /* * And the definition of a class. Note that every class also has an associated @@ -222,10 +255,6 @@ typedef struct Object { typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ - int refCount; /* Number of strong references to this class. - * Weak references are not counted; the - * purpose of this is to avoid Tcl_Preserve as - * that is quite slow. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation @@ -271,7 +300,10 @@ typedef struct Class { * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ } Class; /* @@ -323,7 +355,7 @@ typedef struct Foundation { } Foundation; /* - * A call context structure is built when a method is called. They contain the + * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. @@ -334,7 +366,7 @@ typedef struct Foundation { struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ - int isFilter; /* Whether this is a filter invokation. */ + int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; @@ -373,10 +405,15 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ +#define TRUE_PRIVATE_METHOD 0x20 + /* This is a private method only accessible + * from other methods defined on this class + * or instance. [TIP #500] */ +#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) /* * Structure containing definition information about basic class methods. @@ -431,6 +468,12 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -487,18 +530,28 @@ MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, + Object *useThisObj); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr); +MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); +MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, + Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, + Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); @@ -508,7 +561,8 @@ MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); -MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, +MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, + Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); @@ -521,10 +575,13 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); -MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, +MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp, + Object *oPtr); +MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE int TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr); +MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); -MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); @@ -539,24 +596,38 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #include "tclOOIntDecls.h" /* + * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. + */ + +#define AddRef(ptr) ((ptr)->refCount++) + +/* * A convenience macro for iterating through the lists used in the internal - * memory management of objects. This is a bit gnarly because we want to do - * the assignment of the picked-out value only when the body test succeeds, - * but we cannot rely on the assigned value being useful, forcing us to do - * some nasty stuff with the comma operator. The compiler's optimizer should - * be able to sort it all out! - * + * memory management of objects. * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ - for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++) + for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ + continue; \ + } else if (var = (ary).list[i], 1) + +/* + * A variation where the array is an array of structs. There's no issue with + * possible NULLs; every element of the array will be iterated over and the + * varable set to a pointer to each of those elements in turn. + * REQUIRES DECLARATION: int i; + */ + +#define FOREACH_STRUCT(var,ary) \ + for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. + * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ @@ -585,17 +656,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } \ } while(0) -/* - * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. - */ - -#define AddRef(ptr) ((ptr)->refCount++) -#define DelRef(ptr) do { \ - if ((ptr)->refCount-- <= 1) { \ - ckfree((char *) (ptr)); \ - } \ - } while(0) - #endif /* TCL_OO_INTERNAL_H */ /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 8da0fb3..545cb47 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -186,7 +186,11 @@ Tcl_NewInstanceMethod( mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + oPtr->flags |= HAS_PRIVATE_METHODS; + } } oPtr->epoch++; return (Tcl_Method) mPtr; @@ -250,7 +254,11 @@ Tcl_NewMethod( mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + clsPtr->flags |= HAS_PRIVATE_METHODS; + } } return (Tcl_Method) mPtr; @@ -791,6 +799,7 @@ PushMethodCallFrame( register int result; const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; + ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. @@ -856,10 +865,8 @@ PushMethodCallFrame( * alternative is *so* slow... */ - if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - + ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr) { codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, @@ -928,7 +935,7 @@ PushMethodCallFrame( * variables used in methods. The compiled variable resolver is more * important, but both are needed as it is possible to have a variable * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320] + * force LVT presence. [TIP #320, #500] * * ---------------------------------------------------------------------- */ @@ -986,6 +993,7 @@ ProcedureMethodCompiledVarConnect( CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; int i, isNew, cacheIt, varLen, len; const char *match, *varName; @@ -1019,6 +1027,15 @@ ProcedureMethodCompiledVarConnect( varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { + FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 0; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { match = TclGetStringFromObj(variableObj, &len); @@ -1028,6 +1045,14 @@ ProcedureMethodCompiledVarConnect( } } } else { + FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 1; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->oPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { @@ -1166,7 +1191,7 @@ MethodErrorHandler( CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); + TclGetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { @@ -1315,7 +1340,7 @@ CloneProcedureMethod( bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); Tcl_GetString(bodyObj); - TclFreeIntRep(bodyObj); + Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* * Create the actual copy of the method record, manufacturing a new proc @@ -1544,9 +1569,7 @@ TclOOGetMethodBody( if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; - if (pmPtr->procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); - } + (void) TclGetString(pmPtr->procPtr->bodyPtr); return pmPtr->procPtr->bodyPtr; } return NULL; @@ -1673,6 +1696,13 @@ Tcl_MethodIsPublic( { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } + +int +Tcl_MethodIsPrivate( + Tcl_Method method) +{ + return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; +} /* * Extended method construction for itcl-ng. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h new file mode 100644 index 0000000..2213ce3 --- /dev/null +++ b/generic/tclOOScript.h @@ -0,0 +1,263 @@ +/* + * tclOOScript.h -- + * + * This file contains support scripts for TclOO. They are defined here so + * that the code can be definitely run even in safe interpreters; TclOO's + * core setup is safe. + * + * Copyright (c) 2012-2018 Donal K. Fellows + * Copyright (c) 2013 Andreas Kupries + * Copyright (c) 2017 Gerald Lester + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_OO_SCRIPT_H +#define TCL_OO_SCRIPT_H + +/* + * The scripted part of the definitions of TclOO. + * + * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which + * contains the commented version of everything; *this* file is automatically + * generated. + */ + +static const char *tclOOSetupScript = +/* !BEGIN!: Do not edit below this line. */ +"::namespace eval ::oo {\n" +"\t::namespace path {}\n" +"\tnamespace eval Helpers {\n" +"\t\t::namespace path {}\n" +"\t\tproc callback {method args} {\n" +"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" +"\t\t}\n" +"\t\tnamespace export callback\n" +"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" +"\t\tnamespace export -clear\n" +"\t\trename tmp::callback mymethod\n" +"\t\tnamespace delete tmp\n" +"\t\tproc classvariable {name args} {\n" +"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\t\tforeach v [list $name {*}$args] {\n" +"\t\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tlappend vs $v $v\n" +"\t\t\t}\n" +"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t}\n" +"\t\tproc link {args} {\n" +"\t\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\t\tforeach link $args {\n" +"\t\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\t\tlassign $link src dst\n" +"\t\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\t\tlassign $link src\n" +"\t\t\t\t\tset dst $src\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" +"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t\t}\n" +"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t}\n" +"\tproc UnlinkLinkedCommand {cmd args} {\n" +"\t\tif {[namespace which $cmd] ne {}} {\n" +"\t\t\trename $cmd {}\n" +"\t\t}\n" +"\t}\n" +"\tproc DelegateName {class} {\n" +"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" +"\t}\n" +"\tproc MixinClassDelegates {class} {\n" +"\t\tif {![info object isa class $class]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tset delegate [DelegateName $class]\n" +"\t\tif {![info object isa class $delegate]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tforeach c [info class superclass $class] {\n" +"\t\t\tset d [DelegateName $c]\n" +"\t\t\tif {![info object isa class $d]} {\n" +"\t\t\t\tcontinue\n" +"\t\t\t}\n" +"\t\t\tdefine $delegate superclass -append $d\n" +"\t\t}\n" +"\t\tobjdefine $class mixin -append $delegate\n" +"\t}\n" +"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +"\t\tset originDelegate [DelegateName $originObject]\n" +"\t\tset targetDelegate [DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\tcopy $originDelegate $targetDelegate\n" +"\t\t\tobjdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" +"\t}\n" +"\tproc define::classmethod {name {args {}} {body {}}} {\n" +"\t\t::set argc [::llength [::info level 0]]\n" +"\t\t::if {$argc == 3} {\n" +"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" +"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" +"\t\t\t\t[::lindex [::info level 0] 0]]\n" +"\t\t}\n" +"\t\t::set cls [::uplevel 1 self]\n" +"\t\t::if {$argc == 4} {\n" +"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +"\t\t}\n" +"\t\t::tailcall forward $name myclass $name\n" +"\t}\n" +"\tproc define::initialise {body} {\n" +"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" +"\t\t::tailcall apply [::list {} $body $clsns]\n" +"\t}\n" +"\tnamespace eval define {\n" +"\t\t::namespace export initialise\n" +"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" +"\t\t::namespace export -clear\n" +"\t\t::rename tmp::initialise initialize\n" +"\t\t::namespace delete tmp\n" +"\t}\n" +"\tdefine Slot {\n" +"\t\tmethod Get {} {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Set list {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Resolve list {\n" +"\t\t\treturn $list\n" +"\t\t}\n" +"\t\tmethod -set args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\ttailcall my Set $args\n" +"\t\t}\n" +"\t\tmethod -append args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tmethod -prepend args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" +"\t\t}\n" +"\t\tmethod -remove args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [lmap val $current {\n" +"\t\t\t\tif {$val in $args} continue else {set val}\n" +"\t\t\t}]\n" +"\t\t}\n" +"\t\tforward --default-operation my -append\n" +"\t\tmethod unknown {args} {\n" +"\t\t\tset def --default-operation\n" +"\t\t\tif {[llength $args] == 0} {\n" +"\t\t\t\ttailcall my $def\n" +"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" +"\t\t\t\ttailcall my $def {*}$args\n" +"\t\t\t}\n" +"\t\t\tnext {*}$args\n" +"\t\t}\n" +"\t\texport -set -append -clear -prepend -remove\n" +"\t\tunexport unknown destroy\n" +"\t}\n" +"\tobjdefine define::superclass forward --default-operation my -set\n" +"\tobjdefine define::mixin forward --default-operation my -set\n" +"\tobjdefine objdefine::mixin forward --default-operation my -set\n" +"\tdefine object method <cloned> {originObject} {\n" +"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" +"\t\t\tset args [info args $p]\n" +"\t\t\tset idx -1\n" +"\t\t\tforeach a $args {\n" +"\t\t\t\tif {[info default $p $a d]} {\n" +"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tlset args [incr idx] [list $a]\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\tset b [info body $p]\n" +"\t\t\tset p [namespace tail $p]\n" +"\t\t\tproc $p $args $b\n" +"\t\t}\n" +"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" +"\t\t\tupvar 0 $v vOrigin\n" +"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" +"\t\t\tif {[info exists vOrigin]} {\n" +"\t\t\t\tif {[array exists vOrigin]} {\n" +"\t\t\t\t\tarray set vNew [array get vOrigin]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tset vNew $vOrigin\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t}\n" +"\t}\n" +"\tdefine class method <cloned> {originObject} {\n" +"\t\tnext $originObject\n" +"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t}\n" +"\tclass create singleton {\n" +"\t\tsuperclass class\n" +"\t\tvariable object\n" +"\t\tunexport create createWithNamespace\n" +"\t\tmethod new args {\n" +"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\t\tset object [next {*}$args]\n" +"\t\t\t\t::oo::objdefine $object {\n" +"\t\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\tmethod <cloned> {originObject} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\treturn $object\n" +"\t\t}\n" +"\t}\n" +"\tclass create abstract {\n" +"\t\tsuperclass class\n" +"\t\tunexport create createWithNamespace new\n" +"\t}\n" +"}\n" +/* !END!: Do not edit above this line. */ +; + +#endif /* TCL_OO_SCRIPT_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl new file mode 100644 index 0000000..a48eab5 --- /dev/null +++ b/generic/tclOOScript.tcl @@ -0,0 +1,456 @@ +# tclOOScript.h -- +# +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. +# +# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2013 Andreas Kupries +# Copyright (c) 2017 Gerald Lester +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +::namespace eval ::oo { + ::namespace path {} + + # + # Commands that are made available to objects by default. + # + namespace eval Helpers { + ::namespace path {} + + # ------------------------------------------------------------------ + # + # callback, mymethod -- + # + # Create a script prefix that calls a method on the current + # object. Same operation, two names. + # + # ------------------------------------------------------------------ + + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args + } + + # Make the [callback] command appear as [mymethod] too. + namespace export callback + namespace eval tmp {namespace import ::oo::Helpers::callback} + namespace export -clear + rename tmp::callback mymethod + namespace delete tmp + + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ + + proc classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } + + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCLOO CMDLINK FORMAT} \ + "bad link description; must only have one or two elements" + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] + } + return + } + } + + # ---------------------------------------------------------------------- + # + # UnlinkLinkedCommand -- + # + # Callback used to remove linked command when the underlying mechanism + # that supports it is deleted. + # + # ---------------------------------------------------------------------- + + proc UnlinkLinkedCommand {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } + } + + # ---------------------------------------------------------------------- + # + # DelegateName -- + # + # Utility that gets the name of the class delegate for a class. It's + # trivial, but makes working with them much easier as delegate names are + # intentionally hard to create by accident. + # + # ---------------------------------------------------------------------- + + proc DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} + } + + # ---------------------------------------------------------------------- + # + # MixinClassDelegates -- + # + # Support code called *after* [oo::define] inside the constructor of a + # class that patches in the appropriate class delegates. + # + # ---------------------------------------------------------------------- + + proc MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [DelegateName $c] + if {![info object isa class $d]} { + continue + } + define $delegate superclass -append $d + } + objdefine $class mixin -append $delegate + } + + # ---------------------------------------------------------------------- + # + # UpdateClassDelegatesAfterClone -- + # + # Support code that is like [MixinClassDelegates] except for when a + # class is cloned. + # + # ---------------------------------------------------------------------- + + proc UpdateClassDelegatesAfterClone {originObject targetObject} { + # Rebuild the class inheritance delegation class + set originDelegate [DelegateName $originObject] + set targetDelegate [DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + copy $originDelegate $targetDelegate + objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } + } + + # ---------------------------------------------------------------------- + # + # oo::define::classmethod -- + # + # Defines a class method. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::classmethod {name {args {}} {body {}}} { + # Create the method on the class if the caller gave arguments and body + ::set argc [::llength [::info level 0]] + ::if {$argc == 3} { + ::return -code error -errorcode {TCL WRONGARGS} [::format \ + {wrong # args: should be "%s name ?args body?"} \ + [::lindex [::info level 0] 0]] + } + ::set cls [::uplevel 1 self] + ::if {$argc == 4} { + ::oo::define [::oo::DelegateName $cls] method $name $args $body + } + # Make the connection by forwarding + ::tailcall forward $name myclass $name + } + + # ---------------------------------------------------------------------- + # + # oo::define::initialise, oo::define::initialize -- + # + # Do specific initialisation for a class. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::initialise {body} { + ::set clsns [::info object namespace [::uplevel 1 self]] + ::tailcall apply [::list {} $body $clsns] + } + + # Make the [initialise] definition appear as [initialize] too + namespace eval define { + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::namespace export -clear + ::rename tmp::initialise initialize + ::namespace delete tmp + } + + # ---------------------------------------------------------------------- + # + # Slot -- + # + # The class of slot operations, which are basically lists at the low + # level of TclOO; this provides a more consistent interface to them. + # + # ---------------------------------------------------------------------- + + define Slot { + # ------------------------------------------------------------------ + # + # Slot Get -- + # + # Basic slot getter. Retrieves the contents of the slot. + # Particular slots must provide concrete non-erroring + # implementation. + # + # ------------------------------------------------------------------ + + method Get {} { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot Set -- + # + # Basic slot setter. Sets the contents of the slot. Particular + # slots must provide concrete non-erroring implementation. + # + # ------------------------------------------------------------------ + + method Set list { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot Resolve -- + # + # Helper that lets a slot convert a list of arguments of a + # particular type to their canonical forms. Defaults to doing + # nothing (suitable for simple strings). + # + # ------------------------------------------------------------------ + + method Resolve list { + return $list + } + + # ------------------------------------------------------------------ + # + # Slot -set, -append, -clear, --default-operation -- + # + # Standard public slot operations. If a slot can't figure out + # what method to call directly, it uses --default-operation. + # + # ------------------------------------------------------------------ + + method -set args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + tailcall my Set $args + } + method -append args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [lmap val $current { + if {$val in $args} continue else {set val} + }] + } + + # Default handling + forward --default-operation my -append + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args + } + next {*}$args + } + + # Set up what is exported and what isn't + export -set -append -clear -prepend -remove + unexport unknown destroy + } + + # Set the default operation differently for these slots + objdefine define::superclass forward --default-operation my -set + objdefine define::mixin forward --default-operation my -set + objdefine objdefine::mixin forward --default-operation my -set + + # ---------------------------------------------------------------------- + # + # oo::object <cloned> -- + # + # Handler for cloning objects that clones basic bits (only!) of the + # object's namespace. Non-procedures, traces, sub-namespaces, etc. need + # more complex (and class-specific) handling. + # + # ---------------------------------------------------------------------- + + define object method <cloned> {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin + } + } + } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. + } + + # ---------------------------------------------------------------------- + # + # oo::class <cloned> -- + # + # Handler for cloning classes, which fixes up the delegates. + # + # ---------------------------------------------------------------------- + + define class method <cloned> {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + ::oo::UpdateClassDelegatesAfterClone $originObject [self] + } + + # ---------------------------------------------------------------------- + # + # oo::singleton -- + # + # A metaclass that is used to make classes that only permit one instance + # of them to exist. See singleton(n). + # + # ---------------------------------------------------------------------- + + class create singleton { + superclass class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not destroy a singleton object" + } + method <cloned> {originObject} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not clone a singleton object" + } + } + } + return $object + } + } + + # ---------------------------------------------------------------------- + # + # oo::abstract -- + # + # A metaclass that is used to make classes that can't be directly + # instantiated. See abstract(n). + # + # ---------------------------------------------------------------------- + + class create abstract { + superclass class + unexport create createWithNamespace new + } +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 900ab22..5e235f4 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = { Tcl_ClassSetConstructor, /* 26 */ Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ + Tcl_MethodIsPrivate, /* 29 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 3bf5b8e..6a4d161 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tommath.h" #include <math.h> +#include <assert.h> /* * Table of all object types. @@ -37,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL; * TclNewObj macro, however, so must be visible. */ -#ifdef TCL_THREADS +#if TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif @@ -49,9 +50,8 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; -char *tclEmptyStringRep = &tclEmptyString; -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) /* * Structure for tracking the source file and line number where a given * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, @@ -76,7 +76,7 @@ typedef struct ObjData { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text @@ -88,7 +88,7 @@ typedef struct ThreadSpecificData { * tclCompile.h for the definition of this * structure, and for references to all * related places in the core. */ -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ @@ -157,7 +157,7 @@ typedef struct PendingObjData { /* * Macro to set up the local reference to the deletion context. */ -#ifndef TCL_THREADS +#if !TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData @@ -211,9 +211,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void UpdateStringOfOldInt(Tcl_Obj *objPtr); #endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -243,6 +242,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ @@ -250,6 +250,7 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ @@ -265,19 +266,23 @@ const Tcl_ObjType tclDoubleType = { SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ +#else + "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ +#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef TCL_WIDE_INT_IS_LONG -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static const Tcl_ObjType oldIntType = { + "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { @@ -345,23 +350,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + unsigned long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + unsigned int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this + unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, * deleted, hidden, or exposed, and so the * pointer is invalid. */ - int refCount; /* Reference count: 1 for each cmdName object + size_t refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount @@ -396,21 +401,21 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&oldIntType); +#endif Tcl_RegisterObjType(&oldBooleanType); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS @@ -448,7 +453,7 @@ TclInitObjSubsystem(void) void TclFinalizeThreadObjects(void) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1005,7 +1010,7 @@ void TclDbDumpActiveObjects( FILE *outFile) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -1061,11 +1066,10 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; objPtr->typePtr = NULL; + TclInitStringRep(objPtr, NULL, 0); -#ifdef TCL_THREADS +#if TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1301,7 +1305,7 @@ TclFreeObj( ObjInitDeletionContext(context); -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -1628,32 +1632,30 @@ Tcl_GetString( register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes != NULL) { - return objPtr->bytes; - } - - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant of - * a properly maintained Tcl_Obj is that at least one of objPtr->bytes - * and objPtr->typePtr must not be NULL. If broken extensions fail to - * maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { + if (objPtr->bytes == NULL) { /* - * Those Tcl_ObjTypes which choose not to define an updateStringProc - * must be written in such a way that (objPtr->bytes) never becomes - * NULL. This panic was added in Tcl 8.1. + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } } return objPtr->bytes; } @@ -1689,8 +1691,31 @@ Tcl_GetStringFromObj( * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - (void) TclGetString(objPtr); + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -1700,6 +1725,91 @@ Tcl_GetStringFromObj( /* *---------------------------------------------------------------------- * + * Tcl_InitStringRep -- + * + * This function is called in several configurations to provide all + * the tools needed to set an object's string representation. The + * function is determined by the arguments. + * + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * Invalid call -- panic! + * + * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * Allocation only - allocate space for (numBytes+1) chars. + * store in objPtr->bytes and return. Also sets + * objPtr->length to 0 and objPtr->bytes[0] to NUL. + * + * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * Allocate and copy. bytes is assumed to point to chars to + * copy into the string rep. objPtr->length = numBytes. Allocate + * array of (numBytes + 1) chars. store in objPtr->bytes. Copy + * numBytes chars from bytes to objPtr->bytes; Set + * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. + * Caller must guarantee there are numBytes chars at bytes to + * be copied. + * + * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * Truncate. Set objPtr->length to numBytes and + * objPr->bytes[numBytes] to NUL. Caller has to guarantee + * that a prior allocating call allocated enough bytes for + * this to be valid. Return objPtr->bytes. + * + * Caller is expected to ascertain that the bytes copied into + * the string rep make up complete valid UTF-8 characters. + * + * Results: + * A pointer to the string rep of objPtr. + * + * Side effects: + * As described above. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_InitStringRep( + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + const char *bytes, + unsigned int numBytes) +{ + assert(objPtr->bytes == NULL || bytes == NULL); + + if (numBytes > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* Allocate */ + if (objPtr->bytes == NULL) { + /* Allocate only as empty - extend later if bytes copied */ + objPtr->length = 0; + if (numBytes) { + objPtr->bytes = attemptckalloc(numBytes + 1); + if (objPtr->bytes == NULL) { + return NULL; + } + if (bytes) { + /* Copy */ + memcpy(objPtr->bytes, bytes, numBytes); + objPtr->length = (int) numBytes; + } + } else { + TclInitStringRep(objPtr, NULL, 0); + } + } else { + /* objPtr->bytes != NULL bytes == NULL - Truncate */ + objPtr->bytes = ckrealloc(objPtr->bytes, numBytes + 1); + objPtr->length = (int)numBytes; + } + + /* Terminate */ + objPtr->bytes[objPtr->length] = '\0'; + + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string @@ -1726,6 +1836,123 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_HasStringRep -- + * + * This function reports whether object has a string representation. + * + * Results: + * Boolean. + *---------------------------------------------------------------------- + */ + +int +Tcl_HasStringRep( + Tcl_Obj *objPtr) /* Object to test */ +{ + return TclHasStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StoreIntRep -- + * + * This function is called to set the object's internal + * representation to match a particular type. + * + * It is the caller's responsibility to guarantee that + * the value of the submitted IntRep is in agreement with + * the value of any existing string rep. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StoreIntRep( + Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ + const Tcl_ObjType *typePtr, /* New type for the object */ + const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ +{ + /* Clear out any existing IntRep ( "shimmer" ) */ + TclFreeIntRep(objPtr); + + /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + if (irPtr) { + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; + + /* Set the type to match */ + objPtr->typePtr = typePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FetchIntRep -- + * + * This function is called to retrieve the object's internal + * representation matching a requested type, if any. + * + * Results: + * A read-only pointer to the associated Tcl_ObjIntRep, or + * NULL if no such internal representation exists. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjIntRep * +Tcl_FetchIntRep( + Tcl_Obj *objPtr, /* Object to fetch from. */ + const Tcl_ObjType *typePtr) /* Requested type */ +{ + /* If objPtr type doesn't match request, nothing can be fetched */ + if (objPtr->typePtr != typePtr) { + return NULL; + } + + /* Type match! objPtr IntRep is the one sought. */ + return &(objPtr->internalRep); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeIntRep -- + * + * This function is called to free an object's internal representation. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets typePtr field to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeIntRep( + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ +{ + TclFreeIntRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewBooleanObj -- * * This function is normally called when not debugging: i.e., when @@ -1734,7 +1961,7 @@ Tcl_InvalidateStringRep( * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewBooleanObj. + * of calling the debugging version Tcl_DbNewLongObj. * * Results: * The newly created object is returned. This object will have an invalid @@ -1753,7 +1980,7 @@ Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); + return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -1764,7 +1991,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewBooleanObj(objPtr, boolValue); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1795,6 +2022,7 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG @@ -1809,9 +2037,10 @@ Tcl_DbNewBooleanObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1858,8 +2087,9 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetBooleanObj(objPtr, boolValue); + TclSetIntObj(objPtr, boolValue!=0); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1888,11 +2118,11 @@ Tcl_GetBooleanFromObj( { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; + *boolPtr = objPtr->internalRep.longValue != 0; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -1916,12 +2146,6 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1942,7 +2166,12 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean. + * representation and the type of "objPtr" is set to boolean or int/wideInt. + * + * Warning: If the returned type is "wideInt" (32-bit platforms) and your + * platform is bigendian, you cannot use internalRep.longValue to distinguish + * between false and true. On Windows and most other platforms this still will + * work fine, but basically it is non-portable. * *---------------------------------------------------------------------- */ @@ -1960,8 +2189,7 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { - case 0L: case 1L: + if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; @@ -1971,12 +2199,6 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2005,9 +2227,10 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); + size_t i, length = objPtr->length; if ((length == 0) || (length > 5)) { /* @@ -2059,25 +2282,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2086,10 +2309,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2112,7 +2335,7 @@ ParseBoolean( numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2201,6 +2424,7 @@ Tcl_DbNewDoubleObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; @@ -2293,7 +2517,7 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { @@ -2303,12 +2527,6 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2367,15 +2585,12 @@ static void UpdateStringOfDouble( register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { - char buffer[TCL_DOUBLE_SPACE]; - register int len; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); - len = strlen(buffer); + TclOOM(dst, TCL_DOUBLE_SPACE + 1); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } /* @@ -2502,7 +2717,7 @@ Tcl_GetIntFromObj( if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { if (interp != NULL) { const char *s = "integer value too large to represent as non-long integer"; @@ -2537,9 +2752,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2565,15 +2779,25 @@ static void UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char buffer[TCL_INTEGER_SPACE]; - register int len; + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.wideValue)); +} - len = TclFormatInt(buffer, objPtr->internalRep.longValue); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.longValue)); } +#endif /* *---------------------------------------------------------------------- @@ -2605,8 +2829,8 @@ UpdateStringOfInt( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( @@ -2625,7 +2849,7 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2662,6 +2886,7 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -2676,9 +2901,10 @@ Tcl_DbNewLongObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2716,6 +2942,7 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2726,7 +2953,7 @@ Tcl_SetLongObj( Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } /* @@ -2757,14 +2984,15 @@ Tcl_GetLongFromObj( register long *longPtr) /* Place to store resulting long. */ { do { +#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* - * We return any integer in the range -ULONG_MAX to ULONG_MAX + * We return any integer in the range LONG_MIN to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in @@ -2773,9 +3001,9 @@ Tcl_GetLongFromObj( Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) + if (w >= (Tcl_WideInt)(LONG_MIN) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = Tcl_WideAsLong(w); + *longPtr = (long) w; return TCL_OK; } goto tooLarge; @@ -2801,10 +3029,9 @@ Tcl_GetLongFromObj( mp_int big; UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) + if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; + unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { @@ -2812,11 +3039,16 @@ Tcl_GetLongFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *longPtr = - (long) value; + if (value <= 1 + (unsigned long)LONG_MAX) { + *longPtr = - (long) value; + return TCL_OK; + } } else { - *longPtr = (long) value; + if (value <= (unsigned long)ULONG_MAX) { + *longPtr = (long) value; + return TCL_OK; + } } - return TCL_OK; } } #ifndef TCL_WIDE_INT_IS_LONG @@ -2835,49 +3067,6 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from the - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; - - /* - * Note that sprintf will generate a compiler warning under Mingw claiming - * %I64 is an unknown format specifier. Just ignore this warning. We can't - * use %L as the format specifier since that gets printed as a 32 bit - * value. - */ - - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2927,7 +3116,7 @@ Tcl_NewWideIntObj( register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2979,7 +3168,7 @@ Tcl_DbNewWideIntObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } @@ -3028,19 +3217,7 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); - } else { -#ifndef TCL_WIDE_INT_IS_LONG - TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclBNInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif - } + TclSetIntObj(objPtr, wideValue); } /* @@ -3072,14 +3249,8 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3112,11 +3283,16 @@ Tcl_GetWideIntFromObj( value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { - *wideIntPtr = - (Tcl_WideInt) value; + if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { + *wideIntPtr = - (Tcl_WideInt) value; + return TCL_OK; + } } else { - *wideIntPtr = (Tcl_WideInt) value; + if (value <= (Tcl_WideUInt)WIDE_MAX) { + *wideIntPtr = (Tcl_WideInt) value; + return TCL_OK; + } } - return TCL_OK; } } if (interp != NULL) { @@ -3132,33 +3308,70 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * - * SetWideIntFromAny -- + * TclGetWideBitsFromObj -- * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a int, double or bignum, an attempt will be made + * to convert it to one of these. Out-of-range values don't result in an + * error, but only the least significant 64 bits will be returned. * * Results: - * The return value is a standard object Tcl result. If an error occurs + * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * + * Side effects: + * If the object is not already an int, double or bignum object, the + * conversion will free any old internal representation. + * *---------------------------------------------------------------------- */ -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ +int +TclGetWideBitsFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + do { + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + if (objPtr->typePtr == &tclBignumType) { + mp_int big; + + Tcl_WideUInt value = 0, scratch; + unsigned long numBytes = sizeof(Tcl_WideInt); + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + mp_to_unsigned_bin_n(&big, bytes, &numBytes); + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; + mp_clear(&big); + return TCL_OK; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3245,12 +3458,10 @@ UpdateStringOfBignum( { mp_int bignumVal; int size; - int status; char *stringVal; UNPACK_BIGNUM(objPtr, bignumVal); - status = mp_radix_size(&bignumVal, 10, &size); - if (status != MP_OKAY) { + if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { @@ -3265,13 +3476,14 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); - status = mp_toradix_n(&bignumVal, stringVal, 10, size); - if (status != MP_OKAY) { + + stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + + TclOOM(stringVal, size); + if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing NUL byte. */ + (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* @@ -3391,26 +3603,26 @@ GetBignumFromObj( mp_init_copy(bignumValue, &temp); } else { UNPACK_BIGNUM(objPtr, *bignumValue); + /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; + /* + * TODO: If objPtr has a string rep, this leaves + * it undisturbed. Not clear that's proper. Pure + * bignum values are converted to empty string. + */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - TclBNInitBignumFromWideInt(bignumValue, + TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3520,36 +3732,11 @@ Tcl_SetBignumObj( Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); - } else { - TclSetLongObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; - } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; @@ -3557,19 +3744,18 @@ Tcl_SetBignumObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { + if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetIntObj(objPtr, -(Tcl_WideInt)value); } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + TclSetIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3651,17 +3837,10 @@ TclGetNumberFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *typePtr = TCL_NUMBER_WIDE; + *typePtr = TCL_NUMBER_INT; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, @@ -3714,7 +3893,7 @@ Tcl_DbIncrRefCount( Tcl_Panic("incrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3777,7 +3956,7 @@ Tcl_DbDecrRefCount( Tcl_Panic("decrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3842,7 +4021,7 @@ Tcl_DbIsShared( Tcl_Panic("checking whether previously disposed object is shared"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -4046,7 +4225,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -4096,7 +4275,7 @@ TclHashObjKey( result += (result << 3) + UCHAR(*++string); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -4150,11 +4329,10 @@ Tcl_GetCommandFromObj( */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + if (objPtr->typePtr == &tclCmdNameType) { register Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) - && !(cmdPtr->flags & CMD_IS_DELETED) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { register Namespace *refNsPtr = (Namespace *) @@ -4174,7 +4352,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } @@ -4202,6 +4380,59 @@ Tcl_GetCommandFromObj( *---------------------------------------------------------------------- */ +static void +SetCmdNameObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Command *cmdPtr, + ResolvedCmdName *resPtr) +{ + Interp *iPtr = (Interp *) interp; + ResolvedCmdName *fillPtr; + const char *name = TclGetString(objPtr); + + if (resPtr) { + fillPtr = resPtr; + } else { + fillPtr = ckalloc(sizeof(ResolvedCmdName)); + fillPtr->refCount = 1; + } + + fillPtr->cmdPtr = cmdPtr; + cmdPtr->refCount++; + fillPtr->cmdEpoch = cmdPtr->cmdEpoch; + + /* NOTE: relying on NULL termination here. */ + if ((name[0] == ':') && (name[1] == ':')) { + /* + * Fully qualified names always resolve to same thing. No need + * to record resolution context information. + */ + + fillPtr->refNsPtr = NULL; + fillPtr->refNsId = 0; /* Will not be read */ + fillPtr->refNsCmdEpoch = 0; /* Will not be read */ + } else { + /* + * Record current state of current namespace as the resolution + * context of this command name lookup. + */ + Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; + + fillPtr->refNsPtr = currNsPtr; + fillPtr->refNsId = currNsPtr->nsId; + fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + + if (resPtr == NULL) { + TclFreeIntRep(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } +} + void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command @@ -4211,10 +4442,7 @@ TclSetCmdNameObj( Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { - Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; - register Namespace *currNsPtr; - const char *name; if (objPtr->typePtr == &tclCmdNameType) { resPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4223,36 +4451,7 @@ TclSetCmdNameObj( } } - cmdPtr->refCount++; - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - - name = TclGetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - /* - * The name is fully qualified: set the referring namespace to - * NULL. - */ - - resPtr->refNsPtr = NULL; - } else { - /* - * Get the current namespace. - */ - - currNsPtr = iPtr->varFramePtr->nsPtr; - - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - } - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } /* @@ -4283,13 +4482,12 @@ FreeCmdNameInternalRep( { register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ - if (resPtr->refCount-- == 1) { + if (resPtr->refCount-- <= 1) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName @@ -4301,7 +4499,6 @@ FreeCmdNameInternalRep( TclCleanupCommandMacro(cmdPtr); ckfree(resPtr); } - } objPtr->typePtr = NULL; } @@ -4334,9 +4531,7 @@ DupCmdNameInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - if (resPtr != NULL) { resPtr->refCount++; - } copyPtr->typePtr = &tclCmdNameType; } @@ -4366,10 +4561,8 @@ SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - Interp *iPtr = (Interp *) interp; const char *name; register Command *cmdPtr; - Namespace *currNsPtr; register ResolvedCmdName *resPtr; if (interp == NULL) { @@ -4389,59 +4582,31 @@ SetCmdNameFromAny( Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Free the old internalRep before setting the new one. Do this after - * getting the string rep to allow the conversion code (in particular, - * Tcl_GetStringFromObj) to use that old internalRep. + * Stop shimmering and caching nothing when we found nothing. Just + * report the failure to find the command as an error. */ - if (cmdPtr) { - cmdPtr->refCount++; - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) - && resPtr && (resPtr->refCount == 1)) { - /* - * Reuse the old ResolvedCmdName struct instead of freeing it - */ - - Command *oldCmdPtr = resPtr->cmdPtr; - - if (--oldCmdPtr->refCount == 0) { - TclCleanupCommandMacro(oldCmdPtr); - } - } else { - TclFreeIntRep(objPtr); - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - if ((*name++ == ':') && (*name == ':')) { - /* - * The name is fully qualified: set the referring namespace to - * NULL. - */ + if (cmdPtr == NULL) { + return TCL_ERROR; + } - resPtr->refNsPtr = NULL; - } else { - /* - * Get the current namespace. - */ + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { + /* + * Re-use existing ResolvedCmdName struct when possible. + * Cleanup the old fields that need it. + */ - currNsPtr = iPtr->varFramePtr->nsPtr; + Command *oldCmdPtr = resPtr->cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + if (oldCmdPtr->refCount-- <= 1) { + TclCleanupCommandMacro(oldCmdPtr); } } else { - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + resPtr = NULL; } + + SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); return TCL_OK; } @@ -4468,7 +4633,6 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { @@ -4482,36 +4646,20 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(ptrBuffer, "%p", (void *) objv[1]); descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," - " object pointer at %s", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - objv[1]->refCount, ptrBuffer); - - /* - * This is a workaround to silence reports from `make valgrind` - * on 64-bit systems. The problem is that the test suite - * includes calling the [represenation] command on values of - * &tclDoubleType. When these values are created, the "doubleValue" - * is set, but when the "twoPtrValue" is examined, its "ptr2" - * field has never been initialized. Since [representation] - * presents the value of the ptr2 value in its output, valgrind - * alerts about the read of uninitialized memory. - * - * The general problem with [representation], that it can read - * and report uninitialized fields, is still present. This is - * just the minimal workaround to silence one particular test. - */ + " object pointer at %p", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, objv[1]); - if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) { - objv[1]->internalRep.twoPtrValue.ptr2 = NULL; - } if (objv[1]->typePtr) { - sprintf(ptrBuffer, "%p:%p", - (void *) objv[1]->internalRep.twoPtrValue.ptr1, - (void *) objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendPrintfToObj(descObj, ", internal representation %s", - ptrBuffer); + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_AppendPrintfToObj(descObj, ", internal representation %g", + objv[1]->internalRep.doubleValue); + } else { + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + } } if (objv[1]->bytes) { diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 827d89d..8267a7d 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -233,7 +233,7 @@ ConvertZeroEffectToNOP( TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -248,7 +248,7 @@ ConvertZeroEffectToNOP( TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b03ad41..85b7388 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -23,8 +23,8 @@ * procedure. */ -#if defined(__CYGWIN__) -static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; +#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) +static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; #else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; #endif @@ -45,6 +45,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) diff --git a/generic/tclParse.c b/generic/tclParse.c index f2cf322..00b83a1 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -167,6 +167,8 @@ static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); +static int ParseAllWhiteSpace(const char *src, int numBytes, + int *incompletePtr); /* *---------------------------------------------------------------------- @@ -298,9 +300,43 @@ Tcl_ParseCommand( */ parsePtr->commandStart = src; + type = CHAR_TYPE(*src); + scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; + /* Are we at command termination? */ + + if ((numBytes == 0) || (type & terminators) != 0) { + parsePtr->term = src; + parsePtr->commandSize = src + (numBytes != 0) + - parsePtr->commandStart; + return TCL_OK; + } + + /* Are we missing white space after previous word? */ + + if (scanned == 0) { + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; + } + /* * Create the token for the word. */ @@ -310,23 +346,6 @@ Tcl_ParseCommand( tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; - /* - * Skip white space before the word. Also skip a backslash-newline - * sequence: it should be treated just like white space. - */ - - scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; @@ -546,52 +565,12 @@ Tcl_ParseCommand( tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* - * Do two additional checks: (a) make sure we're really at the end of - * a word (there might have been garbage left after a quoted or braced - * word), and (b) check for the end of the command. - */ + /* Parse the whitespace between words. */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - if (scanned) { - src += scanned; - numBytes -= scanned; - continue; - } - - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - goto error; + src += scanned; + numBytes -= scanned; } - - parsePtr->commandSize = src - parsePtr->commandStart; - return TCL_OK; - - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; } /* @@ -733,23 +712,32 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -int -TclParseAllWhiteSpace( +static int +ParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ + int numBytes, /* Max number of byes to scan */ + int *incompletePtr) /* Set true if parse is incomplete. */ { - int dummy; char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); + int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } + +int +TclParseAllWhiteSpace( + const char *src, /* First character to parse. */ + int numBytes) /* Max number of byes to scan */ +{ + int dummy; + return ParseAllWhiteSpace(src, numBytes, &dummy); +} /* *---------------------------------------------------------------------- @@ -991,7 +979,12 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } - return Tcl_UniCharToUtf(result, dst); + count = Tcl_UniCharToUtf(result, dst); + if (!count) { + /* Special case for handling upper surrogates. */ + count = Tcl_UniCharToUtf(-1, dst); + } + return count; } /* @@ -1021,17 +1014,12 @@ ParseComment( * command. */ { register const char *p = src; + int incomplete = parsePtr->incomplete; while (numBytes) { - char type; - int scanned; - - do { - scanned = ParseWhiteSpace(p, numBytes, - &parsePtr->incomplete, &type); - p += scanned; - numBytes -= scanned; - } while (numBytes && (*p == '\n') && (p++,numBytes--)); + int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + p += scanned; + numBytes -= scanned; if ((numBytes == 0) || (*p != '#')) { break; @@ -1040,35 +1028,28 @@ ParseComment( parsePtr->commentStart = p; } + p++; + numBytes--; while (numBytes) { + if (*p == '\n') { + p++; + numBytes--; + break; + } if (*p == '\\') { - scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, - &type); - if (scanned) { - p += scanned; - numBytes -= scanned; - } else { - /* - * General backslash substitution in comments isn't part - * of the formal spec, but test parse-15.47 and history - * indicate that it has been the de facto rule. Don't - * change it now. - */ - - TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; - numBytes -= scanned; - } - } else { p++; numBytes--; - if (p[-1] == '\n') { + if (numBytes == 0) { break; } } + incomplete = (*p == '\n'); + p++; + numBytes--; } parsePtr->commentSize = p - parsePtr->commentStart; } + parsePtr->incomplete = incomplete; return (p - src); } @@ -2247,7 +2228,7 @@ TclSubstTokens( if (result == 0) { clPos = 0; } else { - Tcl_GetStringFromObj(result, &clPos); + TclGetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { @@ -2523,7 +2504,7 @@ TclObjCommandComplete( * check. */ { int length; - const char *script = Tcl_GetStringFromObj(objPtr, &length); + const char *script = TclGetStringFromObj(objPtr, &length); return CommandComplete(script, length); } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 29d6f96..c072fe0 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -36,7 +36,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp, * internally. */ -static const Tcl_ObjType tclFsPathType = { +static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ @@ -51,19 +51,14 @@ static const Tcl_ObjType tclFsPathType = { * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular - * reference to the container Tcl_Obj of this FsPath. - * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * - * translatedPathPtr contains the translated path (which may be a circular - * reference to the object itself). If it is NULL then the path is pure - * normalized (and the normPathPtr will be a circular reference). cwdPtr is - * null for an absolute path, and non-null for a relative path (unless the cwd - * has never been set, in which case the cwdPtr may also be null for a - * relative path). + * translatedPathPtr contains the translated path. If it is NULL then the path + * is pure normalized. cwdPtr is null for an absolute path, and non-null for a + * relative path (unless the cwd has never been set, in which case the cwdPtr + * may also be null for a relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * @@ -79,11 +74,7 @@ typedef struct FsPath { * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or - * ~user sequences. If the Tcl_Obj containing - * this FsPath is already normalized, this may - * be a circular reference back to the - * container. If that is NOT the case, we have - * a refCount on the object. */ + * ~user sequences. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ @@ -110,9 +101,14 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) +#define PATHOBJ(pathPtr) ((FsPath *) (Tcl_FetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ + } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -232,7 +228,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -258,7 +254,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -289,7 +285,7 @@ TclFSNormalizeAbsolutePath( */ const char *path = - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { @@ -304,7 +300,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -317,7 +313,7 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. @@ -334,7 +330,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } /* @@ -405,7 +401,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - const char *path = Tcl_GetStringFromObj(retVal, &len); + const char *path = TclGetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { @@ -564,7 +560,9 @@ TclPathPart( Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (pathPtr->typePtr == &tclFsPathType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { @@ -580,7 +578,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -618,7 +616,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -647,7 +645,7 @@ TclPathPart( const char *fileName, *extension; int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -699,7 +697,7 @@ TclPathPart( int length; const char *fileName, *extension; - fileName = Tcl_GetStringFromObj(pathPtr, &length); + fileName = TclGetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); @@ -864,6 +862,7 @@ TclJoinPath( if (elements == 2) { Tcl_Obj *elt = objv[0]; + Tcl_ObjIntRep *eltIr = Tcl_FetchIntRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where @@ -877,7 +876,7 @@ TclJoinPath( * to be an absolute path. Added a check for that elt is absolute. */ - if ((elt->typePtr == &tclFsPathType) + if ((eltIr) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[1]; @@ -887,7 +886,7 @@ TclJoinPath( const char *str; int len; - str = Tcl_GetStringFromObj(tailObj, &len); + str = TclGetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -958,7 +957,7 @@ TclJoinPath( Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; - strElt = Tcl_GetStringFromObj(elt, &strEltLen); + strElt = TclGetStringFromObj(elt, &strEltLen); driveNameLength = 0; type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { @@ -1052,10 +1051,8 @@ TclJoinPath( noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); - ptr = Tcl_GetStringFromObj(res, &length); - } else { - ptr = Tcl_GetStringFromObj(res, &length); } + ptr = TclGetStringFromObj(res, &length); /* * Strip off any './' before a tilde, unless this is the beginning of @@ -1088,7 +1085,7 @@ TclJoinPath( if (sep != NULL) { separator = TclGetString(sep)[0]; - Tcl_DecrRefCount(sep); + TclDecrRefCount(sep); } /* Safety check in case the VFS driver caused sharing */ if (Tcl_IsShared(res)) { @@ -1100,7 +1097,7 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - Tcl_GetStringFromObj(res, &length); + TclGetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1156,6 +1153,8 @@ Tcl_FSConvertToPathType( Tcl_Obj *pathPtr) /* Object to convert to a valid, current path * type. */ { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * While it is bad practice to examine an object's type directly, this is * actually the best thing to do here. The reason is that if we are @@ -1166,39 +1165,16 @@ Tcl_FSConvertToPathType( * path. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); - - /* - * We used to have more complex code here: - * - * FsPath *fsPathPtr = PATHOBJ(pathPtr); - * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { - * return TCL_OK; - * } else { - * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - * return TCL_OK; - * } else { - * if (pathPtr->bytes == NULL) { - * UpdateStringOfFsPath(pathPtr); - * } - * FreeFsPathInternalRep(pathPtr); - * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); - * } - * } - * - * But we no longer believe this is necessary. - */ } /* @@ -1330,9 +1306,7 @@ TclNewFSPathObj( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->typePtr = &tclFsPathType; - pathPtr->bytes = NULL; - pathPtr->length = 0; + TclInvalidateStringRep(pathPtr); /* * Look for path components made up of only "." @@ -1393,7 +1367,7 @@ AppendPath( * intrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = Tcl_GetStringFromObj(tail, &numBytes); + bytes = TclGetStringFromObj(tail, &numBytes); if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { @@ -1432,8 +1406,9 @@ TclFSMakePathRelative( { int cwdLen, len; const char *tempStr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { @@ -1452,7 +1427,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1472,7 +1447,7 @@ TclFSMakePathRelative( } break; } - tempStr = Tcl_GetStringFromObj(pathPtr, &len); + tempStr = TclGetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1500,31 +1475,12 @@ MakePathFromNormalized( Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { return TCL_OK; } - /* - * Free old representation - */ - - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't find object string representation", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", - NULL); - } - return TCL_ERROR; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - fsPathPtr = ckalloc(sizeof(FsPath)); /* @@ -1533,11 +1489,7 @@ MakePathFromNormalized( fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; @@ -1546,7 +1498,6 @@ MakePathFromNormalized( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } @@ -1597,25 +1548,12 @@ Tcl_FSNewNativePath( * safe. */ - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - return NULL; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference, by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; @@ -1623,7 +1561,6 @@ Tcl_FSNewNativePath( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return pathPtr; } @@ -1670,20 +1607,22 @@ Tcl_FSGetTranslatedPath( Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); + Tcl_ObjIntRep *translatedCwdIrPtr; + if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); - srcFsPathPtr->translatedPathPtr = retObj; - if (translatedCwdPtr->typePtr == &tclFsPathType) { + Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); + translatedCwdIrPtr = Tcl_FetchIntRep(translatedCwdPtr, &fsPathType); + if (translatedCwdIrPtr) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { /* @@ -1736,7 +1675,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; - const char *orig = Tcl_GetStringFromObj(transPtr, &len); + const char *orig = TclGetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); memcpy(result, orig, (size_t) len+1); @@ -1793,11 +1732,9 @@ Tcl_FSGetNormalizedPath( return NULL; } /* TODO: Figure out why this is needed. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1810,7 +1747,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) Tcl_GetStringFromObj(dir, &cwdLen); + (void) TclGetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ @@ -1847,7 +1784,7 @@ Tcl_FSGetNormalizedPath( /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); * above that set the pathType value should have established that, * but it's far less clear on what basis we know there's been no @@ -1865,6 +1802,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ + copy = NULL; TclDecrRefCount(dir); TclDecrRefCount(origDir); @@ -1877,7 +1815,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ - + copy = NULL; TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; @@ -1889,10 +1827,8 @@ Tcl_FSGetNormalizedPath( if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } @@ -1903,7 +1839,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* @@ -1918,7 +1854,6 @@ Tcl_FSGetNormalizedPath( } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; - int pureNormalized = 1; /* * Since normPathPtr is NULL, but this is a valid path object, we know @@ -1968,7 +1903,6 @@ Tcl_FSGetNormalizedPath( return NULL; } - pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); @@ -1988,7 +1922,6 @@ Tcl_FSGetNormalizedPath( if (absolutePath == NULL) { return NULL; } - pureNormalized = 0; #endif /* _WIN32 */ } } @@ -1997,35 +1930,12 @@ Tcl_FSGetNormalizedPath( * Already has refCount incremented. */ + if (fsPathPtr->normPathPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); - /* - * Check if path is pure normalized (this can only be the case if it - * is an absolute path). - */ - - if (pureNormalized) { - int normPathLen, pathLen; - const char *normPath; - - path = TclGetStringFromObj(pathPtr, &pathLen); - normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); - if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { - /* - * The path was already normalized. Get rid of the duplicate. - */ - - TclDecrRefCount(fsPathPtr->normPathPtr); - - /* - * We do *not* increment the refCount for this circular - * reference. - */ - - fsPathPtr->normPathPtr = pathPtr; - } - } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative @@ -2171,8 +2081,9 @@ TclFSEnsureEpochOk( const Tcl_Filesystem **fsPtrPtr) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr != &tclFsPathType) { + if (irPtr == NULL) { return TCL_OK; } @@ -2188,10 +2099,8 @@ TclFSEnsureEpochOk( * We have to discard the stale representation and recalculate it. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2231,12 +2140,13 @@ TclFSSetPathDetails( ClientData clientData) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);; /* * Make sure pathPtr is of the correct type. */ - if (pathPtr->typePtr != &tclFsPathType) { + if (irPtr == NULL) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } @@ -2334,8 +2244,9 @@ SetFsPathFromAny( FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { return TCL_OK; } @@ -2353,7 +2264,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr, &len); + name = TclGetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. @@ -2477,27 +2388,21 @@ SetFsPathFromAny( fsPathPtr = ckalloc(sizeof(FsPath)); - fsPathPtr->translatedPathPtr = transPtr; - if (transPtr != pathPtr) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); - /* Redo translation when $env(HOME) changes */ - fsPathPtr->filesystemEpoch = TclFSEpoch(); + if (transPtr == pathPtr) { + transPtr = Tcl_DuplicateObj(pathPtr); + fsPathPtr->filesystemEpoch = 0; } else { - fsPathPtr->filesystemEpoch = 0; + fsPathPtr->filesystemEpoch = TclFSEpoch(); } + Tcl_IncrRefCount(transPtr); + fsPathPtr->translatedPathPtr = transPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; - /* - * Free old representation before installing our new one. - */ - - TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } @@ -2520,6 +2425,7 @@ FreeFsPathInternalRep( } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); + fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = @@ -2532,7 +2438,6 @@ FreeFsPathInternalRep( } ckfree(fsPathPtr); - pathPtr->typePtr = NULL; } static void @@ -2545,24 +2450,14 @@ DupFsPathInternalRep( SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->translatedPathPtr = copyPtr; - } else { - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); - } + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } - if (srcFsPathPtr->normPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->normPathPtr = copyPtr; - } else { - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); - } + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; @@ -2588,8 +2483,6 @@ DupFsPathInternalRep( } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - - copyPtr->typePtr = &tclFsPathType; } /* @@ -2621,11 +2514,15 @@ UpdateStringOfFsPath( } copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + if (Tcl_IsShared(copy)) { + copy = Tcl_DuplicateObj(copy); + } - pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); + Tcl_IncrRefCount(copy); + /* Steal copy's string rep */ + pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; - copy->length = 0; + TclInitStringRep(copy, NULL, 0); TclDecrRefCount(copy); } @@ -2655,6 +2552,8 @@ TclNativePathInFilesystem( Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * A special case is required to handle the empty path "". This is a valid * path (i.e. the user should be able to do 'file exists ""' without @@ -2662,7 +2561,7 @@ TclNativePathInFilesystem( * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". @@ -2677,13 +2576,13 @@ TclNativePathInFilesystem( } else { /* * It is somewhat unusual to reach this code path without the object - * being of tclFsPathType. However, we do our best to deal with the + * being of fsPathType. However, we do our best to deal with the * situation. */ int len; - (void) Tcl_GetStringFromObj(pathPtr, &len); + (void) TclGetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 2ecc5a6..f94fe5c 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec, static TclFile FileForRedirect( - Tcl_Interp *interp, /* Intepreter to use for error reporting. */ + Tcl_Interp *interp, /* Interpreter to use for error reporting. */ const char *spec, /* Points to character just after redirection * character. */ int atOK, /* Non-zero means that '@' notation can be @@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -277,38 +277,21 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -319,39 +302,19 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } } @@ -936,6 +899,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclPkg.c b/generic/tclPkg.c index e956a40..2c16458 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,6 +17,10 @@ #include "tclInt.h" +MODULE_SCOPE char *tclEmptyStringRep; + +char *tclEmptyStringRep = &tclEmptyString; + /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter @@ -28,10 +32,22 @@ typedef struct PkgAvail { char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ + char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[1]; +} PkgName; + +typedef struct PkgFiles { + PkgName *names; /* Package names being initialized. Must be first field*/ + Tcl_HashTable table; /* Table which contains files for each package */ +} PkgFiles; + + /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -99,7 +115,7 @@ static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - unsigned local__len = (unsigned) (strlen(s) + 1); \ + size_t local__len = strlen(s) + 1; \ DupBlock((v),(s),local__len); \ } while (0) @@ -207,6 +223,63 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ +static void PkgFilesCleanupProc(ClientData clientData, + Tcl_Interp *interp) +{ + PkgFiles *pkgFiles = (PkgFiles *) clientData; + Tcl_HashSearch search; + Tcl_HashEntry *entry; + + while (pkgFiles->names) { + PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; + ckfree(name); + } + entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); + while (entry) { + Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); + entry = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&pkgFiles->table); + ckfree(pkgFiles); + return; +} + +void *TclInitPkgFiles(Tcl_Interp *interp) +{ + /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { + pkgFiles = ckalloc(sizeof(PkgFiles)); + pkgFiles->names = NULL; + Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); + } + return pkgFiles; +} + +void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +{ + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { + const char *name = pkgFiles->names->name; + Tcl_HashTable *table = &pkgFiles->table; + int new; + Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new); + Tcl_Obj *list; + + if (new) { + list = Tcl_NewObj(); + Tcl_SetHashValue(entry, list); + Tcl_IncrRefCount(list); + } else { + list = Tcl_GetHashValue(entry); + } + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); + } +} + #undef Tcl_PkgRequire const char * Tcl_PkgRequire( @@ -276,8 +349,8 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of the file - * generic/tclObj.c. It clearly should not have the value NULL; it + * the definition of tclEmptyStringRep near the top of this file. + * It clearly should not have the value NULL; it * should point to the char tclEmptyString. If we see it having the * value NULL, then somehow we are seeing a Tcl library that isn't * completely initialized, and that's an indicator for the error @@ -293,18 +366,11 @@ Tcl_PkgRequireEx( * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. In particular, it doesn't have a - * proper value for tclEmptyStringRep. The Tcl_Obj system heavily - * depends on the value of tclEmptyStringRep and all of Tcl depends - * (increasingly) on the Tcl_Obj system, we need to correct that flaw - * before making the calls to set the interpreter result to the error - * message. That's the only flaw corrected; other problems with - * initialization of the Tcl library are not remedied, so be very - * careful about adding any other calls here without checking how they - * behave when initialization is incomplete. + * that's not fully initialized. Functions in it may not work + * reliably, so be very careful about adding any other calls here + * without checking how they behave when initialization is incomplete. */ - tclEmptyStringRep = &tclEmptyString; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); @@ -511,7 +577,7 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ - int availStable, satisfies; + int availStable, satisfies; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; @@ -662,9 +728,21 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; - pkgPtr->clientData = versionToProvide; Tcl_Preserve(versionToProvide); + pkgPtr->clientData = versionToProvide; + + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; + if (bestPtr->pkgIndex) { + TclPkgFileSeen(interp, bestPtr->pkgIndex); + } reqPtr->versionToProvide = versionToProvide; Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); @@ -680,6 +758,12 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; + /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgName *pkgName = pkgFiles->names; + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); + reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { Tcl_ResetResult(interp); @@ -883,14 +967,14 @@ TclNRPackageObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "forget", "ifneeded", "names", "prefer", "present", - "provide", "require", "unknown", "vcompare", "versions", - "vsatisfies", NULL + "files", "forget", "ifneeded", "names", "prefer", + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, - PKG_VSATISFIES + PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, newobjc, satisfies; @@ -914,11 +998,37 @@ TclNRPackageObjCmd( return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { + case PKG_FILES: { + PkgFiles *pkgFiles; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } + pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles) { + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + if (entry) { + Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); + } + } + break; + } case PKG_FORGET: { const char *keyString; + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); + if (pkgFiles) { + hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); + if (hPtr) { + Tcl_Obj *obj = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + Tcl_DecrRefCount(obj); + } + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; @@ -933,6 +1043,10 @@ TclNRPackageObjCmd( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -962,7 +1076,7 @@ TclNRPackageObjCmd( } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = Tcl_GetStringFromObj(objv[3], &length); + argv3 = TclGetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -983,6 +1097,10 @@ TclNRPackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } break; } } @@ -993,6 +1111,7 @@ TclNRPackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); + availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -1003,7 +1122,11 @@ TclNRPackageObjCmd( prevPtr->nextPtr = availPtr; } } - argv4 = Tcl_GetStringFromObj(objv[4], &length); + if (iPtr->scriptFile) { + argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1); + } + argv4 = TclGetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } @@ -1125,7 +1248,6 @@ TclNRPackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); - Tcl_IncrRefCount(ov); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); @@ -1175,7 +1297,7 @@ TclNRPackageObjCmd( if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = Tcl_GetStringFromObj(objv[2], &length); + argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { @@ -1368,7 +1490,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpereter that is being deleted. */ + Interp *iPtr) /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1386,6 +1508,10 @@ TclFreePackageInfo( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -1830,7 +1956,7 @@ AddRequirementsToResult( int i, length; for (i = 0; i < reqc; i++) { - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + const char *v = TclGetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { @@ -2043,7 +2169,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if (exact && actualVersion) { + if ((exact&1) && actualVersion) { const char *p = version; int count = 0; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 466d535..96b6962 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -40,7 +40,7 @@ * configuration information. */ -#ifdef TCL_THREADS +#if TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" @@ -105,6 +105,8 @@ static Tcl_Config const cfg[] = { {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, + {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, /* Installation paths to various stuff */ diff --git a/generic/tclPort.h b/generic/tclPort.h index 12a60db..d3f6233 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -24,20 +24,8 @@ #endif #include "tcl.h" -#if !defined(LLONG_MIN) -# ifdef TCL_WIDE_INT_IS_LONG -# define LLONG_MIN LONG_MIN -# else -# ifdef LLONG_BIT -# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) -# else -/* Assume we're on a system with a 64-bit 'long long' type */ -# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) -# endif -# endif -/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ -# define LLONG_MAX (~LLONG_MIN) -#endif - +#define UWIDE_MAX ((Tcl_WideUInt)-1) +#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) +#define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) #endif /* _TCLPORT */ diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index cca13e8..5c6097f 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -22,7 +22,7 @@ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tcl_Preserve calls in effect for + size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in @@ -63,7 +63,7 @@ typedef struct HandleStruct { * ensure that the contents of the handle are * not changed by anyone else. */ #endif - int refCount; /* Number of TclHandlePreserve() calls in + size_t refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; @@ -155,7 +155,7 @@ Tcl_Preserve( refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; - refPtr->freeProc = TCL_STATIC; + refPtr->freeProc = 0; inUse += 1; Tcl_MutexUnlock(&preserveMutex); } @@ -195,7 +195,7 @@ Tcl_Release( continue; } - if (--refPtr->refCount != 0) { + if (refPtr->refCount-- > 1) { Tcl_MutexUnlock(&preserveMutex); return; } @@ -459,7 +459,7 @@ TclHandleRelease( handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 5c68e17..f1822a2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Variables that are part of the [apply] command implementation and which @@ -67,6 +68,22 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; +#define ProcSetIntRep(objPtr, procPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (procPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + } while (0) + +#define ProcGetIntRep(objPtr, procPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The [upvar]/[uplevel] level reference type. Uses the longValue field * to remember the integer value of a parsed #<integer> format. @@ -89,13 +106,31 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -const Tcl_ObjType tclLambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + +#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = (nsObjPtr); \ + Tcl_IncrRefCount((nsObjPtr)); \ + Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + } while (0) + +#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -124,11 +159,10 @@ Tcl_ProcObjCmd( { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; - Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -141,29 +175,21 @@ Tcl_ProcObjCmd( * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -172,31 +198,16 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used @@ -318,7 +329,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (objv[3]->typePtr == &tclProcBodyType) { + if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) { goto done; } @@ -343,7 +354,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + procBody = TclGetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -393,16 +404,17 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; - register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + register Proc *procPtr = NULL; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; - if (bodyPtr->typePtr == &tclProcBodyType) { + ProcGetIntRep(bodyPtr, procPtr); + if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -415,7 +427,6 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -436,6 +447,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -473,12 +485,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -500,29 +509,30 @@ TclCreateProc( } for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; - const char **fieldValues; + int fieldCount, nameLength; + size_t valueLength; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -530,9 +540,11 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + nameLength = Tcl_NumUtfChars(argname, plen); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + const char * value = TclGetString(fieldValues[1]); + valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length); } else { valueLength = 0; } @@ -541,33 +553,28 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -583,7 +590,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -591,7 +598,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -602,17 +608,17 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - int tmpLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, - &tmpLength); + const char *tmpPtr = TclGetString(localPtr->defValuePtr); + size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -632,7 +638,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -646,13 +652,12 @@ TclCreateProc( localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -660,12 +665,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -686,9 +688,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } @@ -724,51 +723,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* @@ -805,7 +768,9 @@ TclObjGetFrame( { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; + const Tcl_ObjIntRep *irPtr; const char *name = NULL; + Tcl_WideInt w; /* * Parse object to figure out which level number to go to. @@ -821,25 +786,34 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { - level = curLevel - level; - result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { + result = -1; + } else { + level = curLevel - level; + result = 1; + } + } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) { + level = irPtr->wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; - result = 1; + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { + if (level < 0 || (level > 0 && name[1] == '-')) { + result = -1; + } else { + Tcl_ObjIntRep ir; + + ir.wideValue = level; + Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); + result = 1; + } } else { result = -1; } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. @@ -850,7 +824,6 @@ TclObjGetFrame( if (result == 0) { level = curLevel - 1; - name = "1"; } if (result != -1) { if (level >= 0) { @@ -863,11 +836,11 @@ TclObjGetFrame( } } } - if (name == NULL) { - name = TclGetString(objPtr); - } } + if (name == NULL) { + name = TclGetString(objPtr); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; @@ -1071,7 +1044,6 @@ ProcWrongNumArgs( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - register Var *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; @@ -1095,23 +1067,26 @@ ProcWrongNumArgs( } Tcl_IncrRefCount(desiredObjs[0]); - defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); - for (i=1 ; i<=numArgs ; i++, defPtr++) { - Tcl_Obj *argObj; - Tcl_Obj *namePtr = localName(framePtr, i-1); - - if (defPtr->value.objPtr != NULL) { - TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); - } else if (defPtr->flags & VAR_IS_ARGS) { - numArgs--; - final = "?arg ...?"; - break; - } else { - argObj = namePtr; - Tcl_IncrRefCount(namePtr); + if (localCt > 0) { + register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + + for (i=1 ; i<=numArgs ; i++, defPtr++) { + Tcl_Obj *argObj; + Tcl_Obj *namePtr = localName(framePtr, i-1); + + if (defPtr->value.objPtr != NULL) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "?arg ...?"; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; } - desiredObjs[i] = argObj; } Tcl_ResetResult(interp); @@ -1156,10 +1131,10 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1322,7 +1297,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1332,6 +1307,8 @@ InitLocalCache( CompiledLocal *localPtr; int new; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr @@ -1399,11 +1376,13 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1578,7 +1557,8 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; /* @@ -1590,7 +1570,6 @@ TclPushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1788,7 +1767,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1922,7 +1901,9 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1938,7 +1919,7 @@ TclProcCompileProc( * are not recompiled, even if things have changed. */ - if (bodyPtr->typePtr == &tclByteCodeType) { + if (codePtr != NULL) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) @@ -1957,11 +1938,12 @@ TclProcCompileProc( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - TclFreeIntRep(bodyPtr); + Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); + codePtr = NULL; } } - if (bodyPtr->typePtr != &tclByteCodeType) { + if (codePtr == NULL) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG @@ -2083,7 +2065,7 @@ MakeProcError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2310,10 +2292,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - - procPtr->refCount++; + ProcSetIntRep(objPtr, procPtr); } return objPtr; @@ -2341,11 +2320,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + ProcGetIntRep(srcPtr, procPtr); - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; - procPtr->refCount++; + ProcSetIntRep(dupPtr, procPtr); } /* @@ -2371,7 +2349,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + + ProcGetIntRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2397,15 +2377,15 @@ DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &tclLambdaType; + + LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void @@ -2413,14 +2393,16 @@ FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - if (procPtr->refCount-- == 1) { + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); + + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; } static int @@ -2441,7 +2423,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to tclLambdaType. + * length is not 2, then it cannot be converted to lambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2582,21 +2564,42 @@ SetLambdaFromAny( } } - Tcl_IncrRefCount(nsObjPtr); - /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to tclLambdaType. + * conversion to lambdaType. */ - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &tclLambdaType; + LambdaSetIntRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } + +Proc * +TclGetLambdaFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **nsObjPtrPtr) +{ + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + + if (procPtr == NULL) { + if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + } + + assert(procPtr != NULL); + if (procPtr->iPtr != (Interp *)interp) { + return NULL; + } + + *nsObjPtrPtr = nsObjPtr; + return procPtr; +} /* *---------------------------------------------------------------------- @@ -2632,7 +2635,6 @@ TclNRApplyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result; @@ -2650,48 +2652,17 @@ TclNRApplyObjCmd( */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &tclLambdaType) { - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } - -#define JOE_EXTENSION 0 -/* - * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT - * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt - * the code. (MS) - */ - -#if JOE_EXTENSION - else { - /* - * Joe English's suggestion to allow cmdNames to function as lambdas. - */ + procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); - Tcl_Obj *elemPtr; - int numElem; - - if ((lambdaPtr->typePtr == &tclCmdNameType) || - (TclListObjGetElements(interp, lambdaPtr, &numElem, - &elemPtr) == TCL_OK && numElem == 1)) { - return Tcl_EvalObjv(interp, objc-1, objv+1, 0); - } - } -#endif - - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + if (procPtr == NULL) { + return TCL_ERROR; } /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. + * Push a call frame for the lambda namespace. + * Note that TclObjInterpProc() will pop it. */ - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; @@ -2764,7 +2735,7 @@ MakeLambdaError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..a781386 --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,957 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +/* + * Autopurge flag. Process-global because of the way Tcl manages child + * processes (see tclPipe.c). + */ + +static int autopurge = 1; /* Autopurge flag. */ + +/* + * Hash tables that keeps track of all child process statuses. Keys are the + * child process ids and resolved pids, values are (ProcessInfo *). + */ + +typedef struct ProcessInfo { + Tcl_Pid pid; /* Process id. */ + int resolvedPid; /* Resolved process id. */ + int purge; /* Purge eventualy. */ + TclProcessWaitStatus status;/* Process status. */ + int code; /* Error code, exit status or signal + number. */ + Tcl_Obj *msg; /* Error message. */ + Tcl_Obj *error; /* Error code. */ +} ProcessInfo; +static Tcl_HashTable infoTablePerPid; +static Tcl_HashTable infoTablePerResolvedPid; +static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(infoTablesMutex) + + /* + * Prototypes for functions defined later in this file: + */ + +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + +void +InitProcessInfo( + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int resolvedPid) /* Resolved process id. */ +{ + info->pid = pid; + info->resolvedPid = resolvedPid; + info->purge = 0; + info->status = TCL_PROCESS_UNCHANGED; + info->code = 0; + info->msg = NULL; + info->error = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeProcessInfo -- + * + * Free the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory deallocated, Tcl_Obj refcount decreased. + * + *---------------------------------------------------------------------- + */ + +void +FreeProcessInfo( + ProcessInfo *info) /* Structure to free. */ +{ + /* + * Free stored Tcl_Objs. + */ + + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); + } + + /* + * Free allocated structure. + */ + + ckfree(info); +} + +/* + *---------------------------------------------------------------------- + * + * RefreshProcessInfo -- + * + * Refresh process info. + * + * Results: + * Nonzero if state changed, else zero. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +int +RefreshProcessInfo( + ProcessInfo *info, /* Structure to refresh. */ + int options /* Options passed to WaitProcessStatus. */ +) +{ + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); + } else { + /* + * No change. + */ + + return 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * WaitProcessStatus -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +WaitProcessStatus( + Tcl_Pid pid, /* Process id. */ + int resolvedPid, /* Resolved process id. */ + int options, /* Options passed to Tcl_WaitPid. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + int waitStatus; + Tcl_Obj *errorStrings[5]; + const char *msg; + + pid = Tcl_WaitPid(pid, &waitStatus, options); + if (pid == 0) { + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; + } else if (WIFEXITED(waitStatus)) { + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; + } +} + + +/* + *---------------------------------------------------------------------- + * + * BuildProcessStatusObj -- + * + * Build a list object with process status. The first element is always + * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. + * In the latter case, the second element is the error message and the + * third element is a Tcl error code (see tclvars). + * + * Results: + * A list object. + * + * Side effects: + * Tcl_Objs are created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +BuildProcessStatusObj( + ProcessInfo *info) +{ + Tcl_Obj *resultObjs[3]; + + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Process still running, return empty obj. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); + resultObjs[1] = info->msg; + resultObjs[2] = info->error; + return Tcl_NewListObj(3, resultObjs); +} + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *list; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * Return the list of all chid process ids. + */ + + list = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); + } + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * Calls RefreshProcessInfo, which can block if -wait switch is given. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *dict; + int index, options = WNOHANG; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + STATUS_WAIT, STATUS_LAST + }; + + while (objc > 1) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (STATUS_WAIT == (enum switches) index) { + options = 0; + } else { + break; + } + } + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); + return TCL_ERROR; + } + + if (objc == 1) { + /* + * Return a dict with all child process statuses. + */ + + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_DecrRefCount(dict); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + Tcl_SetObjResult(interp, dict); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Frees all ProcessInfo structures with their purge flag set. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); + return TCL_ERROR; + } + + /* + * First reap detached procs so that their purge flag is up-to-date. + */ + + Tcl_ReapDetachedProcs(); + + if (objc == 1) { + /* + * Purge all terminated processes. + */ + + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Purge only provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Alters detached process handling by Tcl_ReapDetachedProcs(). + * + *---------------------------------------------------------------------- + */ + +static int +ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + autopurge = !!flag; + } + + /* + * Return current value. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + if (infoTablesInitialized == 0) { + Tcl_MutexLock(&infoTablesMutex); + if (infoTablesInitialized == 0) { + Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); + infoTablesInitialized = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessCreated -- + * + * Called when a child process has been created by Tcl. + * + * Results: + * None. + * + * Side effects: + * Internal structures are updated with a new ProcessInfo. + * + *---------------------------------------------------------------------- + */ + +void +TclProcessCreated( + Tcl_Pid pid) /* Process id. */ +{ + int resolvedPid; + Tcl_HashEntry *entry, *entry2; + int isNew; + ProcessInfo *info; + + /* + * Get resolved pid first. + */ + + resolvedPid = TclpGetPid(pid); + + Tcl_MutexLock(&infoTablesMutex); + + /* + * Create entry in pid table. + */ + + entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); + if (!isNew) { + /* + * Pid was reused, free old info and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(resolvedPid)); + if (entry2) Tcl_DeleteHashEntry(entry2); + FreeProcessInfo(info); + } + + /* + * Allocate and initialize info structure. + */ + + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + InitProcessInfo(info, pid, resolvedPid); + + /* + * Add entry to tables. + */ + + Tcl_SetHashValue(entry, info); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), + &isNew); + Tcl_SetHashValue(entry, info); + + Tcl_MutexUnlock(&infoTablesMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessWait -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * Completed process info structures are purged immediately (autopurge on) + * or eventually (autopurge off). + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +TclProcessWait( + Tcl_Pid pid, /* Process id. */ + int options, /* Options passed to WaitProcessStatus. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + Tcl_HashEntry *entry; + ProcessInfo *info; + TclProcessWaitStatus result; + + /* + * First search for pid in table. + */ + + Tcl_MutexLock(&infoTablesMutex); + entry = Tcl_FindHashEntry(&infoTablePerPid, pid); + if (!entry) { + /* + * Unknown process, just call WaitProcessStatus and return. + */ + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * No change, stop there. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Set return values. + */ + + result = info->status; + if (codePtr) *codePtr = info->code; + if (msgObjPtr) *msgObjPtr = info->msg; + if (errorObjPtr) *errorObjPtr = info->error; + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + + if (autopurge) { + /* + * Purge now. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. + */ + + info->purge = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + return result; +} diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index cfe6388..a01ace3 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include <assert.h> /* *---------------------------------------------------------------------- @@ -64,7 +65,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this @@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = { NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; + +#define RegexpSetIntRep(objPtr, rePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (rePtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (rePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ + } while (0) + +#define RegexpGetIntRep(objPtr, rePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclRegexpType); \ + (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -510,9 +528,9 @@ Tcl_RegExpMatchObj( */ if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB)) + TCL_REG_ADVANCED | TCL_REG_NOSUB)) && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { - return -1; + return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); @@ -580,14 +598,9 @@ Tcl_GetRegExpFromObj( TclRegexp *regexpPtr; const char *pattern; - /* - * This is OK because we only actually interpret this value properly as a - * TclRegexp* when the type is tclRegexpType. - */ + RegexpGetIntRep(objPtr, regexpPtr); - regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; - - if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { + if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); @@ -595,21 +608,7 @@ Tcl_GetRegExpFromObj( return NULL; } - /* - * Add a reference to the regexp so it will persist even if it is - * pushed out of the current thread's regexp cache. This reference - * will be removed when the object's internal rep is freed. - */ - - regexpPtr->refCount++; - - /* - * Free the old representation and set our type. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; - objPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(objPtr, regexpPtr); } return (Tcl_RegExp) regexpPtr; } @@ -679,7 +678,7 @@ TclRegAbout( resultObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); + Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. @@ -756,7 +755,11 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpRepPtr; + + RegexpGetIntRep(objPtr, regexpRepPtr); + + assert(regexpRepPtr != NULL); /* * If this is the last reference to the regexp, free it. @@ -765,7 +768,6 @@ FreeRegexpInternalRep( if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } - objPtr->typePtr = NULL; } /* @@ -790,11 +792,13 @@ DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpPtr; + + RegexpGetIntRep(srcPtr, regexpPtr); + + assert(regexpPtr != NULL); - regexpPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(copyPtr, regexpPtr); } /* diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index 3b2433e..a263dfd 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -37,7 +37,7 @@ typedef struct TclRegexp { * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - int refCount; /* Count of number of references to this + size_t refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; diff --git a/generic/tclResult.c b/generic/tclResult.c index 9d0714c..a5ec4be 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,9 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -230,6 +232,7 @@ Tcl_DiscardInterpState( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SaveResult void Tcl_SaveResult( @@ -461,6 +464,7 @@ Tcl_SetResult( ResetObjResult(iPtr); } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -483,18 +487,21 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { + Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + return Tcl_GetString(iPtr->objResultPtr); +#else /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ - Interp *iPtr = (Interp *) interp; - if (*(iPtr->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } return iPtr->result; +#endif } /* @@ -536,6 +543,7 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); +#ifndef TCL_NO_DEPRECATED /* * Reset the string result since we just set the result object. */ @@ -550,6 +558,7 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif } /* @@ -578,6 +587,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED Tcl_Obj *objResultPtr; int length; @@ -604,6 +614,7 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->result[0] = 0; } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -640,23 +651,6 @@ Tcl_AppendResultVA( } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); - - /* - * Strictly we should call Tcl_GetStringResult(interp) here to make sure - * that interp->result is correct according to the old contract, but that - * makes the performance of much code (e.g. in Tk) absolutely awful. So we - * leave it out; code that really wants interp->result can just insert the - * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] - */ - -#ifdef USE_INTERP_RESULT - /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... - */ - - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ } /* @@ -722,6 +716,21 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = TclGetString(iPtr->objResultPtr); + if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); + } + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); +#else char *dst; int size; int flags; @@ -765,6 +774,7 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -786,6 +796,7 @@ Tcl_AppendElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer( Interp *iPtr, /* Interpreter whose result is being set up. */ @@ -846,6 +857,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -875,6 +887,7 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -884,6 +897,7 @@ Tcl_FreeResult( iPtr->freeProc = 0; } +#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -913,6 +927,7 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -923,6 +938,7 @@ Tcl_ResetResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -982,11 +998,11 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { ckfree(objResultPtr->bytes); } - objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); @@ -1276,10 +1292,8 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - int infoLen; - - (void) TclGetStringFromObj(valuePtr, &infoLen); - if (infoLen) { + (void) TclGetString(valuePtr); + if (valuePtr->length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1382,13 +1396,11 @@ TclMergeReturnOptions( Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - const char *opt = TclGetStringFromObj(objv[0], &optLen); - int compareLen; - const char *compare = - TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); - if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; diff --git a/generic/tclScan.c b/generic/tclScan.c index 7f71262..745f05b 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include "tommath.h" /* * Flag values used by Tcl_ScanObjCmd. @@ -415,14 +416,7 @@ ValidateFormat( case 'x': case 'X': case 'b': - break; case 'u': - if (flags & SCAN_BIG) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unsigned bignum scans are invalid", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); - goto error; - } break; /* * Bracket terms need special checking @@ -889,7 +883,7 @@ Tcl_ScanObjCmd( i = (int)sch; #if TCL_UTF_MAX == 4 if (!offset) { - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); } #endif @@ -932,19 +926,42 @@ Tcl_ScanObjCmd( } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ + wideValue = WIDE_MAX; if (TclGetString(objPtr)[0] == '-') { - wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ + wideValue = WIDE_MIN; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { - sprintf(buf, "%" TCL_LL_MODIFIER "u", - (Tcl_WideUInt)wideValue); + sprintf(buf, "%" TCL_LL_MODIFIER "u", wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); } - } else if (!(flags & SCAN_BIG)) { + } else if (flags & SCAN_BIG) { + if (flags & SCAN_UNSIGNED) { + mp_int big; + int code = Tcl_GetBignumFromObj(interp, objPtr, &big); + + if (code == TCL_OK) { + if (mp_isneg(&big)) { + code = TCL_ERROR; + } + mp_clear(&big); + } + + if (code == TCL_ERROR) { + if (objs != NULL) { + ckfree(objs); + } + Tcl_DecrRefCount(objPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", + "BADUNSIGNED",NULL); + return TCL_ERROR; + } + } + } else { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; @@ -956,7 +973,7 @@ Tcl_ScanObjCmd( sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetLongObj(objPtr, value); + TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; @@ -992,8 +1009,10 @@ Tcl_ScanObjCmd( double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - if (objPtr->typePtr == &tclDoubleType) { - dvalue = objPtr->internalRep.doubleValue; + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(objPtr, &tclDoubleType); + if (irPtr) { + dvalue = irPtr->doubleValue; } else #endif { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 5d601e4..a46b29a 100644..100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,13 +18,6 @@ #include <math.h> /* - * Define KILL_OCTAL to suppress interpretation of numbers with leading zero - * as octal. (Ceterum censeo: numeros octonarios delendos esse.) - */ - -#undef KILL_OCTAL - -/* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. @@ -489,7 +482,7 @@ TclParseNumber( { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, - ZERO_O, ZERO_B, BINARY, + ZERO_O, ZERO_B, ZERO_D, BINARY, HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, @@ -546,6 +539,20 @@ TclParseNumber( */ if (bytes == NULL) { + if (interp == NULL && endPtrPtr == NULL) { + if (objPtr->typePtr == &tclDictType) { + /* A dict can never be a (single) number */ + return TCL_ERROR; + } + if (objPtr->typePtr == &tclListType) { + int length; + /* A list can only be a (single) number if its length == 1 */ + TclListObjLength(NULL, objPtr, &length); + if (length != 1) { + return TCL_ERROR; + } + } + } bytes = TclGetString(objPtr); } @@ -657,7 +664,11 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef KILL_OCTAL + if (c == 'd' || c == 'D') { + state = ZERO_D; + break; + } +#ifdef TCL_NO_DEPRECATED goto decimal; #endif /* FALLTHROUGH */ @@ -700,7 +711,7 @@ TclParseNumber( || (octalSignificandWide > (~(Tcl_WideUInt)0 >> shift)))) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } @@ -740,7 +751,7 @@ TclParseNumber( goto endgame; } -#ifndef KILL_OCTAL +#ifndef TCL_NO_DEPRECATED /* * Scanned a number with a leading zero that contains an 8, 9, @@ -817,7 +828,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -858,7 +869,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -873,13 +884,23 @@ TclParseNumber( state = BINARY; break; + case ZERO_D: + if (c == '0') { + numTrailZeros++; + } else if ( ! isdigit(UCHAR(c))) { + goto endgame; + } + state = DECIMAL; + flags |= TCL_PARSE_INTEGER_ONLY; + /* FALLTHROUGH */ + case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED decimal: #endif acceptState = state; @@ -1169,6 +1190,7 @@ TclParseNumber( case ZERO_X: case ZERO_O: case ZERO_B: + case ZERO_D: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: @@ -1192,7 +1214,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1213,7 +1235,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1234,7 +1256,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (MOST_BITS + signum) >> shift)) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { @@ -1246,32 +1268,18 @@ TclParseNumber( } } if (!octalSignificandOverflow) { - if (octalSignificandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&octalSignificandBig, + if (octalSignificandWide > (MOST_BITS + signum)) { + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; } else { - objPtr->internalRep.longValue = - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; } } } @@ -1289,36 +1297,22 @@ TclParseNumber( &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if (significandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&significandBig, + if (significandWide > MOST_BITS+signum) { + TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) significandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; } else { - objPtr->internalRep.longValue = - (long) significandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; } } } @@ -1463,7 +1457,7 @@ AccumulateDecimalDigit( * bignum and fall through into the bignum case. */ - TclBNInitBignumFromWideUInt(bignumRepPtr, w); + TclInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. @@ -1606,7 +1600,7 @@ MakeLowPrecisionDouble( * call MakeHighPrecisionDouble to do it the hard way. */ - TclBNInitBignumFromWideUInt(&significandBig, significand); + TclInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); @@ -3293,7 +3287,7 @@ ShorteningBignumConversionPowD( * mminus = 5**m5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_init_set_int(&mminus, 1); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3480,7 +3474,7 @@ StrictBignumConversionPowD( * b = bw * 2**b2 * 5**b5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3688,7 +3682,7 @@ ShorteningBignumConversion( * S = 2**s2 * 5*s5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -3901,7 +3895,7 @@ StrictBignumConversion( */ mp_init_multi(&temp, &dig, NULL); - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -4549,7 +4543,7 @@ Tcl_InitBignumFromDouble( return TCL_ERROR; } - fract = frexp(d,&expt); + fract = frexp(d, &expt); if (expt <= 0) { mp_init(b); mp_zero(b); @@ -4557,7 +4551,7 @@ Tcl_InitBignumFromDouble( Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - TclBNInitBignumFromWideInt(b, w); + TclInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { @@ -4703,7 +4697,7 @@ TclCeil( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclFloor(&b); } else { @@ -4760,7 +4754,7 @@ TclFloor( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclCeil(&b); } else { @@ -4889,7 +4883,7 @@ Pow10TimesFrExp( * Multiply by 10**exponent. */ - retval = frexp(retval * pow10vals[exponent&0xf], &j); + retval = frexp(retval * pow10vals[exponent & 0xf], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<<i)) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 1b35c56..7be74ca 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -38,15 +38,7 @@ #include "tommath.h" #include "tclStringRep.h" -/* - * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. - * This is an escape hatch in case the changes have some unexpected unwelcome - * impact on performance. If things go well, this mechanism can go away when - * post-8.6 development begins. - */ - -#define COMPAT 0 - +#include "assert.h" /* * Prototypes for functions defined later in this file: */ @@ -145,12 +137,12 @@ GrowStringBuffer( char *ptr = NULL; int attempt; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - if (attempt >= 0) { + if (needed <= INT_MAX / 2) { + attempt = 2 * needed; ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { @@ -199,8 +191,8 @@ GrowUnicodeBuffer( * Subsequent appends - apply the growth algorithm. */ - attempt = 2 * needed; - if (attempt >= 0 && attempt <= STRING_MAXCHARS) { + if (needed <= STRING_MAXCHARS / 2) { + attempt = 2 * needed; ptr = stringAttemptRealloc(stringPtr, attempt); } if (ptr == NULL) { @@ -418,16 +410,26 @@ Tcl_GetCharLength( int numChars; /* + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* * Optimize the case where we're really dealing with a bytearray object; * we don't need to convert to a string to perform the get-length operation. * - * NOTE that we do not need the bytearray to be "pure". A ByteArray value - * with a string rep cannot be trusted to represent the same value as the - * string rep, but it *can* be trusted to have the same character length - * as the string rep, which is all this routine cares about. + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. */ - if (objPtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(objPtr)) { int length; (void) Tcl_GetByteArrayFromObj(objPtr, &length); @@ -449,20 +451,50 @@ Tcl_GetCharLength( if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; + } + return numChars; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckEmptyString -- + * + * Determine whether the string value of an object is or would be the + * empty string, without generating a string representation. + * + * Results: + * Returns 1 if empty, 0 if not, and -1 if unknown. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclCheckEmptyString( + Tcl_Obj *objPtr) +{ + int length = -1; -#if COMPAT - if (numChars < objPtr->length) { - /* - * Since we've just computed the number of chars, and not all UTF - * chars are 1-byte long, go ahead and populate the unicode - * string. - */ + if (objPtr->bytes == &tclEmptyString) { + return TCL_EMPTYSTRING_YES; + } - FillUnicodeRep(objPtr); - } -#endif + if (TclListObjIsCanonical(objPtr)) { + Tcl_ListObjLength(NULL, objPtr, &length); + return length == 0; } - return numChars; + + if (TclIsPureDict(objPtr)) { + Tcl_DictObjSize(NULL, objPtr, &length); + return length == 0; + } + + if (objPtr->bytes == NULL) { + return TCL_EMPTYSTRING_UNKNOWN; + } + return objPtr->length == 0; } /* @@ -470,8 +502,9 @@ Tcl_GetCharLength( * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. The index - * is assumed to be in the appropriate range. + * Get the index'th Unicode character from the String object. If index + * is out of range or it references a low surrogate preceded by a high + * surrogate, the result = -1; * * Results: * Returns the index'th Unicode character in the Object. @@ -482,24 +515,31 @@ Tcl_GetCharLength( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ int index) /* Get the index'th Unicode character. */ { String *stringPtr; + int ch, length; + + if (index < 0) { + return -1; + } /* * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the indexing operation. + * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } - return (Tcl_UniChar) bytes[index]; + return (int) bytes[index]; } /* @@ -523,7 +563,28 @@ Tcl_GetUniChar( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - return stringPtr->unicode[index]; + + if (index >= stringPtr->numChars) { + return -1; + } + ch = stringPtr->unicode[index]; +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x400) { + if ((index > 0) + && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) { + ch = -1; /* low surrogate preceded by high surrogate */ + } + } else if ((++index < stringPtr->numChars) + && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) { + /* high surrogate followed by low surrogate */ + ch = (((ch & 0x3FF) << 10) | + (stringPtr->unicode[index] & 0x3FF)) + 0x10000; + } + } +#endif + return ch; } /* @@ -545,6 +606,8 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetUnicode Tcl_UniChar * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string @@ -552,6 +615,7 @@ Tcl_GetUnicode( { return Tcl_GetUnicodeFromObj(objPtr, NULL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -623,17 +687,27 @@ Tcl_GetRange( { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; + int length; + + if (first < 0) { + first = 0; + } /* * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the substring operation. + * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - return Tcl_NewByteArrayObj(bytes+first, last-first+1); + if (last >= length) { + last = length - 1; + } + if (last < first) { + return Tcl_NewObj(); + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); } /* @@ -652,6 +726,12 @@ Tcl_GetRange( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { + if (last >= stringPtr->numChars) { + last = stringPtr->numChars - 1; + } + if (last < first) { + return Tcl_NewObj(); + } newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); /* @@ -666,19 +746,25 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - -#if TCL_UTF_MAX == 4 - /* See: bug [11ae2be95dac9417] */ - if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) { - ++first; - } - if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) - && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { - ++last; - } + if (last > stringPtr->numChars) { + last = stringPtr->numChars; + } + if (last < first) { + return Tcl_NewObj(); + } +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + ++first; + } + if ((last + 1 < stringPtr->numChars) + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + ++last; + } #endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); + return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -794,7 +880,7 @@ Tcl_SetObjLength( /* * Need to enlarge the buffer. */ - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = ckalloc(length + 1); } else { objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); @@ -900,7 +986,7 @@ Tcl_AttemptSetObjLength( char *newBytes; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { newBytes = attemptckalloc(length + 1); } else { newBytes = attemptckrealloc(objPtr->bytes, length + 1); @@ -1188,11 +1274,7 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1233,52 +1315,58 @@ Tcl_AppendObjToObj( * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == tclEmptyStringRep) { + if (appendObjPtr->bytes == &tclEmptyString) { return; } /* * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects don't have string reps; if - * it did, then appending the byte arrays together could well lose - * information; this is a special-case optimization only. + * Note that we only do this when the objects are pure so that the + * bytearray faithfully represent the true value; Otherwise appending the + * byte arrays together could lose information; */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) && TclIsPureByteArray(appendObjPtr)) { - /* * You might expect the code here to be * * 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. + * and essentially all of the time that would be fine. However, it + * would run into trouble in the case where objPtr and appendObjPtr + * point to the same thing. That may never be a good idea. It seems to + * violate Copy On Write, and we don't have any tests for the + * situation, since making any Tcl commands that call + * Tcl_AppendObjToObj() do that appears impossible (They honor Copy On + * Write!). For the sake of extensions that go off into that realm, + * though, here's a more complex approach that can handle all the + * cases. + * + * First, get the lengths. */ - /* Get lengths */ int lengthSrc; (void) Tcl_GetByteArrayFromObj(objPtr, &length); (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - /* Grow buffer enough for the append */ + /* + * Grow buffer enough for the append. + */ + TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); - /* Reset objPtr back to the original value */ + /* + * Reset objPtr back to the original value. + */ + Tcl_SetByteArrayLength(objPtr, length); /* - * Now do the append knowing that buffer growth cannot cause - * any trouble. + * Now do the append knowing that buffer growth cannot cause any + * trouble. */ TclAppendBytesToByteArray(objPtr, @@ -1298,11 +1386,7 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ @@ -1330,16 +1414,13 @@ Tcl_AppendObjToObj( numChars = stringPtr->numChars; if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); + appendNumChars = appendStringPtr->numChars; } AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0 -#if COMPAT - && appendNumChars == length -#endif - ) { + if (numChars >= 0 && appendNumChars >= 0) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1463,14 +1544,6 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } - -#if COMPAT - /* - * Invalidate the unicode rep. - */ - - stringPtr->hasUnicode = 0; -#endif } /* @@ -1831,6 +1904,11 @@ Tcl_AppendFormatToObj( width = 0; if (isdigit(UCHAR(ch))) { width = strtoul(format, &end, 10); + if (width < 0) { + msg = overflow; + errCode = "OVERFLOW"; + goto errorMsg; + } format = end; step = TclUtfToUniChar(format, &ch); } else if (ch == '*') { @@ -1913,6 +1991,25 @@ Tcl_AppendFormatToObj( useWide = 1; #endif } + } else if (ch == 'I') { + if ((format[1] == '6') && (format[2] == '4')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; +#endif + } else if ((format[1] == '3') && (format[2] == '2')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); + } else { + format += step; + step = TclUtfToUniChar(format, &ch); + } + } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') + || (ch == 'L')) { + format += step; + step = TclUtfToUniChar(format, &ch); + useBig = 1; } format += step; @@ -1944,13 +2041,17 @@ Tcl_AppendFormatToObj( } break; case 'c': { - char buf[TCL_UTF_MAX]; + char buf[4]; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); + if (!length) { + /* Special case for handling upper surrogates. */ + length = Tcl_UniCharToUtf(-1, buf); + } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -1958,13 +2059,9 @@ Tcl_AppendFormatToObj( } case 'u': - if (useBig) { - msg = "unsigned bignum format is invalid"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } case 'd': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -1975,53 +2072,58 @@ Tcl_AppendFormatToObj( mp_int big; int toAppend, isNegative = 0; +#ifndef TCL_WIDE_INT_IS_LONG + if (ch == 'p') { + useWide = 1; + } +#endif if (useBig) { + int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - isNegative = (mp_cmp_d(&big, 0) == MP_LT); + cmpResult = mp_cmp_d(&big, 0); + isNegative = (cmpResult == MP_LT); + if (cmpResult == MP_EQ) gotHash = 0; + if (ch == 'u') { + if (isNegative) { + mp_clear(&big); + msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; + goto errorMsg; + } else { + ch = 'd'; + } + } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { - Tcl_Obj *objPtr; - - if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { - goto error; - } - mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - Tcl_GetWideIntFromObj(NULL, objPtr, &w); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { + goto error; } isNegative = (w < (Tcl_WideInt) 0); + if (w == (Tcl_WideInt) 0) gotHash = 0; #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { - Tcl_Obj *objPtr; - - if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { - goto error; - } - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &l); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { + goto error; } else { - l = Tcl_WideAsLong(w); + l = (long) w; } if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } segment = Tcl_NewObj(); @@ -2035,18 +2137,15 @@ Tcl_AppendFormatToObj( segmentLimit -= 1; } - if (gotHash) { + if (gotHash || (ch == 'p')) { switch (ch) { case 'o': - Tcl_AppendToObj(segment, "0", 1); - segmentLimit -= 1; - precision--; - break; - case 'X': - Tcl_AppendToObj(segment, "0X", 2); + Tcl_AppendToObj(segment, "0o", 2); segmentLimit -= 2; break; + case 'p': case 'x': + case 'X': Tcl_AppendToObj(segment, "0x", 2); segmentLimit -= 2; break; @@ -2054,6 +2153,14 @@ Tcl_AppendFormatToObj( Tcl_AppendToObj(segment, "0b", 2); segmentLimit -= 2; break; +#if TCL_MAJOR_VERSION < 9 + case 'd': + if (gotZero) { + Tcl_AppendToObj(segment, "0d", 2); + segmentLimit -= 2; + } + break; +#endif } } @@ -2125,6 +2232,7 @@ Tcl_AppendFormatToObj( case 'u': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -2190,7 +2298,7 @@ Tcl_AppendFormatToObj( * Need to be sure zero becomes "0", not "". */ - if ((numDigits == 0) && !((ch == 'o') && gotHash)) { + if (numDigits == 0) { numDigits = 1; } pure = Tcl_NewObj(); @@ -2257,6 +2365,8 @@ Tcl_AppendFormatToObj( break; } + case 'a': + case 'A': case 'e': case 'E': case 'f': @@ -2325,6 +2435,12 @@ Tcl_AppendFormatToObj( errCode = "OVERFLOW"; goto errorMsg; } + if (ch == 'A') { + char *p = TclGetString(segment) + 1; + *p = 'x'; + p = strchr(p, 'P'); + if (p) *p = 'p'; + } break; } default: @@ -2401,7 +2517,7 @@ Tcl_AppendFormatToObj( /* *--------------------------------------------------------------------------- * - * Tcl_Format-- + * Tcl_Format -- * * Results: * A refcount zero Tcl_Obj. @@ -2512,6 +2628,7 @@ AppendPrintfToObjVA( case 'u': case 'd': case 'o': + case 'p': case 'x': case 'X': seekingConversion = 0; @@ -2525,15 +2642,30 @@ AppendPrintfToObjVA( Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; + case 2: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + va_arg(argList, Tcl_WideInt))); + break; + case 3: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( + va_arg(argList, mp_int *))); + break; } break; + case 'a': + case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': + if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - va_arg(argList, double))); + (double)va_arg(argList, long double))); + } else { + Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( + va_arg(argList, double))); + } seekingConversion = 0; break; case '*': @@ -2553,9 +2685,35 @@ AppendPrintfToObjVA( gotPrecision = 1; p++; break; - /* TODO: support for wide (and bignum?) arguments */ case 'l': - size = 1; + ++size; + p++; + break; + case 't': + case 'z': + if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'j': + case 'q': + size = 2; + p++; + break; + case 'I': + if (p[1]=='6' && p[2]=='4') { + p += 2; + size = 2; + } else if (p[1]=='3' && p[2]=='2') { + p += 2; + } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'L': + size = 3; p++; break; case 'h': @@ -2662,17 +2820,894 @@ TclGetStringStorage( *sizePtr = stringPtr->allocated; return objPtr->bytes; } + +/* + *--------------------------------------------------------------------------- + * + * TclStringRepeat -- + * + * Performs the [string repeat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringRepeat( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int count, + int flags) +{ + Tcl_Obj *objResultPtr; + int inPlace = flags & TCL_STRING_IN_PLACE; + int length = 0, unichar = 0, done = 1; + int binary = TclIsPureByteArray(objPtr); + + /* assert (count >= 2) */ + + /* + * Analyze to determine what representation result should be. + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + if (!binary) { + if (objPtr->typePtr == &tclStringType) { + String *stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode) { + unichar = 1; + } + } + } + + if (binary) { + /* Result will be pure byte array. Pre-size it */ + Tcl_GetByteArrayFromObj(objPtr, &length); + } else if (unichar) { + /* Result will be pure Tcl_UniChar array. Pre-size it. */ + Tcl_GetUnicodeFromObj(objPtr, &length); + } else { + /* Result will be concat of string reps. Pre-size it. */ + Tcl_GetStringFromObj(objPtr, &length); + } + + if (length == 0) { + /* Any repeats of empty is empty. */ + return objPtr; + } + + if (count > INT_MAX/length) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + + if (binary) { + /* Efficiently produce a pure byte array result */ + objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? + Tcl_DuplicateObj(objPtr) : objPtr; + + Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ + Tcl_SetByteArrayLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + TclAppendBytesToByteArray(objResultPtr, + Tcl_GetByteArrayFromObj(objResultPtr, NULL), + (count - done) * length); + } else if (unichar) { + /* + * Efficiently produce a pure Tcl_UniChar array result. + */ + + if (!inPlace || Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + } else { + TclInvalidateStringRep(objPtr); + objResultPtr = objPtr; + } + + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(count*length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + (count - done) * length); + } else { + /* + * Efficiently concatenate string reps. + */ + + if (!inPlace || Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + } else { + TclFreeIntRep(objPtr); + objResultPtr = objPtr; + } + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %u bytes", + count*length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + (count - done) * length); + } + return objResultPtr; +} + /* *--------------------------------------------------------------------------- * - * TclStringObjReverse -- + * TclStringCat -- + * + * Performs the [string cat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringCat( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[], + int flags) +{ + Tcl_Obj *objResultPtr, * const *ov; + int oc, length = 0, binary = 1; + int allowUniChar = 1, requestUniChar = 0; + int first = objc - 1; /* Index of first value possibly not empty */ + int last = 0; /* Index of last value possibly not empty */ + int inPlace = flags & TCL_STRING_IN_PLACE; + + /* assert ( objc >= 0 ) */ + + if (objc <= 1) { + /* Only one or no objects; return first or empty */ + return objc ? objv[0] : Tcl_NewObj(); + } + + /* assert ( objc >= 2 ) */ + + /* + * Analyze to determine what representation result should be. + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + ov = objv, oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + if (TclIsPureByteArray(objPtr)) { + allowUniChar = 0; + } else if (objPtr->bytes) { + /* Value has a string rep. */ + if (objPtr->length) { + /* + * Non-empty string rep. Not a pure bytearray, so we won't + * create a pure bytearray. + */ + + binary = 0; + if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + /* Prevent shimmer of non-string types. */ + allowUniChar = 0; + } + } + } else { + /* assert (objPtr->typePtr != NULL) -- stork! */ + binary = 0; + if (objPtr->typePtr == &tclStringType) { + /* Have a pure Unicode value; ask to preserve it */ + requestUniChar = 1; + } else { + /* Have another type; prevent shimmer */ + allowUniChar = 0; + } + } + } while (--oc && (binary || allowUniChar)); + + if (binary) { + /* + * Result will be pure byte array. Pre-size it + */ + + int numBytes; + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to count bytes for the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + + if (numBytes) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } + } while (--oc); + } else if (allowUniChar && requestUniChar) { + /* + * Result will be pure Tcl_UniChar array. Pre-size it. + */ + + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int numChars; + + Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + if (numChars) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numChars > INT_MAX - length) { + goto overflow; + } + length += numChars; + } + } + } while (--oc); + } else { + /* Result will be concat of string reps. Pre-size it. */ + ov = objv; oc = objc; + do { + Tcl_Obj *pendingPtr = NULL; + + /* + * Loop until a possibly non-empty value is reached. + * Keep string rep generation pending when possible. + */ + + do { + /* assert ( pendingPtr == NULL ) */ + /* assert ( length == 0 ) */ + + Tcl_Obj *objPtr = *ov++; + + if (objPtr->bytes == NULL) { + /* No string rep; Take the chance we can avoid making it */ + pendingPtr = objPtr; + } else { + Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */ + } + } while (--oc && (length == 0) && (pendingPtr == NULL)); + + /* + * Either we found a possibly non-empty value, and we remember + * this index as the first and last such value so far seen, + * or (oc == 0) and all values are known empty, + * so first = last = objc - 1 signals the right quick return. + */ + + first = last = objc - oc - 1; + + if (oc && (length == 0)) { + int numBytes; + + /* assert ( pendingPtr != NULL ) */ + + /* + * There's a pending value followed by more values. Loop over + * remaining values generating strings until a non-empty value + * is found, or the pending value gets its string generated. + */ + + do { + Tcl_Obj *objPtr = *ov++; + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); + + if (numBytes) { + last = objc -oc -1; + } + if (oc || numBytes) { + Tcl_GetStringFromObj(pendingPtr, &length); + } + if (length == 0) { + if (numBytes) { + first = last; + } + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } while (oc && (length == 0)); + + while (oc) { + int numBytes; + Tcl_Obj *objPtr = *ov++; + + /* assert ( length > 0 && pendingPtr == NULL ) */ + + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + if (numBytes) { + last = objc - oc; + if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + --oc; + } + } + + if (last <= first /*|| length == 0 */) { + /* Only one non-empty value or zero length; return first */ + /* NOTE: (length == 0) implies (last <= first) */ + return objv[first]; + } + + objv += first; objc = (last - first + 1); + + if (binary) { + /* Efficiently produce a pure byte array result */ + unsigned char *dst; + + /* + * Broken interface! Byte array value routines offer no way to handle + * failure to allocate enough space. Following stanza may panic. + */ + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + Tcl_GetByteArrayFromObj(objResultPtr, &start); + dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; + } else { + objResultPtr = Tcl_NewByteArrayObj(NULL, length); + dst = Tcl_SetByteArrayLength(objResultPtr, length); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to copy bytes from the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + int more; + unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); + memcpy(dst, src, (size_t) more); + dst += more; + } + } + } else if (allowUniChar && requestUniChar) { + /* Efficiently produce a pure Tcl_UniChar array result */ + Tcl_UniChar *dst; + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + + /* Ugly interface! Force resize of the unicode array. */ + Tcl_GetUnicodeFromObj(objResultPtr, &start); + Tcl_InvalidateStringRep(objResultPtr); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetUnicode(objResultPtr) + start; + } else { + Tcl_UniChar ch = 0; + + /* Ugly interface! No scheme to init array size. */ + objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetUnicode(objResultPtr); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + memcpy(dst, src, more * sizeof(Tcl_UniChar)); + dst += more; + } + } + } else { + /* Efficiently concatenate string reps */ + char *dst; + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + + Tcl_GetStringFromObj(objResultPtr, &start); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetString(objResultPtr) + start; + + /* assert ( length > start ) */ + TclFreeIntRep(objResultPtr); + } else { + objResultPtr = Tcl_NewObj(); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetString(objResultPtr); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + char *src = Tcl_GetStringFromObj(objPtr, &more); + + memcpy(dst, src, (size_t) more); + dst += more; + } + } + /* Must NUL-terminate! */ + *dst = '\0'; + } + return objResultPtr; + + overflow: + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringCmp -- + * Compare two Tcl_Obj values as strings. + * + * Results: + * Like memcmp, return -1, 0, or 1. + * + * Side effects: + * String representations may be generated. Internal representation may + * be changed. + * + *--------------------------------------------------------------------------- + */ + +int TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length */ +{ + char *s1, *s2; + int empty, length, match, s1len, s2len; + memCmpFn_t memCmpFn; + + if ((reqlength == 0) || (value1Ptr == value2Ptr)) { + /* + * Always match at 0 chars of if it is the same obj. + */ + match = 0; + } else { + + if (!nocase && TclIsPureByteArray(value1Ptr) + && TclIsPureByteArray(value2Ptr)) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ + + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if ((value1Ptr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. + */ + + if (nocase) { + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + } else { + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == value1Ptr->length) + && (value1Ptr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { + s1 = value1Ptr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; + } else { + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } + } + } + } else { + if ((empty = TclCheckEmptyString(value1Ptr)) > 0) { + switch (TclCheckEmptyString(value2Ptr)) { + case -1: + s1 = 0; + s1len = 0; + s2 = TclGetStringFromObj(value2Ptr, &s2len); + break; + case 0: + match = -1; + goto matchdone; + case 1: + default: /* avoid warn: `s2` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else if (TclCheckEmptyString(value2Ptr) > 0) { + switch (empty) { + case -1: + s2 = 0; + s2len = 0; + s1 = TclGetStringFromObj(value1Ptr, &s1len); + break; + case 0: + match = 1; + goto matchdone; + case 1: + default: /* avoid warn: `s1` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else { + s1 = TclGetStringFromObj(value1Ptr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + } + if (!nocase && checkEq) { + /* + * When we have equal-length we can check only for + * (in)equality. We can use memcmp in all (n)eq cases because + * we don't need to worry about lexical LE/BE variance. + */ + + memCmpFn = memcmp; + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use + * memcmp() as that is unsafe with any string containing NUL + * (\xC0\x80 in Tcl's utf rep). We can use the more efficient + * TclpUtfNcmp2 if we are case-sensitive and no specific + * length was requested. + */ + + if ((reqlength < 0) && !nocase) { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } else { + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = (memCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + } + + length = (s1len < s2len) ? s1len : s2len; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + if (checkEq && (s1len != s2len)) { + match = 1; /* This will be reversed below. */ + } else { + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + + match = memCmpFn(s1, s2, (size_t) length); + } + if ((match == 0) && (reqlength > length)) { + match = s1len - s2len; + } + match = (match > 0) ? 1 : (match < 0) ? -1 : 0; + } + matchdone: + return match; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringFirst -- + * + * Implements the [string first] operation. + * + * Results: + * If needle is found as a substring of haystack, the index of the + * first instance of such a find is returned. If needle is not present + * as a substring of haystack, -1 is returned. + * + * Side effects: + * needle and haystack may have their Tcl_ObjType changed. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringFirst( + Tcl_Obj *needle, + Tcl_Obj *haystack, + int start) +{ + int lh, ln = Tcl_GetCharLength(needle); + + if (start < 0) { + start = 0; + } + if (ln == 0) { + /* We don't find empty substrings. Bizarre! + * Whenever this routine is turned into a proper substring + * finder, change to `return start` after limits imposed. */ + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *end, *try, *bh; + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + /* Find bytes in bytes */ + bh = Tcl_GetByteArrayFromObj(haystack, &lh); + end = bh + lh; + + try = bh + start; + while (try + ln <= end) { + /* + * Look for the leading byte of the needle in the haystack + * starting at try and stopping when there's not enough room + * for the needle left. + */ + try = memchr(try, bn[0], (end + 1 - ln) - try); + if (try == NULL) { + /* Leading byte not found -> needle cannot be found. */ + return -1; + } + /* Leading byte found, check rest of needle. */ + if (0 == memcmp(try+1, bn+1, ln-1)) { + /* Checks! Return the successful index. */ + return (try - bh); + } + /* Rest of needle match failed; Iterate to continue search. */ + try++; + } + return -1; + } + + /* + * TODO: It might be nice to support some cases where it is not + * necessary to shimmer to &tclStringType to compute the result, + * and instead operate just on the objPtr->bytes values directly. + * However, we also do not want the answer to change based on the + * code pathway, or if it does we want that to be for some values + * we explicitly decline to support. Getting there will involve + * locking down in practice more firmly just what encodings produce + * what supported results for the objPtr->bytes values. For now, + * do only the well-defined Tcl_UniChar array search. + */ + + { + Tcl_UniChar *try, *end, *uh; + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + uh = Tcl_GetUnicodeFromObj(haystack, &lh); + end = uh + lh; + + for (try = uh + start; try + ln <= end; try++) { + if ((*try == *un) && (0 == + memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { + return (try - uh); + } + } + return -1; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringLast -- + * + * Implements the [string last] operation. + * + * Results: + * If needle is found as a substring of haystack, the index of the + * last instance of such a find is returned. If needle is not present + * as a substring of haystack, -1 is returned. + * + * Side effects: + * needle and haystack may have their Tcl_ObjType changed. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringLast( + Tcl_Obj *needle, + Tcl_Obj *haystack, + int last) +{ + int lh, ln = Tcl_GetCharLength(needle); + + if (ln == 0) { + /* + * We don't find empty substrings. Bizarre! + * + * TODO: When we one day make this a true substring + * finder, change this to "return last", after limitation. + */ + return -1; + } + + lh = Tcl_GetCharLength(haystack); + if (last >= lh) { + last = lh - 1; + } + + if (last < ln - 1) { + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *try, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + try = bh + last + 1 - ln; + while (try >= bh) { + if ((*try == bn[0]) + && (0 == memcmp(try+1, bn+1, ln-1))) { + return (try - bh); + } + try--; + } + return -1; + } + + { + Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + try = uh + last + 1 - ln; + while (try >= uh) { + if ((*try == un[0]) + && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + return (try - uh); + } + try--; + } + return -1; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: - * An unshared Tcl value which is the [string reverse] of the argument - * supplied. When sharing rules permit, the returned value might be the - * argument with modifications done in place. + * A Tcl value which is the [string reverse] of the argument supplied. + * When sharing rules permit and the caller requests, the returned value + * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -2684,18 +3719,20 @@ static void ReverseBytes( unsigned char *to, /* Copy bytes into here... */ unsigned char *from, /* ...from here... */ - int count) /* Until this many are copied, */ + int count) /* Until this many are copied, */ /* reversing as you go. */ { unsigned char *src = from + count; + if (to == from) { /* Reversing in place */ while (--src > to) { unsigned char c = *src; + *src = *to; *to++ = c; } - } else { + } else { while (--src >= from) { *to++ = *src; } @@ -2703,17 +3740,19 @@ ReverseBytes( } Tcl_Obj * -TclStringObjReverse( - Tcl_Obj *objPtr) +TclStringReverse( + Tcl_Obj *objPtr, + int flags) { String *stringPtr; Tcl_UniChar ch = 0; + int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); @@ -2727,7 +3766,7 @@ TclStringObjReverse( Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* @@ -2742,7 +3781,10 @@ TclStringObjReverse( *to++ = *src; } } else { - /* Reversing in place */ + /* + * Reversing in place. + */ + while (--src > from) { ch = *src; *src = *from; @@ -2756,7 +3798,7 @@ TclStringObjReverse( int numBytes = objPtr->length; char *to, *from = objPtr->bytes; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewObj(); Tcl_SetObjLength(objPtr, numBytes); } @@ -2766,20 +3808,22 @@ TclStringObjReverse( /* * Either numChars == -1 and we don't know how many chars are * represented by objPtr->bytes and we need Pass 1 just in case, - * or numChars >= 0 and we know we have fewer chars than bytes, - * so we know there's a multibyte character needing Pass 1. + * or numChars >= 0 and we know we have fewer chars than bytes, so + * we know there's a multibyte character needing Pass 1. * * Pass 1. Reverse the bytes of each multi-byte character. */ + int charCount = 0; int bytesLeft = numBytes; while (bytesLeft) { /* - * NOTE: We know that the from buffer is NUL-terminated. - * It's part of the contract for objPtr->bytes values. - * Thus, we can skip calling Tcl_UtfCharComplete() here. + * NOTE: We know that the from buffer is NUL-terminated. It's + * part of the contract for objPtr->bytes values. Thus, we can + * skip calling Tcl_UtfCharComplete() here. */ + int bytesInChar = TclUtfToUniChar(from, &ch); ReverseBytes((unsigned char *)to, (unsigned char *)from, @@ -2803,6 +3847,150 @@ TclStringObjReverse( /* *--------------------------------------------------------------------------- * + * TclStringReplace -- + * + * Implements the inner engine of the [string replace] command. + * + * The result is a concatenation of a prefix from objPtr, characters + * 0 through first-1, the insertPtr string value, and a suffix from + * objPtr, characters from first + count to the end. The effect is as if + * the inner substring of characters first through first+count-1 are + * removed and replaced with insertPtr. If insertPtr is NULL, it is + * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, + * this routine will try to do the work within objPtr, so long as no + * sharing forbids it. Without that request, or as needed, a new Tcl + * value will be allocated to be the result. + * + * Results: + * A Tcl value that is the result of the substring replacement. May + * return NULL in case of an error. When NULL is returned and interp is + * non-NULL, error information is left in interp + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringReplace( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* String to act upon */ + int first, /* First index to replace */ + int count, /* How many chars to replace */ + Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ + int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ +{ + int inPlace = flags & TCL_STRING_IN_PLACE; + Tcl_Obj *result; + + /* Caller is expected to pass sensible arguments */ + assert ( count >= 0 ) ; + assert ( first >= 0 ) ; + + /* Replace nothing with nothing */ + if ((insertPtr == NULL) && (count == 0)) { + if (inPlace) { + return objPtr; + } else { + return Tcl_DuplicateObj(objPtr); + } + } + + /* + * The caller very likely had to call Tcl_GetCharLength() or similar + * to be able to process index values. This means it is like that + * objPtr is either a proper "bytearray" or a "string" or else it has + * a known and short string rep. + */ + + if (TclIsPureByteArray(objPtr)) { + int numBytes; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + + if (insertPtr == NULL) { + /* Replace something with nothing. */ + + assert ( first <= numBytes ) ; + assert ( count <= numBytes ) ; + assert ( first + count <= numBytes ) ; + + result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Replace everything */ + if ((first == 0) && (count == numBytes)) { + return insertPtr; + } + + if (TclIsPureByteArray(insertPtr)) { + int newBytes; + unsigned char *iBytes + = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); + + if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { + /* + * Removal count and replacement count are equal. + * Other conditions permit. Do in-place splice. + */ + + memcpy(bytes + first, iBytes, count); + Tcl_InvalidateStringRep(objPtr); + return objPtr; + } + + if (newBytes > INT_MAX - (numBytes - count)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); + /* PANIC? */ + Tcl_SetByteArrayLength(result, 0); + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, iBytes, newBytes); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Flow through to try other approaches below */ + } + + /* + * TODO: Figure out how not to generate a Tcl_UniChar array rep + * when it can be determined objPtr->bytes points to a string of + * all single-byte characters so we can index it directly. + */ + + /* The traditional implementation... */ + { + int numChars; + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + + /* TODO: Is there an in-place option worth pursuing here? */ + + result = Tcl_NewUnicodeObj(ustring, first); + if (insertPtr) { + Tcl_AppendObjToObj(result, insertPtr); + } + if (first + count < numChars) { + Tcl_AppendUnicodeToObj(result, ustring + first + count, + numChars - first - count); + } + + return result; + } +} + +/* + *--------------------------------------------------------------------------- + * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string @@ -2894,7 +4082,6 @@ DupStringInternalRep( String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; -#if COMPAT==0 if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't @@ -2937,41 +4124,6 @@ DupStringInternalRep( */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; -#else /* COMPAT!=0 */ - /* - * If the src obj is a string of 1-byte Utf chars, then copy the string - * rep of the source object and create an "empty" Unicode internal rep for - * the new object. Otherwise, copy Unicode internal rep, and invalidate - * the string rep of the new object. - */ - - if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { - /* - * Copy the full allocation for the Unicode buffer. - */ - - copyStringPtr = stringAlloc(srcStringPtr->maxChars); - copyStringPtr->maxChars = srcStringPtr->maxChars; - memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); - copyStringPtr->unicode[srcStringPtr->numChars] = 0; - copyStringPtr->allocated = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->unicode[0] = 0; - copyStringPtr->maxChars = 0; - - /* - * Tricky point: the string value was copied by generic object - * management code, so it doesn't contain any extra bytes that might - * exist in the source object. - */ - - copyStringPtr->allocated = copyPtr->length; - } - copyStringPtr->numChars = srcStringPtr->numChars; - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; -#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -3059,7 +4211,7 @@ UpdateStringOfString( stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); @@ -3077,7 +4229,7 @@ ExtendStringRepWithUnicode( */ int i, origLength, size = 0; - char *dst, buf[TCL_UTF_MAX]; + char *dst; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -3103,7 +4255,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - size += Tcl_UniCharToUtf((int) unicode[i], buf); + size += TclUtfCount(unicode[i]); } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 227e6bc..fc5a713 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -46,7 +46,7 @@ * tcl.h, but do not do that unless you are sure what you're doing! */ -typedef struct String { +typedef struct { int numChars; /* The number of chars in the string. -1 means * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or @@ -72,20 +72,21 @@ typedef struct String { do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ - STRING_MAXCHARS); \ + (int)STRING_MAXCHARS); \ } \ } while (0) #define stringAttemptAlloc(numChars) \ - (String *) attemptckalloc((unsigned) STRING_SIZE(numChars)) + (String *) attemptckalloc(STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) ckalloc((unsigned) STRING_SIZE(numChars)) + (String *) ckalloc(STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) + (String *) ckrealloc((ptr), STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) + (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b28d501..4c9d3e8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -12,6 +12,10 @@ #include "tclInt.h" #include "tommath.h" +#ifdef __CYGWIN__ +# include <wchar.h> +#endif + #ifdef __GNUC__ #pragma GCC dependency "tcl.decls" #pragma GCC dependency "tclInt.decls" @@ -31,25 +35,29 @@ #undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj +#undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj +#undef Tcl_GetUnicode #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers -#define TclBackgroundException Tcl_BackgroundException #undef Tcl_SetIntObj +#undef Tcl_SetLongObj #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt +#undef TclWinNToHS /* See bug 510001: TclSockMinimumBuffers needs plat imp */ -#ifdef _WIN64 +#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 # define TclSockMinimumBuffersOld 0 #else #define TclSockMinimumBuffersOld sockMinimumBuffersOld @@ -59,6 +67,32 @@ static int TclSockMinimumBuffersOld(int sock, int size) } #endif +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define TclSetStartupScriptPath 0 +# define TclGetStartupScriptPath 0 +# define TclSetStartupScriptFileName 0 +# define TclGetStartupScriptFileName 0 +# define TclPrecTraceProc 0 +# define TclpInetNtoa 0 +# define TclWinGetServByName 0 +# define TclWinGetSockOpt 0 +# define TclWinSetSockOpt 0 +# define TclWinNToHS 0 +# define TclWinGetPlatformId 0 +# define TclWinResetInterfaces 0 +# define TclWinSetInterfaces 0 +# define TclWinGetPlatformId 0 +# define TclBNInitBignumFromWideUInt 0 +# define TclBNInitBignumFromWideInt 0 +# define TclBNInitBignumFromLong 0 +# define Tcl_Backslash 0 +# define Tcl_GetDefaultEncodingDir 0 +# define Tcl_SetDefaultEncodingDir 0 +# define Tcl_EvalTokens 0 +# define Tcl_CreateMathFunc 0 +# define Tcl_GetMathFuncInfo 0 +# define Tcl_ListMathFuncs 0 +#else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) { @@ -84,14 +118,33 @@ static const char *TclGetStartupScriptFileName(void) } return Tcl_GetString(path); } - #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS +#undef TclWinGetPlatformId +#undef TclWinResetInterfaces +#undef TclWinSetInterfaces +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} #define TclWinNToHS winNToHS static unsigned short TclWinNToHS(unsigned short ns) { return ntohs(ns); } +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId(void) +{ + return 2; /* VER_PLATFORM_WIN32_NT */; +} +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #endif +# define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt +# define TclBNInitBignumFromWideInt TclInitBignumFromWideInt +# define TclBNInitBignumFromLong TclInitBignumFromLong +#endif /* TCL_NO_DEPRECATED */ #ifdef _WIN32 # define TclUnixWaitForFile 0 @@ -101,14 +154,15 @@ static unsigned short TclWinNToHS(unsigned short ns) { # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty -# define TclWinSetInterfaces (void (*) (int)) doNothing +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} +#endif # define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing -# define TclWinResetInterfaces doNothing - -#if TCL_UTF_MAX < 4 -static Tcl_Encoding winTCharEncoding; -#endif static int TclpIsAtty(int fd) @@ -116,15 +170,6 @@ TclpIsAtty(int fd) return isatty(fd); } -#define TclWinGetPlatformId winGetPlatformId -static int -TclWinGetPlatformId() -{ - /* Don't bother to determine the real platform on cygwin, - * because VER_PLATFORM_WIN32_NT is the only supported platform */ - return 2; /* VER_PLATFORM_WIN32_NT */; -} - void *TclWinGetTclInstance() { void *hInstance = NULL; @@ -133,6 +178,7 @@ void *TclWinGetTclInstance() return hInstance; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TclWinSetSockOpt winSetSockOpt static int TclWinSetSockOpt(SOCKET s, int level, int optname, @@ -155,6 +201,7 @@ TclWinGetServByName(const char *name, const char *proto) { return getservbyname(name, proto); } +#endif /* TCL_NO_DEPRECATED */ #define TclWinNoBackslash winNoBackslash static char * @@ -176,37 +223,17 @@ TclpGetPid(Tcl_Pid pid) return (int) (size_t) pid; } -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} - char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 - WCHAR *wp; - int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); - Tcl_DStringInit(dsPtr); - Tcl_DStringSetLength(dsPtr, 2*size+2); - wp = (WCHAR *)Tcl_DStringValue(dsPtr); - MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); - if (len == -1) --size; /* account for 0-byte at string end */ - Tcl_DStringSetLength(dsPtr, 2*size); - wp[size] = 0; - return (char *)wp; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + if (!string) { + return NULL; } - return Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); -#endif + return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr); } char * @@ -215,29 +242,16 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 - char *p; - int size; - - if (len > 0) { - len /= 2; - } - size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); Tcl_DStringInit(dsPtr); - Tcl_DStringSetLength(dsPtr, size+1); - p = (char *)Tcl_DStringValue(dsPtr); - WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); - if (len == -1) --size; /* account for 0-byte at string end */ - Tcl_DStringSetLength(dsPtr, size); - p[size] = 0; - return p; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + if (!string) { + return NULL; } - return Tcl_ExternalToUtfDString(winTCharEncoding, - string, len, dsPtr); -#endif + if (len < 0) { + len = wcslen((wchar_t *)string); + } else { + len /= 2; + } + return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); } #if defined(TCL_WIDE_INT_IS_LONG) @@ -246,33 +260,11 @@ Tcl_WinTCharToUtf( * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))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)) + if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { @@ -288,7 +280,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ long longValue; int result = Tcl_ExprLongObj(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= -(long)(UINT_MAX)) + if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { @@ -316,17 +308,132 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } #define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp -static int formatInt(char *buffer, int n){ - return TclFormatInt(buffer, (long)n); -} -#define TclFormatInt (int(*)(char *, long))formatInt -#endif +#endif /* TCL_WIDE_INT_IS_LONG */ + +#endif /* __CYGWIN__ */ -#else /* UNIX and MAC */ +#if defined(TCL_NO_DEPRECATED) +# define Tcl_SeekOld 0 +# define Tcl_TellOld 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_PkgPresent +# define Tcl_PkgPresent 0 +# undef Tcl_PkgProvide +# define Tcl_PkgProvide 0 +# undef Tcl_PkgRequire +# define Tcl_PkgRequire 0 +# undef Tcl_GetIndexFromObj +# define Tcl_GetIndexFromObj 0 +# define Tcl_NewBooleanObj 0 +# undef Tcl_DbNewBooleanObj +# define Tcl_DbNewBooleanObj 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_SetVar +# define Tcl_SetVar 0 +# undef Tcl_UnsetVar +# define Tcl_UnsetVar 0 +# undef Tcl_GetVar +# define Tcl_GetVar 0 +# undef Tcl_TraceVar +# define Tcl_TraceVar 0 +# undef Tcl_UntraceVar +# define Tcl_UntraceVar 0 +# undef Tcl_VarTraceInfo +# define Tcl_VarTraceInfo 0 +# undef Tcl_UpVar +# define Tcl_UpVar 0 +# undef Tcl_AddErrorInfo +# define Tcl_AddErrorInfo 0 +# undef Tcl_AddObjErrorInfo +# define Tcl_AddObjErrorInfo 0 +# undef Tcl_Eval +# define Tcl_Eval 0 +# undef Tcl_GlobalEval +# define Tcl_GlobalEval 0 +# undef Tcl_SaveResult +# define Tcl_SaveResult 0 +# undef Tcl_RestoreResult +# define Tcl_RestoreResult 0 +# undef Tcl_DiscardResult +# define Tcl_DiscardResult 0 +# undef Tcl_SetResult +# define Tcl_SetResult 0 +# undef Tcl_EvalObj +# define Tcl_EvalObj 0 +# undef Tcl_GlobalEvalObj +# define Tcl_GlobalEvalObj 0 +# define TclBackgroundException 0 +# undef TclpReaddir +# define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 +# undef TclpGetDate +# define TclpGetDate 0 +# undef TclpLocaltime +# define TclpLocaltime 0 +# undef TclpGmtime +# define TclpGmtime 0 +# define TclpLocaltime_unix 0 +# define TclpGmtime_unix 0 +# define Tcl_GetUnicode 0 +#else /* TCL_NO_DEPRECATED */ +# define Tcl_SeekOld seekOld +# define Tcl_TellOld tellOld +# define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime -#endif + +static int +seekOld( + Tcl_Channel chan, /* The channel on which to seek. */ + int offset, /* Offset to seek to. */ + int mode) /* Relative to which location to seek? */ +{ + return Tcl_Seek(chan, offset, mode); +} + +static int +tellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + return Tcl_Tell(chan); +} +#endif /* !TCL_NO_DEPRECATED */ /* * WARNING: The contents of this file is automatically generated by the @@ -337,6 +444,15 @@ static int formatInt(char *buffer, int n){ MODULE_SCOPE const TclStubs tclStubs; MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + /* !BEGIN!: Do not edit below this line. */ static const TclIntStubs tclIntStubs = { @@ -454,22 +570,22 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ @@ -520,8 +636,8 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ @@ -788,6 +904,12 @@ const TclTomMathStubs tclTomMathStubs = { TclBNInitBignumFromLong, /* 64 */ TclBNInitBignumFromWideInt, /* 65 */ TclBNInitBignumFromWideUInt, /* 66 */ + TclBN_mp_expt_d_ex, /* 67 */ + TclBN_mp_set_long_long, /* 68 */ + TclBN_mp_get_long_long, /* 69 */ + TclBN_mp_set_long, /* 70 */ + TclBN_mp_get_long, /* 71 */ + TclBN_mp_get_int, /* 72 */ }; static const TclStubHooks tclStubHooks = { @@ -1454,6 +1576,16 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_OpenTcpServerEx, /* 631 */ + TclZipfs_Mount, /* 632 */ + TclZipfs_Unmount, /* 633 */ + TclZipfs_TclLibrary, /* 634 */ + TclZipfs_MountBuffer, /* 635 */ + Tcl_FreeIntRep, /* 636 */ + Tcl_InitStringRep, /* 637 */ + Tcl_FetchIntRep, /* 638 */ + Tcl_StoreIntRep, /* 639 */ + Tcl_HasStringRep, /* 640 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 859cbf9..5261591 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -24,13 +24,10 @@ const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* - * Use our own isDigit to avoid linking to libc on windows + * Use our own ISDIGIT to avoid linking to libc on windows */ -static int isDigit(const int c) -{ - return (c >= '0' && c <= '9'); -} +#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) /* *---------------------------------------------------------------------- @@ -54,7 +51,8 @@ MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact) + int exact, + int magic) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; @@ -67,9 +65,9 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { - iPtr->result = "interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = TCL_STATIC; + if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = 0; return NULL; } @@ -77,12 +75,12 @@ Tcl_InitStubs( if (actualVersion == NULL) { return NULL; } - if (exact) { + if (exact&1) { const char *p = version; int count = 0; while (*p) { - count += !isDigit(*p++); + count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; @@ -91,7 +89,7 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p || isDigit(*q)) { + if (*p || ISDIGIT(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; @@ -103,12 +101,16 @@ Tcl_InitStubs( } } } - tclStubsPtr = (TclStubs *)pkgData; + if (((exact&0xff00) < 0x900)) { + /* We are running Tcl 8.x */ + stubsPtr = (TclStubs *)pkgData; + } + tclStubsPtr = stubsPtr; - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + if (stubsPtr->hooks) { + tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; diff --git a/generic/tclTest.c b/generic/tclTest.c index 8a59b83..fb8857c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -42,16 +42,8 @@ * Declare external functions used in Windows tests. */ -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Tcltest_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT -EXTERN int Tcltest_Init(Tcl_Interp *interp); -EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); +DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); +DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -75,6 +67,18 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; +/* + * Start of the socket driver state structure to acces field testFlags + */ + +typedef struct TcpState TcpState; + +struct TcpState { + Tcl_Channel channel; /* Channel associated with this socket. */ + int testFlags; /* bit field for tests. Is set by testsocket + * test procedure */ +}; + TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; @@ -98,7 +102,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -109,7 +113,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -132,7 +136,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ @@ -157,7 +161,7 @@ static TestChannel *firstDetached; static int AsyncHandlerProc(ClientData clientData, Tcl_Interp *interp, int code); -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(ClientData); #endif static void CleanupTestSetassocdataTests( @@ -223,6 +227,9 @@ static int TestasyncCmd(ClientData dummy, static int TestbytestringObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TeststringbytesObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestcmdinfoCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, @@ -286,6 +293,8 @@ static int TestgetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetintCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestlongsizeCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); static int TestgetplatformCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( @@ -298,12 +307,6 @@ static int TestlinkCmd(ClientData dummy, static int TestlocaleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestMathFunc(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); -static int TestMathFunc2(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); static int TestmainthreadCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, @@ -323,6 +326,12 @@ static int TestparsevarObjCmd(ClientData dummy, static int TestparsevarnameObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestpreferstableObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestprintObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestregexpObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -364,6 +373,8 @@ static int TestChannelCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); static int TestChannelEventCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); +static int TestSocketCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); static int TestFilesystemObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -538,8 +549,6 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { - Tcl_ValueType t3ArgTypes[2]; - Tcl_Obj *listPtr; Tcl_Obj **objv; int objc, index; @@ -548,10 +557,10 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) { + if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { @@ -559,7 +568,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -571,6 +580,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -637,6 +647,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", @@ -654,6 +666,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, + NULL, NULL); + Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, @@ -680,13 +696,13 @@ Tcltest_Init( TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, + NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); - Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); - Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, @@ -697,11 +713,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif - t3ArgTypes[0] = TCL_EITHER; - t3ArgTypes[1] = TCL_EITHER; - Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - NULL); - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, @@ -715,7 +726,7 @@ Tcltest_Init( if (Procbodytest_Init(interp) != TCL_OK) { return TCL_ERROR; } -#ifdef TCL_THREADS +#if TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } @@ -784,7 +795,7 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } return Procbodytest_SafeInit(interp); @@ -821,7 +832,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -895,7 +906,7 @@ TestasyncCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; -#ifdef TCL_THREADS +#if TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -911,7 +922,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_AppendResult(interp, "can't create thread", NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -992,7 +1003,7 @@ AsyncHandlerProc( *---------------------------------------------------------------------- */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( ClientData clientData) /* Parameter is the id of a @@ -1058,7 +1069,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); + Tcl_AppendResult(interp, "??", NULL); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1185,7 +1196,7 @@ TestcmdtokenCmd( token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1288,10 +1299,10 @@ TestcmdtraceCmd( cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); + Tcl_AppendResult(interp, "Delete wasn't called", NULL); return TCL_ERROR; } else { return result; @@ -1302,7 +1313,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1591,7 +1602,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } @@ -1631,7 +1642,7 @@ DelDeleteProc( { DelCmd *dPtr = clientData; - Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1796,7 +1807,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1832,9 +1843,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1969,9 +1980,12 @@ TestencodingObjCmd( if (objc != 3) { return TCL_ERROR; } - encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); - Tcl_FreeEncoding(encoding); - Tcl_FreeEncoding(encoding); + if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { + return TCL_ERROR; + } + Tcl_FreeEncoding(encoding); /* Free returned reference */ + Tcl_FreeEncoding(encoding); /* Free to match CREATE */ + TclFreeIntRep(objv[2]); /* Free the cached ref */ break; } return TCL_OK; @@ -1994,7 +2008,7 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2026,7 +2040,7 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2380,7 +2394,7 @@ ExitProcOdd( char buf[16 + TCL_INTEGER_SPACE]; size_t len; - sprintf(buf, "odd %d\n", PTR2INT(clientData)); + sprintf(buf, "odd %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData)); len = strlen(buf); if (len != (size_t) write(1, buf, len)) { Tcl_Panic("ExitProcOdd: unable to write to stdout"); @@ -2394,7 +2408,7 @@ ExitProcEven( char buf[16 + TCL_INTEGER_SPACE]; size_t len; - sprintf(buf, "even %d\n", PTR2INT(clientData)); + sprintf(buf, "even %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData)); len = strlen(buf); if (len != (size_t) write(1, buf, len)) { Tcl_Panic("ExitProcEven: unable to write to stdout"); @@ -2434,7 +2448,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2476,7 +2490,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2519,7 +2533,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2562,7 +2576,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2818,7 +2832,7 @@ TestlinkCmd( static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; - static Tcl_WideInt wideVar = Tcl_LongAsWide(79); + static Tcl_WideInt wideVar = 79; static char *stringVar = NULL; static char charVar = '@'; static unsigned char ucharVar = 130; @@ -2828,7 +2842,7 @@ TestlinkCmd( static long longVar = 123456789L; static unsigned long ulongVar = 3456789012UL; static float floatVar = 4.5; - static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); + static Tcl_WideUInt uwideVar = 123; static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; @@ -3324,144 +3338,6 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * - * TestMathFunc -- - * - * This is a user-defined math procedure to test out math procedures - * with no arguments. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Not used. */ - Tcl_Value *args, /* Not used. */ - Tcl_Value *resultPtr) /* Where to store result. */ -{ - resultPtr->type = TCL_INT; - resultPtr->intValue = PTR2INT(clientData); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestMathFunc2 -- - * - * This is a user-defined math procedure to test out math procedures - * that do have arguments, in this case 2. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc2( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Used to report errors. */ - Tcl_Value *args, /* Points to an array of two Tcl_Value structs - * for the two arguments. */ - Tcl_Value *resultPtr) /* Where to store the result. */ -{ - int result = TCL_OK; - - /* - * Return the maximum of the two arguments with the correct type. - */ - - if (args[0].type == TCL_INT) { - int i0 = args[0].intValue; - - if (args[1].type == TCL_INT) { - int i1 = args[1].intValue; - - resultPtr->type = TCL_INT; - resultPtr->intValue = ((i0 > i1)? i0 : i1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = i0; - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = Tcl_LongAsWide(i0); - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_DOUBLE) { - double d0 = args[0].doubleValue; - - if (args[1].type == TCL_INT) { - double d1 = args[1].intValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_DOUBLE) { - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - double d1 = Tcl_WideAsDouble(args[1].wideValue); - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = args[0].wideValue; - - if (args[1].type == TCL_INT) { - Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = Tcl_WideAsDouble(w0); - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); - result = TCL_ERROR; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3793,6 +3669,75 @@ TestparsevarnameObjCmd( /* *---------------------------------------------------------------------- * + * TestpreferstableObjCmd -- + * + * This procedure implements the "testpreferstable" command. It is + * used for being able to test the "package" command even when the + * environment variable TCL_PKG_PREFER_LATEST is set in your environment. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestpreferstableObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + iPtr->packagePrefer = PKG_PREFER_STABLE; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestprintObjCmd -- + * + * This procedure implements the "testprint" command. It is + * used for being able to test the Tcl_ObjPrintf() function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestprintObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt argv1 = 0; + size_t argv2; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); + } + + if (objc > 1) { + Tcl_GetWideIntFromObj(interp, objv[2], &argv1); + } + argv2 = (size_t)argv1; + Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -3936,7 +3881,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); sprintf(resinfo, "%d %d", start, end-1); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -3950,7 +3895,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); sprintf(resinfo, "%ld", info.extendStart); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -4293,7 +4238,7 @@ StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -4377,7 +4322,7 @@ TestupvarCmd( } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); + return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -4417,7 +4362,7 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, "too many args", TCL_STATIC); + Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } switch (argc) { @@ -4871,10 +4816,10 @@ GetTimesObjCmd( timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4888,7 +4833,7 @@ GetTimesObjCmd( fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4959,6 +4904,40 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TeststringbytesObjCmd -- + * Returns bytearray value of the bytes in argument string rep + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststringbytesObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const unsigned char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestbytestringObjCmd -- * * This object-based procedure constructs a string which can @@ -5021,7 +5000,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5029,7 +5008,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5053,7 +5032,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5061,7 +5040,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5127,10 +5106,11 @@ TestsaveresultCmd( return TCL_ERROR; } + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); + Tcl_AppendResult(interp, "small result", NULL); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -5151,13 +5131,12 @@ TestsaveresultCmd( break; } - freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_Eval(interp, Tcl_GetString(objv[2])); + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } if (discard) { @@ -5169,11 +5148,9 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); break; } case RESULT_OBJECT: @@ -5234,12 +5211,12 @@ TestmainthreadCmd( const char **argv) /* Argument strings. */ { if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); + Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } } @@ -5631,8 +5608,8 @@ TestChannelCmd( return TCL_ERROR; } - TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan)); - Tcl_AppendResult(interp, buf, NULL); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan))); return TCL_OK; } @@ -6012,6 +5989,75 @@ TestChannelEventCmd( /* *---------------------------------------------------------------------- * + * TestSocketCmd -- + * + * Implements the Tcl "testsocket" debugging command and its + * subcommands. This is part of the testing environment. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestSocketCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter for result. */ + int argc, /* Count of additional args. */ + const char **argv) /* Additional arg strings. */ +{ + const char *cmdName; /* Sub command. */ + size_t len; /* Length of subcommand string. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { + Tcl_Channel hChannel; + int modePtr; + TcpState *statePtr; + /* Set test value in the socket driver + */ + /* Check for argument "channel name" + */ + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " testflags channel flags\"", NULL); + return TCL_ERROR; + } + hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); + if ( NULL == hChannel ) { + Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); + return TCL_ERROR; + } + statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); + if ( NULL == statePtr) { + Tcl_AppendResult(interp, "No channel instance data:", argv[2], + NULL); + return TCL_ERROR; + } + statePtr->testFlags = atoi(argv[3]); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " + "testflags", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. @@ -6040,7 +6086,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6057,7 +6103,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6259,7 +6305,7 @@ TestReport( savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); @@ -6766,7 +6812,7 @@ TestcpuidCmd( Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - unsigned int regs[4]; + int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { @@ -6776,14 +6822,14 @@ TestcpuidCmd( if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID((unsigned) index, regs); + status = TclWinCPUID(index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + regsObjs[i] = Tcl_NewIntObj(regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -6878,7 +6924,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -6894,6 +6940,24 @@ TestgetintCmd( } } +/* + * Used for determining sizeof(long) at script level. + */ +static int +TestlongsizeCmd( + ClientData dummy, + Tcl_Interp *interp, + int argc, + const char **argv) +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long))); + return TCL_OK; +} + static int NREUnwind_callback( ClientData data[], @@ -7018,17 +7082,11 @@ TestconcatobjCmd( list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - if (list1Ptr->bytes != NULL) { - ckfree(list1Ptr->bytes); - list1Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list1Ptr); list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - if (list2Ptr->bytes != NULL) { - ckfree(list2Ptr->bytes); - list2Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list2Ptr); /* * Verify that concat'ing a list obj with one or more empty strings does @@ -7402,7 +7460,7 @@ InterpCmdResolver( */ CallFrame *parentFramePtr = varFramePtr->callerPtr; - char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f7d2bae..547792a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -622,23 +622,9 @@ TestindexobjCmd( } argv[objc-4] = NULL; - /* - * Tcl_GetIndexFromObj assumes that the table is statically-allocated so - * that its address is different for each index object. If we accidently - * allocate a table at the same address as that cached in the index - * object, clear out the object's cached state. - */ - - if (objv[3]->typePtr != NULL - && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = objv[3]->internalRep.twoPtrValue.ptr1; - if (indexRep->tablePtr == (void *) argv) { - TclFreeIntRep(objv[3]); - } - } - result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); + argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), + &index); ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); @@ -1102,6 +1088,9 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; +#ifndef TCL_WIDE_INT_IS_LONG + if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { @@ -1115,7 +1104,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1129,6 +1118,11 @@ TestobjCmd( } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "int", -1); +#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); diff --git a/generic/tclThread.c b/generic/tclThread.c index 198fa6a..cafd824 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -41,21 +41,6 @@ static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); /* - * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not - * specified. Here we undo that so the functions are defined in the stubs - * table. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#undef Tcl_MutexUnlock -#undef Tcl_MutexFinalize -#undef Tcl_ConditionNotify -#undef Tcl_ConditionWait -#undef Tcl_ConditionFinalize -#endif - -/* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- @@ -79,7 +64,7 @@ Tcl_GetThreadData( int size) /* Size of storage block */ { void *result; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Initialize the key for this thread. */ @@ -126,7 +111,7 @@ TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ { -#ifdef TCL_THREADS +#if TCL_THREADS return TclThreadStorageKeyGet(keyPtr); #else /* TCL_THREADS */ return *keyPtr; @@ -269,11 +254,12 @@ TclRememberMutex( *---------------------------------------------------------------------- */ +#undef Tcl_MutexFinalize void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif TclpMasterLock(); @@ -322,11 +308,12 @@ TclRememberCondition( *---------------------------------------------------------------------- */ +#undef Tcl_ConditionFinalize void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeCondition(condPtr); #endif TclpMasterLock(); @@ -356,7 +343,7 @@ void TclFinalizeThreadData(int quick) { TclFinalizeThreadDataThread(); -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) if (!quick) { /* * Quick exit principle makes it useless to terminate allocators @@ -389,7 +376,7 @@ TclFinalizeSynchronization(void) int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; @@ -413,7 +400,7 @@ TclFinalizeSynchronization(void) keyRecord.max = 0; keyRecord.num = 0; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Call thread storage master cleanup. */ @@ -473,12 +460,10 @@ Tcl_ExitThread( int status) { Tcl_FinalizeThread(); -#ifdef TCL_THREADS TclpThreadExit(status); -#endif } -#ifndef TCL_THREADS +#if !TCL_THREADS /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2ee758e..3f1abc2 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -13,7 +13,7 @@ */ #include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store @@ -196,20 +196,11 @@ GetCache(void) if (listLockPtr == NULL) { Tcl_Mutex *initLockPtr; - unsigned int i; initLockPtr = Tcl_GetAllocMutex(); Tcl_MutexLock(initLockPtr); if (listLockPtr == NULL) { - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } + TclInitThreadAlloc(); } Tcl_MutexUnlock(initLockPtr); } @@ -1064,6 +1055,40 @@ GetBlocks( } return 1; } + +/* + *---------------------------------------------------------------------- + * + * TclInitThreadAlloc -- + * + * Initializes the allocator cache-maintenance structures. + * It is done early and protected during the TclInitSubsystems(). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclInitThreadAlloc(void) +{ + unsigned int i; + + listLockPtr = TclpNewAllocMutex(); + objLockPtr = TclpNewAllocMutex(); + for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); + } + TclpInitAllocCache(); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 755a461..b56ec80 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -13,7 +13,7 @@ #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS #include <signal.h> /* diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index fcf3880..1742eb7 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -18,7 +18,7 @@ #endif #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS /* * Each thread has an single instance of the following structure. There is one * instance of this structure per thread even if that thread contains multiple @@ -174,7 +174,6 @@ TclThread_Init( Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -248,7 +247,7 @@ ThreadObjCmd( switch ((enum options)option) { case THREAD_CANCEL: { - long id; + Tcl_WideInt id; const char *result; int flags, arg; @@ -264,7 +263,7 @@ ThreadObjCmd( arg++; } } - if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; @@ -655,9 +654,9 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); + sprintf(buf, "%p", Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); @@ -1032,8 +1031,8 @@ ThreadEventProc( code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } @@ -1158,6 +1157,14 @@ ThreadExitProc( Tcl_MutexLock(&threadMutex); + if (self == errorThreadId) { + if (errorProcString) { /* Extra safety */ + ckfree(errorProcString); + errorProcString = NULL; + } + errorThreadId = 0; + } + if (threadEvalScript) { ckfree(threadEvalScript); threadEvalScript = NULL; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c10986a..ccfd179 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -91,7 +91,7 @@ typedef struct IdleHandler { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ @@ -789,7 +789,7 @@ Tcl_AfterObjCmd( AfterInfo *afterPtr; AfterAssocData *assocPtr; int length; - int index; + int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; @@ -818,15 +818,9 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif - || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { - index = -1; - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -900,10 +894,10 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } - command = Tcl_GetStringFromObj(commandPtr, &length); + command = TclGetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + tempCommand = TclGetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, (unsigned) length)) { @@ -1045,31 +1039,27 @@ AfterDelay( if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1; + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break; - } else break; + Tcl_Sleep((int) diff); + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } + } else { + break; + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { - Tcl_Sleep((long) diff); + Tcl_Sleep((int) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { @@ -1083,7 +1073,7 @@ AfterDelay( return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 610a031..56ab55f 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -30,13 +30,13 @@ declare 1 { } declare 2 { - int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 3 { - int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) } declare 4 { - int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) } declare 5 { void TclBN_mp_clamp(mp_int *a) @@ -63,25 +63,25 @@ declare 12 { int TclBN_mp_count_bits(const mp_int *a) } declare 13 { - int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r) + int TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) } declare 14 { - int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, mp_digit *r) + int TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) } declare 15 { - int TclBN_mp_div_2(mp_int *a, mp_int *q) + int TclBN_mp_div_2(const mp_int *a, mp_int *q) } declare 16 { int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) } declare 17 { - int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r) + int TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) } declare 18 { void TclBN_mp_exch(mp_int *a, mp_int *b) } declare 19 { - int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) } declare 20 { int TclBN_mp_grow(mp_int *a, int size) @@ -90,7 +90,7 @@ declare 21 { int TclBN_mp_init(mp_int *a) } declare 22 { - int TclBN_mp_init_copy(mp_int *a, mp_int *b) + int TclBN_mp_init_copy(mp_int *a, const mp_int *b) } declare 23 { int TclBN_mp_init_multi(mp_int *a, ...) @@ -105,19 +105,19 @@ declare 26 { int TclBN_mp_lshd(mp_int *a, int shift) } declare 27 { - int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r) + int TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r) } declare 28 { int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) } declare 29 { - int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p) + int TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) } declare 30 { - int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p) + int TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) } declare 31 { - int TclBN_mp_mul_2(mp_int *a, mp_int *p) + int TclBN_mp_mul_2(const mp_int *a, mp_int *p) } declare 32 { int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) @@ -126,10 +126,10 @@ declare 33 { int TclBN_mp_neg(const mp_int *a, mp_int *b) } declare 34 { - int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c) } declare 35 { - int TclBN_mp_radix_size(mp_int *a, int radix, int *size) + int TclBN_mp_radix_size(const mp_int *a, int radix, int *size) } declare 36 { int TclBN_mp_read_radix(mp_int *a, const char *str, int radix) @@ -144,32 +144,32 @@ declare 39 { void TclBN_mp_set(mp_int *a, mp_digit b) } declare 40 { - int TclBN_mp_sqr(mp_int *a, mp_int *b) + int TclBN_mp_sqr(const mp_int *a, mp_int *b) } declare 41 { - int TclBN_mp_sqrt(mp_int *a, mp_int *b) + int TclBN_mp_sqrt(const mp_int *a, mp_int *b) } declare 42 { - int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 43 { - int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) } declare 44 { - int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b) + int TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) } declare 45 { - int TclBN_mp_to_unsigned_bin_n(mp_int *a, unsigned char *b, + int TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) } declare 46 { - int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, int maxlen) + int TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) } declare 47 { - int TclBN_mp_unsigned_bin_size(mp_int *a) + int TclBN_mp_unsigned_bin_size(const mp_int *a) } declare 48 { - int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) } declare 49 { void TclBN_mp_zero(mp_int *a) @@ -182,34 +182,34 @@ declare 50 { void TclBN_reverse(unsigned char *s, int len) } declare 51 { - int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) + int TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } declare 52 { - int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b) + int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b) } declare 53 { - int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) } declare 54 { - int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b) + int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) } declare 55 { - int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) } declare 56 { - int TclBN_mp_toom_sqr(mp_int *a, mp_int *b) + int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) } declare 57 { - int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c) + int TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 58 { - int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) + int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } declare 59 { - int TclBN_s_mp_sqr(mp_int *a, mp_int *b) + int TclBN_s_mp_sqr(const mp_int *a, mp_int *b) } declare 60 { - int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) + int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 61 { int TclBN_mp_init_set_int(mp_int *a, unsigned long i) @@ -223,16 +223,37 @@ declare 63 { # Formerly internal API to allow initialisation of bignums without knowing the # typedefs of how a bignum works internally. -declare 64 { +declare 64 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromLong(mp_int *bignum, long initVal) } -declare 65 { +declare 65 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) } -declare 66 { +declare 66 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) } +# Added in libtommath 1.0 +declare 67 { + int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +} +# Added in libtommath 1.0.1 +declare 68 { + int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i) +} +declare 69 { + Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a) +} +declare 70 { + int TclBN_mp_set_long(mp_int *a, unsigned long i) +} +declare 71 { + unsigned long TclBN_mp_get_long(const mp_int *a) +} +declare 72 { + unsigned long TclBN_mp_get_int(const mp_int *a) +} + # Local Variables: # mode: tcl # End: diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index 41512f0..fbf0d35 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -9,8 +9,6 @@ * * The library is free for all purposes without any express * guarantee it works. - * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com */ #ifndef BN_H_ #define BN_H_ @@ -22,32 +20,25 @@ -#ifndef MIN -# define MIN(x,y) ((x)<(y)?(x):(y)) -#endif - -#ifndef MAX -# define MAX(x,y) ((x)>(y)?(x):(y)) -#endif - #ifdef __cplusplus extern "C" { - -/* C++ compilers don't like assigning void * to mp_digit * */ -#define OPT_CAST(x) (x *) - -#else - -/* C on the other hand doesn't care */ -#define OPT_CAST(x) - #endif +/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ +#if defined(_MSC_VER) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__) +# define MP_32BIT +#endif /* detect 64-bit mode if possible */ -#if defined(NEVER) /* 128-bit ints fail in too many places */ -# if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) -# define MP_64BIT +#if defined(NEVER) +# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT)) +# if defined(__GNUC__) +/* we support 128bit integers only via: __attribute__((mode(TI))) */ +# define MP_64BIT +# else +/* otherwise we fall back to MP_32BIT even on 64bit platforms */ +# define MP_32BIT +# endif # endif #endif @@ -61,83 +52,67 @@ extern "C" { */ #ifdef MP_8BIT #ifndef MP_DIGIT_DECLARED - typedef unsigned char mp_digit; +typedef unsigned char mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned short mp_word; +#ifndef MP_WORD_DECLARED +typedef unsigned short mp_word; +#define MP_WORD_DECLARED +#endif +# define MP_SIZEOF_MP_DIGIT 1 +# ifdef DIGIT_BIT +# error You must not define DIGIT_BIT when using MP_8BIT +# endif #elif defined(MP_16BIT) #ifndef MP_DIGIT_DECLARED - typedef unsigned short mp_digit; +typedef unsigned short mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned long mp_word; -#elif defined(MP_64BIT) - /* for GCC only on supported platforms */ -#ifndef CRYPT - typedef unsigned long long ulong64; - typedef signed long long long64; +#ifndef MP_WORD_DECLARED +typedef unsigned int mp_word; +#define MP_WORD_DECLARED #endif - +# define MP_SIZEOF_MP_DIGIT 2 +# ifdef DIGIT_BIT +# error You must not define DIGIT_BIT when using MP_16BIT +# endif +#elif defined(MP_64BIT) +/* for GCC only on supported platforms */ #ifndef MP_DIGIT_DECLARED - typedef unsigned long mp_digit; +typedef unsigned long long mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned long mp_word __attribute__ ((mode(TI))); - -# define DIGIT_BIT 60 +typedef unsigned long mp_word __attribute__((mode(TI))); +# define DIGIT_BIT 60 #else - /* this is the default case, 28-bit digits */ - - /* this is to make porting into LibTomCrypt easier :-) */ -#ifndef CRYPT -# if defined(_MSC_VER) || defined(__BORLANDC__) - typedef unsigned __int64 ulong64; - typedef signed __int64 long64; -# else - typedef unsigned long long ulong64; - typedef signed long long long64; -# endif -#endif +/* this is the default case, 28-bit digits */ +/* this is to make porting into LibTomCrypt easier :-) */ #ifndef MP_DIGIT_DECLARED - typedef unsigned int mp_digit; +typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED #endif - typedef ulong64 mp_word; - -#ifdef MP_31BIT - /* this is an extension that uses 31-bit digits */ -# define DIGIT_BIT 31 -#else - /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ -# define DIGIT_BIT 28 -# define MP_28BIT -#endif +#ifndef MP_WORD_DECLARED +typedef unsigned long long mp_word; +#define MP_WORD_DECLARED #endif -/* define heap macros */ -#if 0 /* these are macros in tclTomMathDecls.h */ -#ifndef CRYPT - /* default to libc stuff */ -# ifndef XMALLOC -# define XMALLOC malloc -# define XFREE free -# define XREALLOC realloc -# define XCALLOC calloc -# else - /* prototypes for our heap functions */ - extern void *XMALLOC(size_t n); - extern void *XREALLOC(void *p, size_t n); - extern void *XCALLOC(size_t n, size_t s); - extern void XFREE(void *p); -# endif -#endif +# ifdef MP_31BIT +/* this is an extension that uses 31-bit digits */ +# define DIGIT_BIT 31 +# else +/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ +# define DIGIT_BIT 28 +# define MP_28BIT +# endif #endif - /* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ #ifndef DIGIT_BIT -# define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +# define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */ +typedef unsigned long mp_min_u32; +#else +typedef mp_digit mp_min_u32; #endif #define MP_DIGIT_BIT DIGIT_BIT @@ -170,9 +145,9 @@ typedef int mp_err; /* you'll have to tune these... */ #if defined(BUILD_tcl) || !defined(_WIN32) MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, - KARATSUBA_SQR_CUTOFF, - TOOM_MUL_CUTOFF, - TOOM_SQR_CUTOFF; + KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF; #endif /* define this to use lower memory usage routines (exptmods mostly) */ @@ -180,15 +155,15 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, /* default precision */ #ifndef MP_PREC -# ifndef MP_LOW_MEM -# define MP_PREC 32 /* default digits of precision */ -# else -# define MP_PREC 8 /* default digits of precision */ -# endif +# ifndef MP_LOW_MEM +# define MP_PREC 32 /* default digits of precision */ +# else +# define MP_PREC 8 /* default digits of precision */ +# endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ -#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) +#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) /* the infamous mp_int structure */ #ifndef MP_INT_DECLARED @@ -196,22 +171,20 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, typedef struct mp_int mp_int; #endif struct mp_int { - int used, alloc, sign; - mp_digit *dp; + int used, alloc, sign; + mp_digit *dp; }; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); -#define USED(m) ((m)->used) -#define DIGIT(m,k) ((m)->dp[(k)]) -#define SIGN(m) ((m)->sign) +#define USED(m) ((m)->used) +#define DIGIT(m, k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) /* error code to char* string */ -/* -char *mp_error_to_string(int code); -*/ +const char *mp_error_to_string(int code); /* ---> init and deinit bignum functions <--- */ /* init a bignum */ @@ -256,8 +229,9 @@ int mp_init_size(mp_int *a, int size); /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) -#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) -#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) +#define mp_iseven(a) ((((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) ? MP_YES : MP_NO) +#define mp_isodd(a) ((((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) ? MP_YES : MP_NO) +#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO) /* set to zero */ /* @@ -274,17 +248,39 @@ void mp_set(mp_int *a, mp_digit b); int mp_set_int(mp_int *a, unsigned long b); */ +/* set a platform dependent unsigned long value */ +/* +int mp_set_long(mp_int *a, unsigned long b); +*/ + +/* set a platform dependent unsigned long long value */ +/* +int mp_set_long_long(mp_int *a, unsigned long long b); +*/ + /* get a 32-bit value */ -unsigned long mp_get_int(mp_int * a); +/* +unsigned long mp_get_int(const mp_int *a); +*/ + +/* get a platform dependent unsigned long value */ +/* +unsigned long mp_get_long(const mp_int *a); +*/ + +/* get a platform dependent unsigned long long value */ +/* +unsigned long long mp_get_long_long(const mp_int *a); +*/ /* initialize and set a digit */ /* -int mp_init_set (mp_int * a, mp_digit b); +int mp_init_set(mp_int *a, mp_digit b); */ /* initialize and set 32-bit value */ /* -int mp_init_set_int (mp_int * a, unsigned long b); +int mp_init_set_int(mp_int *a, unsigned long b); */ /* copy, b = a */ @@ -294,7 +290,7 @@ int mp_copy(const mp_int *a, mp_int *b); /* inits and copies, a = b */ /* -int mp_init_copy(mp_int *a, mp_int *b); +int mp_init_copy(mp_int *a, const mp_int *b); */ /* trim unused digits */ @@ -302,6 +298,16 @@ int mp_init_copy(mp_int *a, mp_int *b); void mp_clamp(mp_int *a); */ +/* import binary data */ +/* +int mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails, const void *op); +*/ + +/* export binary data */ +/* +int mp_export(void *rop, size_t *countp, int order, size_t size, int endian, size_t nails, const mp_int *op); +*/ + /* ---> digit manipulation <--- */ /* right shift by "b" digits */ @@ -314,27 +320,27 @@ void mp_rshd(mp_int *a, int b); int mp_lshd(mp_int *a, int b); */ -/* c = a / 2**b */ +/* c = a / 2**b, implemented as c = a >> b */ /* int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d); */ /* b = a/2 */ /* -int mp_div_2(mp_int *a, mp_int *b); +int mp_div_2(const mp_int *a, mp_int *b); */ -/* c = a * 2**b */ +/* c = a * 2**b, implemented as c = a << b */ /* int mp_mul_2d(const mp_int *a, int b, mp_int *c); */ /* b = a*2 */ /* -int mp_mul_2(mp_int *a, mp_int *b); +int mp_mul_2(const mp_int *a, mp_int *b); */ -/* c = a mod 2**d */ +/* c = a mod 2**b */ /* int mp_mod_2d(const mp_int *a, int b, mp_int *c); */ @@ -356,24 +362,57 @@ int mp_cnt_lsb(const mp_int *a); int mp_rand(mp_int *a, int digits); */ +#ifdef MP_PRNG_ENABLE_LTM_RNG +/* as last resort we will fall back to libtomcrypt's rng_get_bytes() + * in case you don't use libtomcrypt or use it w/o rng_get_bytes() + * you have to implement it somewhere else, as it's required */ +extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); +extern void (*ltm_rng_callback)(void); +#endif + /* ---> binary operations <--- */ /* c = a XOR b */ /* -int mp_xor(mp_int *a, mp_int *b, mp_int *c); +int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a OR b */ /* -int mp_or(mp_int *a, mp_int *b, mp_int *c); +int mp_or(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a AND b */ /* -int mp_and(mp_int *a, mp_int *b, mp_int *c); +int mp_and(const mp_int *a, const mp_int *b, mp_int *c); +*/ + +/* c = a XOR b (two complement) */ +/* +int mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c); +*/ + +/* c = a OR b (two complement) */ +/* +int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c); +*/ + +/* c = a AND b (two complement) */ +/* +int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c); +*/ + +/* right shift (two complement) */ +/* +int mp_tc_div_2d(const mp_int *a, int b, mp_int *c); */ /* ---> Basic arithmetic <--- */ +/* b = ~a */ +/* +int mp_complement(const mp_int *a, mp_int *b); +*/ + /* b = -a */ /* int mp_neg(const mp_int *a, mp_int *b); @@ -381,7 +420,7 @@ int mp_neg(const mp_int *a, mp_int *b); /* b = |a| */ /* -int mp_abs(mp_int *a, mp_int *b); +int mp_abs(const mp_int *a, mp_int *b); */ /* compare a to b */ @@ -396,32 +435,32 @@ int mp_cmp_mag(const mp_int *a, const mp_int *b); /* c = a + b */ /* -int mp_add(mp_int *a, mp_int *b, mp_int *c); +int mp_add(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a - b */ /* -int mp_sub(mp_int *a, mp_int *b, mp_int *c); +int mp_sub(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a * b */ /* -int mp_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_mul(const mp_int *a, const mp_int *b, mp_int *c); */ /* b = a*a */ /* -int mp_sqr(mp_int *a, mp_int *b); +int mp_sqr(const mp_int *a, mp_int *b); */ /* a/b => cb + d == a */ /* -int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d); */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod(mp_int *a, mp_int *b, mp_int *c); +int mp_mod(const mp_int *a, const mp_int *b, mp_int *c); */ /* ---> single digit functions <--- */ @@ -433,79 +472,82 @@ int mp_cmp_d(const mp_int *a, mp_digit b); /* c = a + b */ /* -int mp_add_d(mp_int *a, mp_digit b, mp_int *c); +int mp_add_d(const mp_int *a, mp_digit b, mp_int *c); */ /* c = a - b */ /* -int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); */ /* c = a * b */ /* -int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); +int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); */ /* a/b => cb + d == a */ /* -int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); +int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); */ /* a/3 => 3c + d == a */ /* -int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); +int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); */ /* c = a**b */ /* -int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c); +*/ +/* +int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); +int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c); */ /* ---> number theory <--- */ /* d = a + b (mod c) */ /* -int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* d = a - b (mod c) */ /* -int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* d = a * b (mod c) */ /* -int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* c = a * a (mod b) */ /* -int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); +int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = 1/a (mod b) */ /* -int mp_invmod(mp_int *a, mp_int *b, mp_int *c); +int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = (a, b) */ /* -int mp_gcd(mp_int *a, mp_int *b, mp_int *c); +int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c); */ /* produces value such that U1*a + U2*b = U3 */ /* -int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); +int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); */ /* c = [a, b] or (a*b)/(a, b) */ /* -int mp_lcm(mp_int *a, mp_int *b, mp_int *c); +int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c); */ /* finds one of the b'th root of a, such that |c|**b <= |a| @@ -513,136 +555,144 @@ int mp_lcm(mp_int *a, mp_int *b, mp_int *c); * returns error if a < 0 and b is even */ /* -int mp_n_root(mp_int *a, mp_digit b, mp_int *c); +int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); +*/ +/* +int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); */ /* special sqrt algo */ /* -int mp_sqrt(mp_int *arg, mp_int *ret); +int mp_sqrt(const mp_int *arg, mp_int *ret); +*/ + +/* special sqrt (mod prime) */ +/* +int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); */ /* is number a square? */ /* -int mp_is_square(mp_int *arg, int *ret); +int mp_is_square(const mp_int *arg, int *ret); */ /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ /* -int mp_jacobi(mp_int *a, mp_int *n, int *c); +int mp_jacobi(const mp_int *a, const mp_int *n, int *c); */ /* used to setup the Barrett reduction for a given modulus b */ /* -int mp_reduce_setup(mp_int *a, mp_int *b); +int mp_reduce_setup(mp_int *a, const mp_int *b); */ /* Barrett Reduction, computes a (mod b) with a precomputed value c * - * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely - * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ /* -int mp_reduce(mp_int *a, mp_int *b, mp_int *c); +int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); */ /* setups the montgomery reduction */ /* -int mp_montgomery_setup(mp_int *a, mp_digit *mp); +int mp_montgomery_setup(const mp_int *n, mp_digit *rho); */ /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ /* -int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); +int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); */ /* computes x/R == x (mod N) via Montgomery Reduction */ /* -int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); */ /* returns 1 if a is a valid DR modulus */ /* -int mp_dr_is_modulus(mp_int *a); +int mp_dr_is_modulus(const mp_int *a); */ /* sets the value of "d" required for mp_dr_reduce */ /* -void mp_dr_setup(mp_int *a, mp_digit *d); +void mp_dr_setup(const mp_int *a, mp_digit *d); */ -/* reduces a modulo b using the Diminished Radix method */ +/* reduces a modulo n using the Diminished Radix method */ /* -int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); +int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); */ /* returns true if a can be reduced with mp_reduce_2k */ /* -int mp_reduce_is_2k(mp_int *a); +int mp_reduce_is_2k(const mp_int *a); */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup(mp_int *a, mp_digit *d); +int mp_reduce_2k_setup(const mp_int *a, mp_digit *d); */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); +int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d); */ /* returns true if a can be reduced with mp_reduce_2k_l */ /* -int mp_reduce_is_2k_l(mp_int *a); +int mp_reduce_is_2k_l(const mp_int *a); */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); +int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d); */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); +int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); */ -/* d = a**b (mod c) */ +/* Y = G**X (mod P) */ /* -int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); */ /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT -# define PRIME_SIZE 31 +# define PRIME_SIZE 31 #else -# define PRIME_SIZE 256 +# define PRIME_SIZE 256 #endif /* table of first PRIME_SIZE primes */ #if defined(BUILD_tcl) || !defined(_WIN32) -MODULE_SCOPE const mp_digit ltm_prime_tab[]; +MODULE_SCOPE const mp_digit ltm_prime_tab[PRIME_SIZE]; #endif /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ /* -int mp_prime_is_divisible(mp_int *a, int *result); +int mp_prime_is_divisible(const mp_int *a, int *result); */ /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_fermat(mp_int *a, mp_int *b, int *result); +int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result); */ /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); +int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result); */ /* This gives [for a given bit size] the number of trials required @@ -660,7 +710,7 @@ int mp_prime_rabin_miller_trials(int size); * Sets result to 1 if probably prime, 0 otherwise */ /* -int mp_prime_is_prime(mp_int *a, int t, int *result); +int mp_prime_is_prime(const mp_int *a, int t, int *result); */ /* finds the next prime after the number "a" using "t" trials @@ -689,7 +739,6 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) - * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can @@ -707,50 +756,52 @@ int mp_count_bits(const mp_int *a); */ /* -int mp_unsigned_bin_size(mp_int *a); +int mp_unsigned_bin_size(const mp_int *a); */ /* int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); */ /* -int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +int mp_to_unsigned_bin(const mp_int *a, unsigned char *b); */ /* -int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); */ /* -int mp_signed_bin_size(mp_int *a); +int mp_signed_bin_size(const mp_int *a); */ /* int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); */ /* -int mp_to_signed_bin(mp_int *a, unsigned char *b); +int mp_to_signed_bin(const mp_int *a, unsigned char *b); */ /* -int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); */ /* int mp_read_radix(mp_int *a, const char *str, int radix); */ /* -int mp_toradix(mp_int *a, char *str, int radix); +int mp_toradix(const mp_int *a, char *str, int radix); */ /* -int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen); */ /* -int mp_radix_size(mp_int *a, int radix, int *size); +int mp_radix_size(const mp_int *a, int radix, int *size); */ +#ifndef LTM_NO_FILE /* int mp_fread(mp_int *a, int radix, FILE *stream); */ /* -int mp_fwrite(mp_int *a, int radix, FILE *stream); +int mp_fwrite(const mp_int *a, int radix, FILE *stream); */ +#endif #define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) #define mp_raw_size(mp) mp_signed_bin_size(mp) @@ -764,69 +815,14 @@ int mp_fwrite(mp_int *a, int radix, FILE *stream); #define mp_todecimal(M, S) mp_toradix((M), (S), 10) #define mp_tohex(M, S) mp_toradix((M), (S), 16) -/* lowlevel functions, do not call! */ -/* -int s_mp_add(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); -*/ -#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) -/* -int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int fast_s_mp_sqr(mp_int *a, mp_int *b); -*/ -/* -int s_mp_sqr(mp_int *a, mp_int *b); -*/ -/* -int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_karatsuba_sqr(mp_int *a, mp_int *b); -*/ -/* -int mp_toom_sqr(mp_int *a, mp_int *b); -*/ -/* -int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); -*/ -/* -int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); -*/ -/* -int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); -*/ -/* -int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); -*/ -/* -void bn_reverse(unsigned char *s, int len); -*/ - -#if defined(BUILD_tcl) || !defined(_WIN32) -MODULE_SCOPE const char *mp_s_rmap; -#endif - #ifdef __cplusplus } #endif #endif + + +/* ref: $Format:%D$ */ +/* git commit: $Format:%H$ */ +/* commit time: $Format:%ai$ */ + diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 2ce9d5a..9fc034f 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -73,6 +73,10 @@ #define mp_div_d TclBN_mp_div_d #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_d +#define mp_expt_d_ex TclBN_mp_expt_d_ex +#define mp_get_int TclBN_mp_get_int +#define mp_get_long TclBN_mp_get_long +#define mp_get_long_long TclBN_mp_get_long_long #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy @@ -94,9 +98,10 @@ #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd -#define mp_s_rmap TclBNMpSRmap #define mp_set TclBN_mp_set #define mp_set_int TclBN_mp_set_int +#define mp_set_long TclBN_mp_set_long +#define mp_set_long_long TclBN_mp_set_long_long #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt @@ -147,11 +152,14 @@ EXTERN int TclBN_epoch(void); /* 1 */ EXTERN int TclBN_revision(void); /* 2 */ -EXTERN int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); /* 3 */ -EXTERN int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_add_d(const mp_int *a, mp_digit b, + mp_int *c); /* 4 */ -EXTERN int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_and(const mp_int *a, const mp_int *b, + mp_int *c); /* 5 */ EXTERN void TclBN_mp_clamp(mp_int *a); /* 6 */ @@ -169,28 +177,30 @@ EXTERN int TclBN_mp_copy(const mp_int *a, mp_int *b); /* 12 */ EXTERN int TclBN_mp_count_bits(const mp_int *a); /* 13 */ -EXTERN int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, - mp_int *r); +EXTERN int TclBN_mp_div(const mp_int *a, const mp_int *b, + mp_int *q, mp_int *r); /* 14 */ -EXTERN int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, - mp_digit *r); +EXTERN int TclBN_mp_div_d(const mp_int *a, mp_digit b, + mp_int *q, mp_digit *r); /* 15 */ -EXTERN int TclBN_mp_div_2(mp_int *a, mp_int *q); +EXTERN int TclBN_mp_div_2(const mp_int *a, mp_int *q); /* 16 */ EXTERN int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r); /* 17 */ -EXTERN int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r); +EXTERN int TclBN_mp_div_3(const mp_int *a, mp_int *q, + mp_digit *r); /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ -EXTERN int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_expt_d(const mp_int *a, mp_digit b, + mp_int *c); /* 20 */ EXTERN int TclBN_mp_grow(mp_int *a, int size); /* 21 */ EXTERN int TclBN_mp_init(mp_int *a); /* 22 */ -EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_init_copy(mp_int *a, const mp_int *b); /* 23 */ EXTERN int TclBN_mp_init_multi(mp_int *a, ...); /* 24 */ @@ -200,23 +210,28 @@ EXTERN int TclBN_mp_init_size(mp_int *a, int size); /* 26 */ EXTERN int TclBN_mp_lshd(mp_int *a, int shift); /* 27 */ -EXTERN int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r); +EXTERN int TclBN_mp_mod(const mp_int *a, const mp_int *b, + mp_int *r); /* 28 */ EXTERN int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r); /* 29 */ -EXTERN int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p); +EXTERN int TclBN_mp_mul(const mp_int *a, const mp_int *b, + mp_int *p); /* 30 */ -EXTERN int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p); +EXTERN int TclBN_mp_mul_d(const mp_int *a, mp_digit b, + mp_int *p); /* 31 */ -EXTERN int TclBN_mp_mul_2(mp_int *a, mp_int *p); +EXTERN int TclBN_mp_mul_2(const mp_int *a, mp_int *p); /* 32 */ EXTERN int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p); /* 33 */ EXTERN int TclBN_mp_neg(const mp_int *a, mp_int *b); /* 34 */ -EXTERN int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_or(const mp_int *a, const mp_int *b, + mp_int *c); /* 35 */ -EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size); +EXTERN int TclBN_mp_radix_size(const mp_int *a, int radix, + int *size); /* 36 */ EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str, int radix); @@ -227,52 +242,59 @@ EXTERN int TclBN_mp_shrink(mp_int *a); /* 39 */ EXTERN void TclBN_mp_set(mp_int *a, mp_digit b); /* 40 */ -EXTERN int TclBN_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_sqr(const mp_int *a, mp_int *b); /* 41 */ -EXTERN int TclBN_mp_sqrt(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_sqrt(const mp_int *a, mp_int *b); /* 42 */ -EXTERN int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); /* 43 */ -EXTERN int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_sub_d(const mp_int *a, mp_digit b, + mp_int *c); /* 44 */ -EXTERN int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b); +EXTERN int TclBN_mp_to_unsigned_bin(const mp_int *a, + unsigned char *b); /* 45 */ -EXTERN int TclBN_mp_to_unsigned_bin_n(mp_int *a, +EXTERN int TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); /* 46 */ -EXTERN int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, - int maxlen); +EXTERN int TclBN_mp_toradix_n(const mp_int *a, char *str, + int radix, int maxlen); /* 47 */ -EXTERN int TclBN_mp_unsigned_bin_size(mp_int *a); +EXTERN int TclBN_mp_unsigned_bin_size(const mp_int *a); /* 48 */ -EXTERN int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_xor(const mp_int *a, const mp_int *b, + mp_int *c); /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); /* 50 */ EXTERN void TclBN_reverse(unsigned char *s, int len); /* 51 */ -EXTERN int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, - mp_int *c, int digs); +EXTERN int TclBN_fast_s_mp_mul_digs(const mp_int *a, + const mp_int *b, mp_int *c, int digs); /* 52 */ -EXTERN int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); /* 53 */ -EXTERN int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, - mp_int *c); +EXTERN int TclBN_mp_karatsuba_mul(const mp_int *a, + const mp_int *b, mp_int *c); /* 54 */ -EXTERN int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); /* 55 */ -EXTERN int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, + mp_int *c); /* 56 */ -EXTERN int TclBN_mp_toom_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); /* 57 */ -EXTERN int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_s_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); /* 58 */ -EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, - int digs); +EXTERN int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, + mp_int *c, int digs); /* 59 */ -EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); /* 60 */ -EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); /* 61 */ EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); /* 62 */ @@ -280,13 +302,29 @@ EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); /* 64 */ -EXTERN void TclBNInitBignumFromLong(mp_int *bignum, long initVal); +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromLong(mp_int *bignum, long initVal); /* 65 */ -EXTERN void TclBNInitBignumFromWideInt(mp_int *bignum, +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal); /* 66 */ -EXTERN void TclBNInitBignumFromWideUInt(mp_int *bignum, +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal); +/* 67 */ +EXTERN int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, + mp_int *c, int fast); +/* 68 */ +EXTERN int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i); +/* 69 */ +EXTERN Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a); +/* 70 */ +EXTERN int TclBN_mp_set_long(mp_int *a, unsigned long i); +/* 71 */ +EXTERN unsigned long TclBN_mp_get_long(const mp_int *a); +/* 72 */ +EXTERN unsigned long TclBN_mp_get_int(const mp_int *a); typedef struct TclTomMathStubs { int magic; @@ -294,9 +332,9 @@ typedef struct TclTomMathStubs { int (*tclBN_epoch) (void); /* 0 */ int (*tclBN_revision) (void); /* 1 */ - int (*tclBN_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 2 */ - int (*tclBN_mp_add_d) (mp_int *a, mp_digit b, mp_int *c); /* 3 */ - int (*tclBN_mp_and) (mp_int *a, mp_int *b, mp_int *c); /* 4 */ + int (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */ + int (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */ + int (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */ void (*tclBN_mp_clamp) (mp_int *a); /* 5 */ void (*tclBN_mp_clear) (mp_int *a); /* 6 */ void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */ @@ -305,60 +343,66 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */ int (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */ int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */ - int (*tclBN_mp_div) (mp_int *a, mp_int *b, mp_int *q, mp_int *r); /* 13 */ - int (*tclBN_mp_div_d) (mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ - int (*tclBN_mp_div_2) (mp_int *a, mp_int *q); /* 15 */ + int (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */ + int (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ + int (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */ int (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */ - int (*tclBN_mp_div_3) (mp_int *a, mp_int *q, mp_digit *r); /* 17 */ + int (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */ void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - int (*tclBN_mp_expt_d) (mp_int *a, mp_digit b, mp_int *c); /* 19 */ + int (*tclBN_mp_expt_d) (const mp_int *a, mp_digit b, mp_int *c); /* 19 */ int (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */ int (*tclBN_mp_init) (mp_int *a); /* 21 */ - int (*tclBN_mp_init_copy) (mp_int *a, mp_int *b); /* 22 */ + int (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */ int (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */ int (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */ int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */ int (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */ - int (*tclBN_mp_mod) (mp_int *a, mp_int *b, mp_int *r); /* 27 */ + int (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */ int (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */ - int (*tclBN_mp_mul) (mp_int *a, mp_int *b, mp_int *p); /* 29 */ - int (*tclBN_mp_mul_d) (mp_int *a, mp_digit b, mp_int *p); /* 30 */ - int (*tclBN_mp_mul_2) (mp_int *a, mp_int *p); /* 31 */ + int (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */ + int (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */ + int (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */ int (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */ int (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */ - int (*tclBN_mp_or) (mp_int *a, mp_int *b, mp_int *c); /* 34 */ - int (*tclBN_mp_radix_size) (mp_int *a, int radix, int *size); /* 35 */ + int (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */ + int (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */ int (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ int (*tclBN_mp_shrink) (mp_int *a); /* 38 */ void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */ - int (*tclBN_mp_sqr) (mp_int *a, mp_int *b); /* 40 */ - int (*tclBN_mp_sqrt) (mp_int *a, mp_int *b); /* 41 */ - int (*tclBN_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 42 */ - int (*tclBN_mp_sub_d) (mp_int *a, mp_digit b, mp_int *c); /* 43 */ - int (*tclBN_mp_to_unsigned_bin) (mp_int *a, unsigned char *b); /* 44 */ - int (*tclBN_mp_to_unsigned_bin_n) (mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ - int (*tclBN_mp_toradix_n) (mp_int *a, char *str, int radix, int maxlen); /* 46 */ - int (*tclBN_mp_unsigned_bin_size) (mp_int *a); /* 47 */ - int (*tclBN_mp_xor) (mp_int *a, mp_int *b, mp_int *c); /* 48 */ + int (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ + int (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */ + int (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */ + int (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */ + int (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ + int (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ + int (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ + int (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ + int (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ - int (*tclBN_fast_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 51 */ - int (*tclBN_fast_s_mp_sqr) (mp_int *a, mp_int *b); /* 52 */ - int (*tclBN_mp_karatsuba_mul) (mp_int *a, mp_int *b, mp_int *c); /* 53 */ - int (*tclBN_mp_karatsuba_sqr) (mp_int *a, mp_int *b); /* 54 */ - int (*tclBN_mp_toom_mul) (mp_int *a, mp_int *b, mp_int *c); /* 55 */ - int (*tclBN_mp_toom_sqr) (mp_int *a, mp_int *b); /* 56 */ - int (*tclBN_s_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 57 */ - int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ - int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ - int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ + int (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ + int (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ + int (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ + int (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ + int (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ + int (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ + int (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ + int (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ + int (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ + int (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ - void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ - void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ - void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ + int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ + int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */ + Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */ + int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */ + unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */ + unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */ } TclTomMathStubs; extern const TclTomMathStubs *tclTomMathStubsPtr; @@ -507,6 +551,18 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */ #define TclBNInitBignumFromWideUInt \ (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */ +#define TclBN_mp_expt_d_ex \ + (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ +#define TclBN_mp_set_long_long \ + (tclTomMathStubsPtr->tclBN_mp_set_long_long) /* 68 */ +#define TclBN_mp_get_long_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */ +#define TclBN_mp_set_long \ + (tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */ +#define TclBN_mp_get_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */ +#define TclBN_mp_get_int \ + (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 48db8c3..9e7bf4b 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -89,86 +89,11 @@ TclBN_revision(void) { return TCLTOMMATH_REVISION; } -#if 0 /* *---------------------------------------------------------------------- * - * TclBNAlloc -- - * - * Allocate memory for libtommath. - * - * Results: - * Returns a pointer to the allocated block. - * - * This procedure is a wrapper around Tcl_Alloc, needed because of a - * mismatched type signature between Tcl_Alloc and malloc. - * - *---------------------------------------------------------------------- - */ - -extern void * -TclBNAlloc( - size_t x) -{ - return (void *) ckalloc((unsigned int) x); -} - -/* - *---------------------------------------------------------------------- - * - * TclBNRealloc -- - * - * Change the size of an allocated block of memory in libtommath - * - * Results: - * Returns a pointer to the allocated block. - * - * This procedure is a wrapper around Tcl_Realloc, needed because of a - * mismatched type signature between Tcl_Realloc and realloc. - * - *---------------------------------------------------------------------- - */ - -void * -TclBNRealloc( - void *p, - size_t s) -{ - return (void *) ckrealloc((char *) p, (unsigned int) s); -} - -/* - *---------------------------------------------------------------------- - * - * TclBNFree -- - * - * Free allocated memory in libtommath. - * - * Results: - * None. - * - * Side effects: - * Memory is freed. - * - * This function is simply a wrapper around Tcl_Free, needed in libtommath - * because of a type mismatch between free and Tcl_Free. - * - *---------------------------------------------------------------------- - */ - -extern void -TclBNFree( - void *p) -{ - ckree((char *) p); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclBNInitBignumFromLong -- + * TclInitBignumFromLong -- * * Allocate and initialize a 'bignum' from a native 'long'. * @@ -181,47 +106,20 @@ TclBNFree( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromLong( +void +TclInitBignumFromLong( mp_int *a, - long initVal) + long v) { - int status; - unsigned long v; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible long - */ - - status = mp_init_size(a, - (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); + if (mp_init_size(a, (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromLong"); } - - /* - * Convert arg to sign and magnitude. - */ - - if (initVal < 0) { - a->sign = MP_NEG; - v = -initVal; + if (v < (long)0) { + mp_set_long_long(a, (Tcl_WideUInt)(-(Tcl_WideInt)v)); + mp_neg(a, a); } else { - a->sign = MP_ZPOS; - v = initVal; - } - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; + mp_set_long_long(a, (Tcl_WideUInt)v); } - a->used = p - a->dp; } /* @@ -240,16 +138,19 @@ TclBNInitBignumFromLong( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideInt( +void +TclInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { + if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideInt"); + } if (v < (Tcl_WideInt)0) { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); + mp_set_long_long(a, (Tcl_WideUInt)(-v)); mp_neg(a, a); } else { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + mp_set_long_long(a, (Tcl_WideUInt)v); } } @@ -269,36 +170,15 @@ TclBNInitBignumFromWideInt( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideUInt( +void +TclInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - int status; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible Tcl_WideUInt. - */ - - status = mp_init_size(a, - (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); - } - - a->sign = MP_ZPOS; - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; - } - a->used = p - a->dp; + if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideUInt"); + } + mp_set_long_long(a, v); } /* diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 4e74c54..8663eae 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -52,7 +52,7 @@ typedef struct { * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -191,8 +191,10 @@ Tcl_TraceObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; +#ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; +#endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", @@ -278,7 +280,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -365,12 +367,14 @@ Tcl_TraceObjCmd( } return TCL_OK; +#ifndef TCL_REMOVE_OBSOLETE_TRACES badVarOps: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad operations \"%s\": should be one or more of rwua", flagOps)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); return TCL_ERROR; +#endif } /* @@ -462,7 +466,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -701,7 +705,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -904,7 +908,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( @@ -912,9 +916,11 @@ TraceVariableObjCmd( + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; +#ifndef TCL_REMOVE_OBSOLETE_TRACES if (objv[0] == NULL) { ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } +#endif ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); @@ -939,7 +945,11 @@ TraceVariableObjCmd( TraceVarInfo *tvarPtr = clientData; if ((tvarPtr->length == length) - && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) + && ((tvarPtr->flags +#ifndef TCL_REMOVE_OBSOLETE_TRACES +& ~TCL_TRACE_OLD_STYLE +#endif + )==flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, @@ -2468,6 +2478,47 @@ TclVarTraceExists( /* *---------------------------------------------------------------------- * + * TclCheckArrayTraces -- + * + * This function is invoked to when we operate on an array variable, + * to allow any array traces to fire. + * + * Results: + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned, then error information is left in interp. + * + * Side effects: + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckArrayTraces( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *name, + int index) +{ + int code = TCL_OK; + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + Interp *iPtr = (Interp *)interp; + + code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, + (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), + /* leaveErrMsg */ 1, index); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCallVarTraces -- * * This function is invoked to find and invoke relevant trace functions @@ -2819,6 +2870,7 @@ DisposeTraceResult( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UntraceVar void Tcl_UntraceVar( @@ -2834,6 +2886,7 @@ Tcl_UntraceVar( { Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2988,6 +3041,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_VarTraceInfo ClientData Tcl_VarTraceInfo( @@ -3005,6 +3059,7 @@ Tcl_VarTraceInfo( return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3097,6 +3152,7 @@ Tcl_VarTraceInfo2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_TraceVar int Tcl_TraceVar( @@ -3114,6 +3170,7 @@ Tcl_TraceVar( { return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 9f05230..faca93d 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -42,22 +42,22 @@ static const unsigned short pageMap[] = { 4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672, 1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344, 4992, 5024, 5056, 5088, 1824, 1824, 5120, 5152, 5184, 5216, 5248, 5280, - 1344, 5312, 1344, 5344, 5376, 5408, 5440, 1824, 5472, 5504, 5536, 5568, - 5600, 5632, 5664, 5600, 704, 5696, 224, 224, 224, 224, 5728, 224, 224, - 224, 5760, 5792, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, - 6112, 6144, 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, - 6496, 6528, 6528, 6528, 6528, 6528, 6528, 6528, 6528, 6560, 6592, 4928, - 6624, 6656, 6688, 6720, 6752, 4928, 6784, 6816, 6848, 6880, 6912, 6944, - 6976, 4928, 4928, 4928, 4928, 4928, 7008, 7040, 7072, 4928, 4928, 4928, - 7104, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7136, 7168, 4928, 7200, - 7232, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6528, 6528, 6528, - 6528, 7264, 6528, 7296, 7328, 6528, 6528, 6528, 6528, 6528, 6528, 6528, - 6528, 4928, 7360, 7392, 7424, 7456, 7488, 7520, 7552, 7584, 7616, 7648, + 1344, 5312, 1344, 5344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, + 5632, 5664, 5696, 5632, 704, 5728, 224, 224, 224, 224, 5760, 224, 224, + 224, 5792, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, + 6144, 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, + 6528, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6592, 6624, 4928, + 6656, 6688, 6720, 6752, 6784, 4928, 6816, 6848, 6880, 6912, 6944, 6976, + 7008, 4928, 4928, 4928, 4928, 4928, 7040, 7072, 7104, 4928, 4928, 4928, + 7136, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7168, 7200, 4928, 7232, + 7264, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6560, 6560, 6560, + 6560, 7296, 6560, 7328, 7360, 6560, 6560, 6560, 6560, 6560, 6560, 6560, + 6560, 4928, 7392, 7424, 7456, 7488, 4928, 7520, 7552, 7584, 7616, 7648, 7680, 224, 224, 224, 7712, 7744, 7776, 1344, 7808, 7840, 7872, 7872, 704, 7904, 7936, 7968, 1824, 8000, 4928, 4928, 8032, 4928, 4928, 4928, 4928, 4928, 4928, 8064, 8096, 8128, 8160, 3232, 1344, 8192, 4192, 1344, - 8224, 8256, 8288, 1344, 1344, 8320, 8352, 4928, 8384, 8416, 8448, 8480, - 4928, 8448, 8512, 4928, 8416, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 8224, 8256, 8288, 1344, 1344, 8320, 8352, 4928, 8384, 7552, 8416, 8448, + 4928, 8416, 8480, 4928, 7552, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -130,7 +130,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, - 1792, 8544, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 8512, 8544, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8576, 4928, 8608, 5408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -203,37 +203,37 @@ static const unsigned short pageMap[] = { 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 7840, 4704, 10272, 1824, 1824, 1824, 1824, 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744, 11776, - 1824, 1824, 1344, 11808, 11840, 6848, 11872, 11904, 11936, 11968, 12000, + 1824, 1824, 1344, 11808, 11840, 6880, 11872, 11904, 11936, 11968, 12000, 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224, 1824, - 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12416, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448, - 12480, 12512, 12544, 5248, 12576, 12608, 12640, 12672, 12704, 12736, - 12768, 5248, 12800, 12832, 12864, 12896, 12928, 1824, 1824, 12960, - 12992, 13024, 13056, 13088, 2368, 13120, 13152, 1824, 1824, 1824, 1824, - 1344, 13184, 13216, 1824, 1344, 13248, 13280, 1824, 1824, 1824, 1824, - 1824, 1344, 13312, 13344, 1824, 1344, 13376, 13408, 13440, 1344, 13472, - 13504, 1824, 13536, 13568, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 13600, 13632, 13664, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 13696, 13728, 13760, 1344, 13792, 13824, 1344, - 13856, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13888, 13920, - 13952, 13984, 14016, 14048, 1824, 1824, 14080, 14112, 14144, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, + 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344, 12416, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448, 1824, + 1824, 1824, 1824, 12000, 12480, 12512, 1824, 1824, 1824, 1824, 1824, + 12544, 12576, 12608, 12640, 5248, 12672, 12704, 12736, 12768, 12800, + 12832, 12864, 5248, 12896, 12928, 12960, 12992, 13024, 1824, 1824, + 13056, 13088, 13120, 13152, 13184, 13216, 13248, 13280, 1824, 1824, + 1824, 1824, 1344, 13312, 13344, 1824, 1344, 13376, 13408, 1824, 1824, + 1824, 1824, 1824, 1344, 13440, 13472, 1824, 1344, 13504, 13536, 13568, + 1344, 13600, 13632, 1824, 4032, 13664, 1824, 1824, 1824, 1824, 1824, + 1824, 1344, 13696, 1824, 1824, 1824, 13728, 13760, 13792, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 13824, 13856, 13888, 1344, 13920, + 13952, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 13984, 14016, 14048, 14080, 14112, 14144, 1824, 1824, 14176, 14208, + 14240, 14272, 14304, 13632, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 14336, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 9984, 1824, 1824, 1824, 10848, 10848, 10848, 14176, 1344, 1344, 1344, - 1344, 1344, 1344, 14208, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 9984, 1824, 1824, 1824, 10848, 10848, 10848, + 14368, 1344, 1344, 1344, 1344, 1344, 1344, 14400, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 14240, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14432, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, @@ -243,10 +243,9 @@ static const unsigned short pageMap[] = { 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 14272, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14464, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, @@ -268,12 +267,13 @@ static const unsigned short pageMap[] = { 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 13856, 4736, 14304, 1824, 1824, 10208, - 14336, 1344, 14368, 14400, 14432, 14464, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, - 14496, 14528, 14560, 1824, 1824, 14592, 1344, 1344, 1344, 1344, 1344, + 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736, 14496, + 1824, 1824, 10208, 14528, 1344, 14560, 14592, 14624, 8512, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13728, 13760, 14656, 1824, + 1824, 1824, 1344, 1344, 14688, 14720, 14752, 1824, 1824, 14784, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -289,9 +289,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, 14624, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14816, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14656, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14848, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, @@ -316,17 +316,16 @@ static const unsigned short pageMap[] = { 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 4736, 1824, 1824, 10208, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 9856, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 4736, 1824, 1824, 10208, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9856, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 14688, 14720, - 14752, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, + 14880, 14912, 14944, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, @@ -338,41 +337,42 @@ static const unsigned short pageMap[] = { 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8064, 4928, 14784, 4928, - 14816, 14848, 14880, 4928, 14912, 4928, 4928, 14944, 1824, 1824, 1824, - 1824, 1824, 4928, 4928, 14976, 15008, 1824, 1824, 1824, 1824, 15040, - 15072, 15104, 15136, 15168, 15200, 15232, 15264, 15296, 15328, 15360, - 15392, 15424, 15040, 15072, 15456, 15136, 15488, 15520, 15552, 15264, - 15584, 15616, 15648, 15680, 15712, 15744, 15776, 15808, 15840, 15872, - 15904, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, - 4928, 4928, 4928, 4928, 4928, 4928, 704, 15936, 704, 15968, 16000, - 16032, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8064, 4928, 14976, + 4928, 15008, 15040, 15072, 4928, 15104, 4928, 4928, 15136, 1824, 1824, + 1824, 1824, 15168, 4928, 4928, 15200, 15232, 1824, 1824, 1824, 1824, + 15264, 15296, 15328, 15360, 15392, 15424, 15456, 15488, 15520, 15552, + 15584, 15616, 15648, 15264, 15296, 15680, 15360, 15712, 15744, 15776, + 15488, 15808, 15840, 15872, 15904, 15936, 15968, 16000, 16032, 16064, + 16096, 16128, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, 16160, 704, 16192, 16224, + 16256, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 16064, 16096, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 16288, 16320, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1344, 1344, 1344, 1344, 1344, 1344, 16128, 1824, 16160, 16192, - 16224, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1344, 1344, 1344, 1344, 1344, 1344, 16352, 1824, 16384, 16416, + 16448, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 16256, 16288, 16320, 16352, 16384, 16416, 1824, 16448, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 16480, 4928, - 4928, 8032, 16512, 16544, 8064, 16576, 16608, 4928, 16480, 4928, 16640, - 1824, 16672, 16704, 16736, 16768, 16800, 1824, 1824, 1824, 1824, 4928, - 4928, 4928, 4928, 4928, 4928, 4928, 16832, 4928, 4928, 4928, 4928, + 1824, 1824, 16480, 6880, 16512, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 16544, 16576, 16608, 16640, 16672, 16704, 1824, + 16736, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 16768, + 4928, 4928, 8032, 16800, 16832, 8064, 16864, 4928, 4928, 16768, 4928, + 16896, 1824, 16928, 16960, 16992, 17024, 17056, 1824, 1824, 1824, 1824, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17088, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, - 4928, 4928, 4928, 4928, 4928, 4928, 16864, 16896, 4928, 4928, 4928, - 8032, 4928, 4928, 16864, 1824, 16480, 4928, 16928, 4928, 16960, 16992, - 1824, 1824, 16480, 8416, 17024, 17056, 17088, 1824, 17120, 6784, 1824, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17120, 17152, 4928, 4928, + 4928, 8032, 4928, 4928, 17184, 1824, 16768, 4928, 17216, 4928, 17248, + 17280, 1824, 1824, 16768, 7552, 4928, 17312, 4928, 17344, 16960, 4928, + 1824, 1824, 1824, 17280, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -483,7 +483,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 7840, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 7840, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -494,7 +494,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 17152, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1344, 1344, 1344, + 1344, 1344, 17376, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -509,7 +509,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 17184, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 17408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -529,7 +529,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 17216, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 17440, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, @@ -537,8 +537,8 @@ static const unsigned short pageMap[] = { 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360 + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360 #endif /* TCL_UTF_MAX > 3 */ }; @@ -616,100 +616,100 @@ static const unsigned char groupMap[] = { 23, 24, 23, 24, 0, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 0, 0, 91, 3, 3, 3, 3, 3, 3, 0, 123, 123, 123, 123, 123, 123, 123, 123, + 0, 0, 91, 3, 3, 3, 3, 3, 3, 21, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, - 123, 123, 21, 0, 3, 8, 0, 0, 14, 14, 4, 0, 92, 92, 92, 92, 92, 92, + 123, 123, 123, 21, 21, 3, 8, 0, 0, 14, 14, 4, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 8, 92, 3, 92, 92, 3, 92, 92, 3, 92, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 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, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 92, + 92, 92, 92, 92, 92, 92, 8, 92, 3, 92, 92, 3, 92, 92, 3, 92, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, + 17, 17, 17, 7, 7, 7, 3, 3, 4, 3, 3, 14, 14, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, + 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 3, 15, 92, 92, 92, 92, 92, 92, 92, 17, 14, 92, 92, 92, 92, 92, - 92, 91, 91, 92, 92, 14, 92, 92, 92, 92, 15, 15, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 14, 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 0, 17, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 3, 15, 92, 92, 92, 92, 92, 92, 92, 17, 14, 92, 92, 92, 92, + 92, 92, 91, 91, 92, 92, 14, 92, 92, 92, 92, 15, 15, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 15, 14, 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 0, 17, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 91, 91, 14, 3, 3, 3, 91, 0, 0, 0, 0, 0, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 91, 91, 14, 3, 3, 3, 91, 0, 0, + 92, 4, 4, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 91, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 91, 92, 92, 92, 91, 92, 92, 92, 92, 92, 0, 0, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 92, 92, 92, 92, 91, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 91, 92, 92, 92, 91, 92, 92, 92, 92, 92, 0, 0, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, - 92, 92, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 92, 92, 92, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 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, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 17, 92, 92, 92, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 17, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, - 124, 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, - 124, 124, 92, 124, 124, 15, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 92, 92, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 3, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 0, 0, - 15, 15, 15, 15, 0, 0, 92, 15, 124, 124, 124, 92, 92, 92, 92, 0, 0, - 124, 124, 0, 0, 124, 124, 92, 15, 0, 0, 0, 0, 0, 0, 0, 0, 124, 0, 0, - 0, 0, 15, 15, 0, 15, 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, 15, 3, 0, 0, 0, - 92, 92, 124, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, - 0, 15, 15, 0, 0, 92, 0, 124, 124, 124, 92, 92, 0, 0, 0, 0, 92, 92, - 0, 0, 92, 92, 92, 0, 0, 0, 92, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, - 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, 92, 15, - 15, 15, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 124, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 92, 124, 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, + 92, 124, 124, 124, 124, 92, 124, 124, 15, 92, 92, 92, 92, 92, 92, 92, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 3, 3, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 3, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 0, 0, 0, 15, 15, 15, 15, 0, 0, 92, 15, 124, 124, 124, 92, 92, 92, 92, + 0, 0, 124, 124, 0, 0, 124, 124, 92, 15, 0, 0, 0, 0, 0, 0, 0, 0, 124, + 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, 15, 3, 92, + 0, 0, 92, 92, 124, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, + 15, 15, 0, 15, 15, 0, 0, 92, 0, 124, 124, 124, 92, 92, 0, 0, 0, 0, + 92, 92, 0, 0, 92, 92, 92, 0, 0, 0, 92, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, + 92, 15, 15, 15, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 124, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, + 0, 0, 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 0, 92, 92, 124, 0, + 124, 124, 92, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, 0, 0, 0, + 0, 0, 0, 0, 15, 92, 92, 92, 92, 92, 92, 0, 92, 124, 124, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, - 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 0, 92, 92, 124, 0, 124, - 124, 92, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, 0, 0, 0, 0, 0, - 0, 0, 15, 92, 92, 92, 92, 92, 92, 0, 92, 124, 124, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 92, 15, - 124, 92, 124, 92, 92, 92, 92, 0, 0, 124, 124, 0, 0, 124, 124, 92, 0, - 0, 0, 0, 0, 0, 0, 0, 92, 124, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 92, - 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18, 18, 18, 18, - 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 0, 15, 15, 15, 15, 15, 15, - 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15, 0, 15, 0, - 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 124, 124, 92, 124, + 92, 15, 124, 92, 124, 92, 92, 92, 92, 0, 0, 124, 124, 0, 0, 124, 124, + 92, 0, 0, 0, 0, 0, 0, 0, 0, 92, 124, 0, 0, 0, 0, 15, 15, 0, 15, 15, + 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18, 18, + 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 0, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15, 0, + 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 124, 124, 92, 124, 124, 0, 0, 0, 124, 124, 124, 0, 124, 124, 124, 92, 0, 0, 15, 0, 0, 0, 0, 0, 0, 124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, 4, 14, 0, - 0, 0, 0, 0, 92, 124, 124, 124, 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, + 0, 0, 0, 0, 92, 124, 124, 124, 92, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 92, 92, 92, 124, 124, 124, 124, 0, 92, 92, 92, 0, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 92, 92, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, - 18, 18, 14, 15, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 18, 18, 14, 15, 92, 124, 124, 3, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 92, 15, 124, 92, 124, @@ -764,353 +764,355 @@ static const unsigned char groupMap[] = { 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 0, 125, 0, 0, 0, 0, 0, 125, 0, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 91, 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, 92, 92, 92, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 0, 0, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, - 126, 126, 126, 126, 126, 126, 126, 126, 126, 104, 104, 104, 104, 104, - 104, 0, 0, 110, 110, 110, 110, 110, 110, 0, 0, 8, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 2, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 5, - 6, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 127, - 127, 127, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, - 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 3, 3, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, - 0, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, - 124, 92, 92, 92, 92, 92, 92, 92, 124, 124, 124, 124, 124, 124, 124, - 124, 92, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 3, - 3, 91, 3, 3, 3, 4, 15, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 92, 92, 92, 17, 0, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 91, 15, 15, 15, 15, + 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, + 126, 3, 91, 126, 126, 126, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, + 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 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, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 0, 0, 0, 0, 0, 15, + 15, 0, 0, 92, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 104, 104, 104, 104, 104, 104, 0, 0, 110, 110, 110, 110, + 110, 110, 0, 0, 8, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 2, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 5, 6, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 128, 128, 128, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 92, 92, 92, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 92, 92, 92, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 92, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 124, 92, 92, 92, 92, 92, 92, + 92, 124, 124, 124, 124, 124, 124, 124, 124, 92, 124, 124, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 3, 3, 3, 91, 3, 3, 3, 4, 15, 92, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, + 3, 3, 92, 92, 92, 17, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 92, 92, 92, 124, 124, 124, 124, 92, - 92, 124, 124, 124, 0, 0, 0, 0, 124, 124, 92, 124, 124, 124, 124, 124, - 124, 92, 92, 92, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 92, 92, 124, 124, 92, 0, 0, 3, 3, 15, 15, 15, + 15, 15, 92, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 124, 92, 124, 92, 92, 92, 92, 92, 92, 92, 0, 92, 124, 92, 124, - 124, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 124, 124, 124, 124, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 92, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, - 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 91, 3, 3, 3, 3, 3, 3, 0, 0, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 119, 0, 92, 92, 92, 92, - 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 92, 92, 92, 124, 124, 124, 124, 92, 92, 124, 124, 124, 0, 0, 0, 0, + 124, 124, 92, 124, 124, 124, 124, 124, 124, 92, 92, 92, 0, 0, 0, 0, + 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 92, - 92, 92, 92, 92, 124, 92, 124, 124, 124, 124, 124, 92, 124, 124, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, - 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, - 92, 92, 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, - 92, 92, 92, 92, 124, 124, 92, 92, 124, 92, 92, 92, 15, 15, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 124, 92, 92, 124, 124, 124, 92, 124, 92, 92, 92, 124, 124, 0, 0, - 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 124, 124, 124, 124, 124, - 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 0, - 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 15, 15, - 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 91, 91, 91, 91, 91, 91, 3, 3, 128, 129, 130, 131, 131, - 132, 133, 134, 135, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 92, 92, 92, 3, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 124, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, 15, 92, 15, 15, 15, 15, - 124, 124, 92, 15, 15, 124, 92, 92, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 92, 124, 124, 92, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 92, 124, 92, 92, + 92, 92, 92, 92, 92, 0, 92, 124, 92, 124, 124, 92, 92, 92, 92, 92, 92, + 92, 92, 124, 124, 124, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 0, 0, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 91, + 3, 3, 3, 3, 3, 3, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 119, 0, 92, 92, 92, 92, 124, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 92, 124, 92, 92, 92, 92, 92, 124, 92, 124, + 124, 124, 124, 124, 92, 124, 124, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, 92, 92, 92, 92, 92, 92, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 92, 92, 124, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 92, 92, 92, 92, 124, 124, + 92, 92, 124, 92, 92, 92, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 92, 92, 124, 124, + 124, 92, 124, 92, 92, 92, 124, 124, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, + 3, 15, 15, 15, 15, 124, 124, 124, 124, 124, 124, 124, 124, 92, 92, + 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 0, 0, 0, 3, 3, 3, 3, 3, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 91, + 91, 91, 91, 91, 3, 3, 129, 130, 131, 132, 132, 133, 134, 135, 136, + 0, 0, 0, 0, 0, 0, 0, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 0, 0, 137, 137, 137, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 3, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, + 15, 92, 15, 15, 15, 15, 124, 124, 92, 15, 15, 124, 92, 92, 0, 0, 0, + 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - 91, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 91, 136, 21, - 21, 21, 137, 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, 91, 91, - 91, 91, 91, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 92, 92, - 92, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 138, 21, 21, 139, 21, 140, - 140, 140, 140, 140, 140, 140, 140, 141, 141, 141, 141, 141, 141, 141, - 141, 140, 140, 140, 140, 140, 140, 0, 0, 141, 141, 141, 141, 141, 141, - 0, 0, 140, 140, 140, 140, 140, 140, 140, 140, 141, 141, 141, 141, 141, - 141, 141, 141, 140, 140, 140, 140, 140, 140, 140, 140, 141, 141, 141, - 141, 141, 141, 141, 141, 140, 140, 140, 140, 140, 140, 0, 0, 141, 141, - 141, 141, 141, 141, 0, 0, 21, 140, 21, 140, 21, 140, 21, 140, 0, 141, - 0, 141, 0, 141, 0, 141, 140, 140, 140, 140, 140, 140, 140, 140, 141, - 141, 141, 141, 141, 141, 141, 141, 142, 142, 143, 143, 143, 143, 144, - 144, 145, 145, 146, 146, 147, 147, 0, 0, 140, 140, 140, 140, 140, 140, - 140, 140, 148, 148, 148, 148, 148, 148, 148, 148, 140, 140, 140, 140, - 140, 140, 140, 140, 148, 148, 148, 148, 148, 148, 148, 148, 140, 140, - 140, 140, 140, 140, 140, 140, 148, 148, 148, 148, 148, 148, 148, 148, - 140, 140, 21, 149, 21, 0, 21, 21, 141, 141, 150, 150, 151, 11, 152, - 11, 11, 11, 21, 149, 21, 0, 21, 21, 153, 153, 153, 153, 151, 11, 11, - 11, 140, 140, 21, 21, 0, 0, 21, 21, 141, 141, 154, 154, 0, 11, 11, - 11, 140, 140, 21, 21, 21, 113, 21, 21, 141, 141, 155, 155, 117, 11, - 11, 11, 0, 0, 21, 149, 21, 0, 21, 21, 156, 156, 157, 157, 151, 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, - 158, 159, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 20, - 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, 17, 17, 0, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 91, 0, 0, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 91, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 7, 7, 7, 5, 6, 0, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 119, 119, 119, 119, 92, 119, 119, 119, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 107, 14, 14, 14, 14, 107, 14, 14, 21, 107, 107, 107, 21, 21, 107, - 107, 107, 21, 14, 107, 14, 14, 7, 107, 107, 107, 107, 107, 14, 14, - 14, 14, 14, 14, 107, 14, 160, 14, 107, 14, 161, 162, 107, 107, 14, - 21, 107, 107, 163, 107, 21, 15, 15, 15, 15, 21, 14, 14, 21, 21, 107, - 107, 7, 7, 7, 7, 7, 107, 21, 21, 21, 21, 14, 7, 14, 14, 164, 14, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, - 166, 166, 127, 127, 127, 23, 24, 127, 127, 127, 127, 18, 14, 14, 0, - 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 7, - 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, + 91, 91, 91, 91, 91, 91, 91, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 91, 138, 21, 21, 21, 139, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 91, 91, 91, 91, 91, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 0, 92, 92, 92, 92, 92, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, + 140, 21, 21, 141, 21, 142, 142, 142, 142, 142, 142, 142, 142, 143, + 143, 143, 143, 143, 143, 143, 143, 142, 142, 142, 142, 142, 142, 0, + 0, 143, 143, 143, 143, 143, 143, 0, 0, 142, 142, 142, 142, 142, 142, + 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, 142, 142, 142, 142, + 142, 142, 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, 142, 142, + 142, 142, 142, 142, 0, 0, 143, 143, 143, 143, 143, 143, 0, 0, 21, 142, + 21, 142, 21, 142, 21, 142, 0, 143, 0, 143, 0, 143, 0, 143, 142, 142, + 142, 142, 142, 142, 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, + 144, 144, 145, 145, 145, 145, 146, 146, 147, 147, 148, 148, 149, 149, + 0, 0, 142, 142, 142, 142, 142, 142, 142, 142, 150, 150, 150, 150, 150, + 150, 150, 150, 142, 142, 142, 142, 142, 142, 142, 142, 150, 150, 150, + 150, 150, 150, 150, 150, 142, 142, 142, 142, 142, 142, 142, 142, 150, + 150, 150, 150, 150, 150, 150, 150, 142, 142, 21, 151, 21, 0, 21, 21, + 143, 143, 152, 152, 153, 11, 154, 11, 11, 11, 21, 151, 21, 0, 21, 21, + 155, 155, 155, 155, 153, 11, 11, 11, 142, 142, 21, 21, 0, 0, 21, 21, + 143, 143, 156, 156, 0, 11, 11, 11, 142, 142, 21, 21, 21, 113, 21, 21, + 143, 143, 157, 157, 117, 11, 11, 11, 0, 0, 21, 151, 21, 0, 21, 21, + 158, 158, 159, 159, 153, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 17, 17, 17, 17, 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, + 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 160, 161, 17, 17, 17, 17, 17, 2, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, + 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 2, 17, 17, 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 18, 91, 0, 0, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 91, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 119, 119, 119, 119, 92, 119, 119, + 119, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 107, 14, 14, 14, 14, 107, 14, + 14, 21, 107, 107, 107, 21, 21, 107, 107, 107, 21, 14, 107, 14, 14, + 7, 107, 107, 107, 107, 107, 14, 14, 14, 14, 14, 14, 107, 14, 162, 14, + 107, 14, 163, 164, 107, 107, 14, 21, 107, 107, 165, 107, 21, 15, 15, + 15, 15, 21, 14, 14, 21, 21, 107, 107, 7, 7, 7, 7, 7, 107, 21, 21, 21, + 21, 14, 7, 14, 14, 166, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 168, 168, 168, 168, 168, 168, 168, + 168, 168, 168, 168, 168, 168, 168, 168, 168, 128, 128, 128, 23, 24, + 128, 128, 128, 128, 18, 14, 14, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, + 14, 14, 14, 7, 7, 14, 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, + 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 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, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 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, + 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, + 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 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, 7, 7, 7, 7, 7, + 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 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, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, + 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, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, + 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 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, + 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, 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, + 7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 7, 7, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, + 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 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, 0, 0, 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, 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, 0, 0, 0, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 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, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 122, 122, 122, 122, 122, 122, 122, 122, 122, 0, 123, 123, 123, 123, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 0, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, - 123, 0, 23, 24, 169, 170, 171, 172, 173, 23, 24, 23, 24, 23, 24, 174, - 175, 176, 177, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, 21, 91, 91, - 178, 178, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, 24, 23, 24, - 92, 92, 92, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, 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, 179, 179, 179, 179, 179, 179, 0, 179, 0, 0, 0, 0, 0, 179, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 91, 3, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, - 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6, 5, 6, 5, 6, - 5, 6, 3, 3, 3, 3, 3, 91, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3, - 3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 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, + 123, 123, 123, 123, 123, 0, 23, 24, 171, 172, 173, 174, 175, 23, 24, + 23, 24, 23, 24, 176, 177, 178, 179, 21, 23, 24, 21, 23, 24, 21, 21, + 21, 21, 21, 91, 91, 180, 180, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, + 14, 23, 24, 23, 24, 92, 92, 92, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, + 18, 3, 3, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, + 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, + 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 0, 181, + 0, 0, 0, 0, 0, 181, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 91, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, + 3, 16, 20, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, + 16, 20, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 91, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 8, 8, 3, 3, 3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 0, 0, 0, 0, 2, 3, 3, 3, 14, 91, 15, 127, 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, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 92, 92, 92, 92, 124, 124, 8, - 91, 91, 91, 91, 91, 14, 14, 127, 127, 127, 91, 15, 3, 14, 14, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 92, 92, 11, 11, 91, 91, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 3, 91, 91, 91, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 2, 3, 3, 3, 14, 91, + 15, 128, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14, 5, 6, 5, 6, 5, 6, 5, + 6, 8, 5, 6, 6, 14, 128, 128, 128, 128, 128, 128, 128, 128, 128, 92, + 92, 92, 92, 124, 124, 8, 91, 91, 91, 91, 91, 14, 14, 128, 128, 128, + 91, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 92, 92, 11, 11, 91, + 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 91, 91, 91, 15, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 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, 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, 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, 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, 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, 15, 15, - 15, 15, 15, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 14, 14, + 15, 15, 15, 0, 0, 0, 0, 0, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 91, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 15, 92, 119, 119, 119, - 3, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 91, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 23, 24, 23, 24, 91, 91, 92, 92, 15, 15, 15, 15, 15, 15, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 127, 92, 92, 3, 3, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 91, 91, 91, 91, - 91, 91, 91, 91, 91, 11, 11, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 91, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24, 23, 24, 180, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 91, 11, 11, 23, 24, 181, 21, 15, - 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 182, 183, 184, 185, 182, 0, 186, - 187, 188, 189, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 91, 91, - 21, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, 92, 15, 15, 15, 15, - 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 124, 124, 92, 92, 124, 14, 14, 14, 14, - 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, + 15, 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, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 124, 124, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 3, 3, 3, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 15, + 92, 119, 119, 119, 3, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 91, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 91, 91, 92, 92, 15, 15, + 15, 15, 15, 15, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 92, + 92, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 11, 11, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 91, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24, + 23, 24, 182, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 91, 11, 11, 23, + 24, 183, 21, 15, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 184, 185, 186, + 187, 184, 21, 188, 189, 190, 191, 23, 24, 23, 24, 23, 24, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 91, 91, 21, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, + 92, 15, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 92, 92, 124, + 14, 14, 14, 14, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 14, 14, 4, 14, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 124, + 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, - 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 92, - 92, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, - 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, 3, 15, 0, - 0, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 3, 3, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, - 124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 124, 92, 92, 92, 92, 124, - 124, 92, 124, 124, 124, 124, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 0, 91, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, - 15, 15, 92, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 124, 124, 92, 92, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 15, - 15, 92, 124, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, 3, 3, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, - 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 124, 92, 124, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 92, - 92, 92, 15, 15, 92, 92, 15, 15, 15, 15, 15, 92, 92, 15, 92, 15, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 15, 15, 91, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, - 92, 92, 124, 124, 3, 3, 15, 91, 91, 124, 92, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 21, 21, 21, 21, 21, 21, 21, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, + 124, 124, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, + 3, 15, 15, 92, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, + 92, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 124, 124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 124, 92, 92, + 92, 92, 124, 124, 92, 124, 124, 124, 124, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 0, 91, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, + 15, 15, 15, 15, 15, 92, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 124, 124, + 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 92, 15, 15, 15, 15, + 15, 15, 15, 15, 92, 124, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 91, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 124, 92, 124, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 15, 92, 92, 92, 15, 15, 92, 92, 15, 15, 15, 15, 15, 92, 92, 15, + 92, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 91, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 124, 92, 92, 124, 124, 3, 3, 15, 91, 91, 124, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 190, 21, 21, 21, 21, 21, - 21, 21, 11, 91, 91, 91, 91, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, - 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, - 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, - 191, 191, 191, 191, 191, 191, 191, 191, 191, 15, 15, 15, 124, 124, - 92, 124, 124, 92, 124, 124, 3, 124, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 192, 21, 21, 21, + 21, 21, 21, 21, 11, 91, 91, 91, 91, 21, 21, 21, 21, 21, 21, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 15, 15, 15, 124, + 124, 92, 124, 124, 92, 124, 124, 3, 124, 92, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 192, 192, 192, - 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, - 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, - 192, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, - 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, - 193, 193, 193, 193, 193, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, + 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, + 195, 195, 195, 195, 195, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, @@ -1160,10 +1162,10 @@ 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, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 18, + 14, 14, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -1176,29 +1178,29 @@ 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, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 127, 15, 15, 15, 15, 15, 15, - 15, 15, 127, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 128, 15, 15, 15, 15, 15, 15, + 15, 15, 128, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 127, - 127, 127, 127, 127, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 194, 194, 194, 194, - 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, - 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, - 194, 194, 194, 194, 194, 194, 194, 194, 195, 195, 195, 195, 195, 195, - 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, - 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, - 195, 195, 195, 195, 195, 195, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 128, + 128, 128, 128, 128, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 194, - 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, - 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, - 194, 194, 194, 194, 194, 194, 194, 0, 0, 0, 0, 195, 195, 195, 195, - 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, - 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, - 195, 195, 195, 195, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 0, 0, 0, 0, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, @@ -1222,304 +1224,316 @@ static const unsigned char groupMap[] = { 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 92, 92, 92, 0, 92, 92, 0, 0, 0, 0, 0, 92, 92, 92, 92, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 92, 92, 92, 0, 0, 0, - 0, 92, 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, 0, 0, 92, 92, 92, 0, 0, + 0, 0, 92, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 18, 18, 3, 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, 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, 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, 92, 92, 0, 0, 0, 0, 18, 18, 18, - 18, 18, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 18, 18, + 15, 15, 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 97, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, - 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, 102, 102, 102, 102, 102, 102, + 97, 97, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, - 102, 102, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 102, 102, 102, 102, 102, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, + 15, 15, 15, 15, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 124, 92, 124, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 18, 18, 18, 18, 18, 18, 0, 18, 18, 18, 18, 18, 18, 18, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 124, 92, + 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 3, 3, - 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, - 92, 124, 124, 92, 92, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 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, 92, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, + 92, 92, 92, 92, 124, 124, 92, 92, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 17, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 92, + 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 92, 92, 0, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 92, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 92, + 92, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 124, 124, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 92, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 92, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 15, + 15, 15, 15, 3, 3, 3, 3, 92, 92, 92, 92, 3, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 15, 15, 15, 15, 3, 3, - 3, 3, 3, 92, 92, 92, 3, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 3, - 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, 124, 124, - 92, 124, 92, 92, 3, 3, 3, 3, 3, 3, 92, 0, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 0, - 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 92, 92, 124, 124, 92, 124, 92, 92, 3, 3, 3, 3, 3, 3, 92, 0, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 92, 92, 124, 124, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 124, 124, 124, 0, 0, 124, - 124, 0, 0, 124, 124, 124, 0, 0, 15, 0, 0, 0, 0, 0, 0, 124, 0, 0, 0, - 0, 0, 15, 15, 15, 15, 15, 124, 124, 0, 0, 92, 92, 92, 92, 92, 92, 92, - 0, 0, 0, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 92, - 92, 92, 124, 92, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 3, 0, 3, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 124, - 92, 124, 124, 124, 124, 92, 92, 124, 92, 92, 15, 15, 3, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, - 92, 92, 92, 92, 0, 0, 124, 124, 124, 124, 92, 92, 124, 92, 92, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 15, - 15, 15, 15, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 92, 124, 124, 124, 92, 92, 92, 92, 92, 92, + 92, 92, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 92, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, + 15, 15, 15, 15, 15, 0, 92, 92, 15, 124, 124, 92, 124, 124, 124, 124, + 0, 0, 124, 124, 0, 0, 124, 124, 124, 0, 0, 15, 0, 0, 0, 0, 0, 0, 124, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 124, 124, 0, 0, 92, 92, 92, 92, + 92, 92, 92, 0, 0, 0, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, - 124, 124, 92, 124, 92, 92, 3, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 92, - 124, 124, 92, 92, 92, 92, 92, 92, 124, 92, 0, 0, 0, 0, 0, 0, 0, 0, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 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, 92, 92, 92, 124, 124, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, - 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 3, 3, 3, 14, 10, + 124, 124, 92, 92, 92, 124, 92, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 3, 0, 3, 92, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, + 92, 92, 92, 124, 92, 124, 124, 124, 124, 92, 92, 124, 92, 92, 15, 15, + 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 124, 124, 124, 92, 92, 92, 92, 0, 0, 124, 124, 124, 124, 92, 92, + 124, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, + 92, 92, 92, 92, 92, 124, 124, 92, 124, 92, 92, 3, 3, 3, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 92, 124, 92, 124, 124, 92, 92, 92, 92, 92, 92, 124, 92, 0, 0, 0, + 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 124, 124, 92, 92, 92, 92, + 124, 92, 92, 92, 92, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 18, 18, 3, 3, 3, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 92, 92, 3, + 0, 0, 0, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 124, 15, 92, 92, 92, 92, 3, - 3, 3, 3, 3, 3, 3, 3, 92, 0, 0, 0, 0, 0, 0, 0, 0, 15, 92, 92, 92, 92, - 92, 92, 124, 124, 92, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, - 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 124, 92, 92, 3, 3, 3, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 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, 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, 124, 92, 92, 92, 92, 92, 92, 92, 0, 92, - 92, 92, 92, 92, 92, 124, 92, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 3, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 0, 124, 92, 92, 92, 92, 92, 92, 92, 124, 92, 92, 124, 92, 92, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 124, 15, 92, + 92, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 92, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 92, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 124, 92, 92, 3, 3, 3, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 92, 92, 92, 92, 92, 92, 0, 0, 0, 92, 0, 92, 92, 0, 92, - 92, 92, 92, 92, 92, 92, 15, 92, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 127, 127, 127, 127, 127, 127, 127, - 127, 127, 127, 127, 127, 127, 127, 127, 0, 3, 3, 3, 3, 3, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 0, 92, 92, 92, 92, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 92, 92, 92, 92, 92, 92, 3, 3, 3, 3, 3, 14, 14, 14, 14, 91, 91, - 91, 91, 3, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 0, 18, 18, 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 124, 124, 124, 124, - 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 92, 92, 92, + 92, 92, 92, 92, 0, 92, 92, 92, 92, 92, 92, 124, 92, 15, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 0, 124, 92, 92, 92, 92, 92, 92, 92, 124, + 92, 92, 124, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 0, 0, 0, + 92, 0, 92, 92, 0, 92, 92, 92, 92, 92, 92, 92, 15, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 124, 124, 124, 124, 124, 0, 92, 92, 0, 124, 124, 92, + 124, 92, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 124, 124, 3, 3, 0, + 0, 0, 0, 0, 0, 0, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 92, 92, 92, 92, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, + 92, 92, 92, 3, 3, 3, 3, 3, 14, 14, 14, 14, 91, 91, 91, 91, 3, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, + 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 91, - 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 0, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 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, 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, 92, 92, 3, 17, - 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, + 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, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 14, 92, 92, 3, 17, 17, 17, + 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 124, 124, 92, 92, 92, 14, 14, 14, - 124, 124, 124, 124, 124, 124, 17, 17, 17, 17, 17, 17, 17, 17, 92, 92, - 92, 92, 92, 92, 92, 92, 14, 14, 92, 92, 92, 92, 92, 92, 92, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 124, 124, 92, 92, 92, 14, 14, 14, 124, + 124, 124, 124, 124, 124, 17, 17, 17, 17, 17, 17, 17, 17, 92, 92, 92, + 92, 92, 92, 92, 92, 14, 14, 92, 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, 92, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 92, 92, 92, 14, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 14, 14, 92, 92, 92, 14, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 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, 107, 107, 107, 107, 107, 107, 107, 107, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 0, 0, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, + 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, - 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 0, 107, 107, 0, 0, 107, - 0, 0, 107, 107, 0, 0, 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, - 107, 107, 107, 21, 21, 21, 21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, - 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 107, 0, 107, 107, 0, 0, 107, 0, 0, 107, 107, + 0, 0, 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 21, 21, 21, 21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, + 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, + 0, 107, 107, 107, 107, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 0, 107, 107, 107, 107, 107, 107, 107, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 107, 107, 0, 107, 107, 107, 107, 0, 0, 107, 107, 107, 107, - 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, 107, 107, 0, 21, 21, + 21, 21, 107, 107, 0, 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, + 0, 107, 0, 0, 0, 107, 107, 107, 107, 107, 107, 107, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 107, 107, 0, 107, 107, 107, 107, 0, 107, - 107, 107, 107, 107, 0, 107, 0, 0, 0, 107, 107, 107, 107, 107, 107, - 107, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, + 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 0, 0, 107, 107, 107, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, - 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 21, 21, 21, 21, 21, 21, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, + 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, + 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 7, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, + 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, + 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, - 21, 21, 21, 21, 21, 21, 107, 21, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, + 107, 21, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, 92, 92, 92, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 14, 14, 14, 14, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 92, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 92, 14, 14, 3, - 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, - 92, 92, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, - 92, 92, 92, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 92, 0, 0, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 0, 92, - 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 196, 196, - 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, - 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, - 196, 196, 196, 196, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, - 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, - 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 92, 92, 92, 92, 92, - 92, 92, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, - 3, 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, + 92, 14, 14, 14, 14, 14, 14, 14, 14, 92, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 92, 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 0, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 92, 92, + 92, 92, 92, 92, 92, 0, 92, 92, 0, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 92, 92, 92, 92, 92, 92, 92, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 199, 199, + 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 199, 199, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, + 18, 18, 18, 4, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, + 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 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, 14, 14, 14, 14, 14, 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, 0, 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, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 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, 14, 14, 14, 14, 14, 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, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, 11, 11, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 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, 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, + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, + 11, 11, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, + 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0 + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 0, 0, 0, 14, 0, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 #endif /* TCL_UTF_MAX > 3 */ }; @@ -1535,6 +1549,7 @@ static const unsigned char groupMap[] = { * 100 = subtract delta for title/upper * 101 = sub delta for upper, sub 1 for title * 110 = sub delta for upper, add delta for lower + * 111 = subtract delta for upper * * Bits 8-31 Case delta: delta for case conversions. This should be the * highest field so we can easily sign extend. @@ -1554,16 +1569,16 @@ static const int groups[] = { 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, 9949249, 10, 1601154, 1600898, 1598594, 1598082, 1598338, - 1596546, 1582466, -9027966, -9044862, -976254, 15234, -1949375, - -1918, -1983, -18814, -21886, -25470, -32638, -28542, -32126, - -1981, -2174, -18879, -2237, 1844610, -21951, -25535, -28607, - -32703, -32191, 13, 14, -1924287, -2145983, -2115007, 7233, 7298, - 4170, 4234, 6749, 6813, -2750143, -976319, -2746047, 2763650, - 2762882, -2759615, -2751679, -2760383, -2760127, -2768575, 1859714, - -9044927, -10823615, -10830783, -10833599, -10832575, -10830015, - -10817983, -10824127, -10818751, 237633, 237698, 9949314, 18, - 17, 10305, 10370, 8769, 8834 + 8, 1859649, -769822, 9949249, 10, 1601154, 1600898, 1598594, 1598082, + 1598338, 1596546, 1582466, -9027966, -769983, -9044862, -976254, + 15234, -1949375, -1918, -1983, -18814, -21886, -25470, -32638, + -28542, -32126, -1981, -2174, -18879, -2237, 1844610, -21951, + -25535, -28607, -32703, -32191, 13, 14, -1924287, -2145983, -2115007, + 7233, 7298, 4170, 4234, 6749, 6813, -2750143, -976319, -2746047, + 2763650, 2762882, -2759615, -2751679, -2760383, -2760127, -2768575, + 1859714, -9044927, -10823615, -10830783, -10833599, -10832575, + -10830015, -10817983, -10824127, -10818751, 237633, 237698, 9949314, + 18, 17, 10305, 10370, 8769, 8834 }; #if TCL_UTF_MAX > 3 diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6255a4e..ce67db7 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -68,24 +68,14 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 4,4,4,4,4,4,4,4, -#else - 1,1,1,1,1,1,1,1, -#endif 1,1,1,1,1,1,1,1 }; - -/* - * Functions used only in this module. - */ - -static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * UtfCount -- + * TclUtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -98,8 +88,8 @@ static int UtfCount(int ch); *--------------------------------------------------------------------------- */ -static inline int -UtfCount( +int +TclUtfCount( int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { @@ -108,11 +98,9 @@ UtfCount( if (ch <= 0x7FF) { return 2; } -#if TCL_UTF_MAX > 3 if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { return 4; } -#endif return 3; } @@ -141,7 +129,7 @@ Tcl_UniCharToUtf( char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character - * (at most TCL_UTF_MAX bytes). */ + * (at most 4 bytes). */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; @@ -154,27 +142,30 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { -#if TCL_UTF_MAX == 4 if ((ch & 0xF800) == 0xD800) { if (ch & 0x0400) { /* Low surrogate */ - buf[3] = (char) ((ch | 0x80) & 0xBF); - buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F); - return 4; + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + /* Previous Tcl_UniChar was a High surrogate, so combine */ + buf[3] = (char) ((ch & 0x3F) | 0x80); + buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80); + return 4; + } + /* Previous Tcl_UniChar was not a High surrogate, so just output */ } else { /* High surrogate */ ch += 0x40; - buf[2] = (char) (((ch << 4) | 0x80) & 0xB0); - buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF); - buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7); + /* Fill buffer with specific 3-byte (invalid) byte combination, + so following Low surrogate can recognize it and combine */ + buf[2] = (char) ((ch << 4) & 0x30); + buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); + buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); return 0; } } -#endif goto three; } - -#if TCL_UTF_MAX > 3 if (ch <= 0x10FFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); @@ -182,7 +173,13 @@ Tcl_UniCharToUtf( buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } -#endif + } else if (ch == -1) { + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2) + + ((buf[2] & 0x30) >> 4); + goto three; + } } ch = 0xFFFD; @@ -221,23 +218,31 @@ Tcl_UniCharToUtfDString( { const Tcl_UniChar *w, *wEnd; char *p, *string; - int oldLength; + int oldLength, len = 1; /* - * UTF-8 string length in bytes will be <= Unicode string length * - * TCL_UTF_MAX. + * UTF-8 string length in bytes will be <= Unicode string length * 4. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - p += Tcl_UniCharToUtf(*w, p); + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; w++; } + if (!len) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; @@ -278,6 +283,13 @@ Tcl_UniCharToUtfDString( *--------------------------------------------------------------------------- */ +static const unsigned short cp1252[32] = { + 0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, + 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, + 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, + 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 +}; + int Tcl_UtfToUniChar( register const char *src, /* The UTF-8 string. */ @@ -294,11 +306,17 @@ Tcl_UtfToUniChar( if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. - * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid + * Treats naked trail bytes 0x80 to 0x9F as valid characters from + * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8> + * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid * characters representing themselves. */ - *chPtr = (Tcl_UniChar) byte; + if ((unsigned)(byte-0x80) < (unsigned) 0x20) { + *chPtr = (Tcl_UniChar) cp1252[byte-0x80]; + } else { + *chPtr = (Tcl_UniChar) byte; + } return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { @@ -334,13 +352,12 @@ Tcl_UtfToUniChar( * represents itself. */ } -#if TCL_UTF_MAX > 3 else if (byte < 0xF8) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 Tcl_UniChar surrogate; byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) @@ -371,7 +388,6 @@ Tcl_UtfToUniChar( * represents itself. */ } -#endif *chPtr = (Tcl_UniChar) byte; return 1; @@ -418,20 +434,32 @@ Tcl_UtfToUniCharDString( */ oldLength = Tcl_DStringLength(dsPtr); -/* TODO: fix overreach! */ + Tcl_DStringSetLength(dsPtr, - (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); + oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; - end = src + length; - for (p = src; p < end; ) { + p = src; + end = src + length - 4; + while (p < end) { p += TclUtfToUniChar(p, &ch); *w++ = ch; } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else if ((unsigned)((UCHAR(*p)-0x80)) < (unsigned) 0x20) { + ch = (Tcl_UniChar) cp1252[UCHAR(*p++)-0x80]; + } else { + ch = UCHAR(*p++); + } + *w++ = ch; + } *w = '\0'; Tcl_DStringSetLength(dsPtr, - (oldLength + ((char *) w - (char *) wString))); + oldLength + ((char *) w - (char *) wString)); return wString; } @@ -505,13 +533,13 @@ Tcl_NumUtfChars( } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { - register const char *endPtr = src + length - TCL_UTF_MAX; + register const char *endPtr = src + length - 4; while (src < endPtr) { src += TclUtfToUniChar(src, &ch); i++; } - endPtr += TCL_UTF_MAX; + endPtr += 4; while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { src += TclUtfToUniChar(src, &ch); i++; @@ -553,7 +581,7 @@ Tcl_UtfFindFirst( while (1) { len = TclUtfToUniChar(src, &find); fullchar = find; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if (!len) { len += TclUtfToUniChar(src, &find); fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; @@ -601,7 +629,7 @@ Tcl_UtfFindLast( while (1) { len = TclUtfToUniChar(src, &find); fullchar = find; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if (!len) { len += TclUtfToUniChar(src, &find); fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; @@ -644,7 +672,7 @@ Tcl_UtfNext( Tcl_UniChar ch = 0; int len = TclUtfToUniChar(src, &ch); -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if (len == 0) { len = TclUtfToUniChar(src, &ch); } @@ -683,7 +711,7 @@ Tcl_UtfPrev( int i, byte; look = --src; - for (i = 0; i < TCL_UTF_MAX; i++) { + for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; @@ -719,17 +747,33 @@ Tcl_UtfPrev( *--------------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharAtIndex( register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; + int fullchar = 0; +#if TCL_UTF_MAX <= 4 + int len = 1; +#endif while (index-- >= 0) { +#if TCL_UTF_MAX <= 4 + src += (len = TclUtfToUniChar(src, &ch)); +#else src += TclUtfToUniChar(src, &ch); +#endif + } + fullchar = ch; +#if TCL_UTF_MAX <= 4 + if (!len) { + /* If last Tcl_UniChar was an upper surrogate, combine with lower surrogate */ + (void)TclUtfToUniChar(src, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; } - return ch; +#endif + return fullchar; } /* @@ -738,7 +782,9 @@ Tcl_UniCharAtIndex( * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. + * the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as + * 2 positions, but then the pointer should never be placed between + * the two positions. * * Results: * As above. @@ -755,10 +801,18 @@ Tcl_UtfAtIndex( register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; + int len = 1; while (index-- > 0) { + len = TclUtfToUniChar(src, &ch); + src += len; + } +#if TCL_UTF_MAX <= 4 + if (!len) { + /* Index points at character following High Surrogate */ src += TclUtfToUniChar(src, &ch); } +#endif return src; } @@ -837,7 +891,8 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, upChar; + Tcl_UniChar ch = 0; + int upChar; char *src, *dst; int bytes; @@ -848,7 +903,16 @@ Tcl_UtfToUpper( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - upChar = Tcl_UniCharToUpper(ch); + upChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + upChar = Tcl_UniCharToUpper(upChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -856,7 +920,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(upChar)) { + if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -890,7 +954,8 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, lowChar; + Tcl_UniChar ch = 0; + int lowChar; char *src, *dst; int bytes; @@ -901,7 +966,16 @@ Tcl_UtfToLower( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + lowChar = Tcl_UniCharToLower(lowChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -909,7 +983,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -944,7 +1018,8 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, titleChar, lowChar; + Tcl_UniChar ch = 0; + int titleChar, lowChar; char *src, *dst; int bytes; @@ -957,9 +1032,18 @@ Tcl_UtfToTitle( if (*src) { bytes = TclUtfToUniChar(src, &ch); - titleChar = Tcl_UniCharToTitle(ch); + titleChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + titleChar = Tcl_UniCharToTitle(titleChar); - if (bytes < UtfCount(titleChar)) { + if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -969,9 +1053,21 @@ Tcl_UtfToTitle( } while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + /* Special exception for Georgian Asomtavruli chars, no titlecase. */ + if ((unsigned)(lowChar - 0x1C90) >= 0x30) { + lowChar = Tcl_UniCharToLower(lowChar); + } - if (bytes < UtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1071,7 +1167,7 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1122,7 +1218,7 @@ Tcl_UtfNcasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1141,6 +1237,52 @@ Tcl_UtfNcasecmp( } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- @@ -1171,7 +1313,7 @@ TclUtfCasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1208,16 +1350,18 @@ TclUtfCasecmp( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToUpper( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); - if (GetCaseType(info) & 0x04) { - ch -= GetDelta(info); + if (GetCaseType(info) & 0x04) { + ch -= GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1236,16 +1380,19 @@ Tcl_UniCharToUpper( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToLower( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if (GetCaseType(info) & 0x02) { - ch += GetDelta(info); + if ((mode & 0x02) && (mode != 0x7)) { + ch += GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1264,23 +1411,27 @@ Tcl_UniCharToLower( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToTitle( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); - int mode = GetCaseType(info); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if (mode & 0x1) { - /* - * Subtract or add one depending on the original case. - */ + if (mode & 0x1) { + /* + * Subtract or add one depending on the original case. + */ - ch += ((mode & 0x4) ? -1 : 1); - } else if (mode == 0x4) { - ch -= GetDelta(info); + if (mode != 0x7) { + ch += ((mode & 0x4) ? -1 : 1); + } + } else if (mode == 0x4) { + ch -= GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1414,11 +1565,9 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } @@ -1442,11 +1591,9 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((ALPHA_BITS >> GetCategory(ch)) & 1); } @@ -1470,7 +1617,6 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) { @@ -1481,7 +1627,6 @@ Tcl_UniCharIsControl( } return 0; } -#endif return ((CONTROL_BITS >> GetCategory(ch)) & 1); } @@ -1505,11 +1650,9 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } @@ -1533,12 +1676,10 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; return (ch >= 0xE0100) && (ch <= 0xE01EF); } -#endif return ((GRAPH_BITS >> GetCategory(ch)) & 1); } @@ -1562,11 +1703,9 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == LOWERCASE_LETTER); } @@ -1590,12 +1729,10 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; return (ch >= 0xE0100) && (ch <= 0xE01EF); } -#endif return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } @@ -1619,11 +1756,9 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((PUNCT_BITS >> GetCategory(ch)) & 1); } @@ -1647,13 +1782,8 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 /* Ignore upper 11 bits. */ ch &= 0x1FFFFF; -#else - /* Ignore upper 16 bits. */ - ch &= 0xFFFF; -#endif /* * If the character is within the first 127 characters, just use the @@ -1662,10 +1792,8 @@ Tcl_UniCharIsSpace( if (ch < 0x80) { return TclIsSpaceProc((char) ch); -#if TCL_UTF_MAX > 3 } else if (UNICODE_OUT_OF_RANGE(ch)) { return 0; -#endif } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) { return 1; @@ -1694,11 +1822,9 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == UPPERCASE_LETTER); } @@ -1722,11 +1848,9 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((WORD_BITS >> GetCategory(ch)) & 1); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index feee9c5..ef3c3dc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" +#include "tommath.h" #include <math.h> /* @@ -107,10 +108,11 @@ static Tcl_ThreadDataKey precisionKey; static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, + Tcl_WideInt endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); +static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_WideInt endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, @@ -119,16 +121,20 @@ static int FindElement(Tcl_Interp *interp, const char *string, /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is an - * integer, so no memory management is required for it. + * performance optimization in TclGetIntForIndex. The internal rep is + * stored directly in the wideValue, so no memory management is required + * for it. This is a caching intrep, keeping the result of a parse + * around. This type is only created from a pre-existing string, so an + * updateStringProc will never be called and need not exist. The type + * is unregistered, so has no need of a setFromAnyProc either. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* @@ -1384,9 +1390,9 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; - length = 0; - conversion = CONVERT_BRACE; + p[0] = '{'; + p[1] = '}'; + return 2; } /* @@ -1604,6 +1610,7 @@ Tcl_Merge( return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -1637,15 +1644,51 @@ Tcl_Backslash( TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * - * TclTrimRight -- + * UtfWellFormedEnd -- + * Checks the end of utf string is malformed, if yes - wraps bytes + * to the given buffer (as well-formed NTS string). The buffer + * argument should be initialized by the caller and ready to use. + * + * Results: + * The bytes with well-formed end of the string. + * + * Side effects: + * Buffer (DString) may be allocated, so must be released. + * + *---------------------------------------------------------------------- + */ + +static inline const char* +UtfWellFormedEnd( + Tcl_DString *buffer, /* Buffer used to hold well-formed string. */ + const char *bytes, /* Pointer to the beginning of the string. */ + int length) /* Length of the string. */ +{ + const char *l = bytes + length; + const char *p = Tcl_UtfPrev(l, bytes); + + if (Tcl_UtfCharComplete(p, l - p)) { + return bytes; + } + /* + * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, + * avoid segfault by access violation out of range. + */ + Tcl_DStringAppend(buffer, bytes, length); + return Tcl_DStringValue(buffer); +} +/* + *---------------------------------------------------------------------- * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the right side of the first string - * all characters found in the second string. + * TclTrimRight -- + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the right side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1656,8 +1699,8 @@ Tcl_Backslash( *---------------------------------------------------------------------- */ -int -TclTrimRight( +static inline int +TrimRight( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ @@ -1665,25 +1708,13 @@ TclTrimRight( { const char *p = bytes + numBytes; int pInc; - - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimRight works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; @@ -1695,7 +1726,6 @@ TclTrimRight( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1718,15 +1748,46 @@ TclTrimRight( return numBytes - (p - bytes); } + +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimRight(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} /* *---------------------------------------------------------------------- * * TclTrimLeft -- * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the left side of the first string - * all characters found in the second string. + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the left side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1737,33 +1798,21 @@ TclTrimRight( *---------------------------------------------------------------------- */ -int -TclTrimLeft( +static inline int +TrimLeft( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes; - - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimLeft works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; @@ -1773,7 +1822,6 @@ TclTrimLeft( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1794,10 +1842,99 @@ TclTrimLeft( p += pInc; numBytes -= pInc; - } while (numBytes); + } while (numBytes > 0); return p - bytes; } + +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimLeft(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} + +/* + *---------------------------------------------------------------------- + * + * TclTrim -- + * Finds the sub string (offset) to trim from both sides of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the start of the string + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrim( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim, /* ...and its length in bytes */ + int *trimRight) /* Offset from the end of the string. */ +{ + int trimLeft; + Tcl_DString bytesBuf, trimBuf; + + *trimRight = 0; + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + trimLeft = TrimLeft(bytes, numBytes, trim, numTrim); + if (trimLeft > numBytes) { + trimLeft = numBytes; + } + numBytes -= trimLeft; + /* have to trim yet (first char was already verified within TrimLeft) */ + if (numBytes > 1) { + bytes += trimLeft; + *trimRight = TrimRight(bytes, numBytes, trim, numTrim); + if (*trimRight > numBytes) { + *trimRight = numBytes; + } + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return trimLeft; +} /* *---------------------------------------------------------------------- @@ -1865,30 +2002,20 @@ Tcl_Concat( result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { - int trim, elemLength; + int triml, trimr, elemLength; const char *element; element = argv[i]; elemLength = strlen(argv[i]); - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ - - trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. @@ -1953,7 +2080,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -1962,7 +2089,7 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (objPtr->bytes && objPtr->length == 0) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { @@ -2008,28 +2135,18 @@ Tcl_ConcatObj( Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { - int trim; + int triml, trimr; element = TclGetStringFromObj(objv[i], &elemLength); - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; - - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. @@ -2107,7 +2224,7 @@ Tcl_StringCaseMatch( { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2217,7 +2334,7 @@ Tcl_StringCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { @@ -2530,7 +2647,8 @@ TclStringMatchObj( udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if (TclIsPureByteArray(strObj) && !flags) { + } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) + && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); @@ -2662,7 +2780,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2879,7 +2997,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -2909,6 +3026,14 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_ResetResult(interp); +#else Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -2917,7 +3042,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: + * there's no string result, we only have to deal with two cases: * * 1. When the string rep is the empty string, when we don't copy but * instead use the staticSpace in the DString to hold an empty string. @@ -2932,17 +3057,17 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->string = TclGetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } return; @@ -2980,6 +3105,7 @@ Tcl_DStringGetResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3130,7 +3256,7 @@ Tcl_PrintDouble( int signum; char *digits; char *end; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. @@ -3292,6 +3418,7 @@ Tcl_PrintDouble( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ char * TclPrecTraceProc( @@ -3303,7 +3430,7 @@ TclPrecTraceProc( { Tcl_Obj *value; int prec; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * If the variable is unset, then recreate the trace. @@ -3349,6 +3476,7 @@ TclPrecTraceProc( *precisionPtr = prec; return NULL; } +#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- @@ -3466,9 +3594,9 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; @@ -3491,7 +3619,7 @@ TclFormatInt( intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* @@ -3528,253 +3656,507 @@ TclFormatInt( /* *---------------------------------------------------------------------- * - * TclGetIntForIndex -- + * GetWideForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. + * This function produces a wide integer value corresponding to the + * index value held in *objPtr. The parsing supports all values + * recognized as any size of integer, and the syntaxes end[-+]$integer + * and $integer[-+]$integer. The argument endValue is used to give + * the meaning of the literal index value "end". Index arithmetic + * on arguments outside the wide integer range are only accepted + * when interp is a working interpreter, not NULL. * * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. + * When parsing of *objPtr successfully recognizes an index value, + * TCL_OK is returned, and the wide integer value corresponding to + * the recognized index value is written to *widePtr. When parsing + * fails, TCL_ERROR is returned and error information is written to + * interp, if non-NULL. * * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. + * The type of *objPtr may change. * *---------------------------------------------------------------------- */ -int -TclGetIntForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - Tcl_Obj *objPtr, /* Points to an object containing either "end" - * or an integer. */ - int endValue, /* The value to be stored at "indexPtr" if - * "objPtr" holds "end". */ - int *indexPtr) /* Location filled in with an integer - * representing an index. */ +static int +GetWideForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to the value to be parsed */ + Tcl_WideInt endValue, /* The value to be stored at *widePtr if + * objPtr holds "end". + * NOTE: this value may be negative. */ + Tcl_WideInt *widePtr) /* Location filled in with a wide integer + * representing an index. */ { - int length; - char *opPtr; - const char *bytes; - - if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { - return TCL_OK; + ClientData cd; + const char *opPtr; + int numType, length, t1 = 0, t2 = 0; + int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + + if (code == TCL_OK) { + if (numType == TCL_NUMBER_INT) { + /* objPtr holds an integer in the signed wide range */ + *widePtr = (Tcl_WideInt)(*(Tcl_WideInt *)cd); + return TCL_OK; + } + if (numType == TCL_NUMBER_BIG) { + /* objPtr holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + if (mp_isneg((mp_int *)cd)) { + *widePtr = WIDE_MIN; + } else { + *widePtr = WIDE_MAX; + } + return TCL_OK; + } + /* Must be a double -> not a valid index */ + goto parseError; } - if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { - /* - * If the object is already an offset from the end of the list, or can - * be converted to one, use it. - */ - - *indexPtr = endValue + objPtr->internalRep.longValue; + /* objPtr does not hold a number, check the end+/- format... */ + if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) { return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + /* If we reach here, the string rep of objPtr exists. */ /* - * Leading whitespace is acceptable in an index. + * The valid index syntax does not include any value that is + * a list of more than one element. This is necessary so that + * lists of index values can be reliably distinguished from any + * single index value. */ - while (length && TclIsSpaceProc(*bytes)) { - bytes++; - length--; + /* + * Quick scan to see if multi-value list is even possible. + * This relies on TclGetString() returning a NUL-terminated string. + */ + if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1) + + /* If it's possible, do the full list parse. */ + && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) + && (length > 1)) { + goto parseError; } - if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, - TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { - int code, first, second; - char savedOp = *opPtr; + /* Passed the list screen, so parse for index arithmetic expression */ + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + TCL_PARSE_INTEGER_ONLY)) { + Tcl_WideInt w1=0, w2=0; - if ((savedOp != '+') && (savedOp != '-')) { - goto parseError; - } - if (TclIsSpaceProc(opPtr[1])) { - goto parseError; - } - *opPtr = '\0'; - code = Tcl_GetInt(interp, bytes, &first); - *opPtr = savedOp; - if (code == TCL_ERROR) { - goto parseError; - } - if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { - goto parseError; - } - if (savedOp == '+') { - *indexPtr = first + second; - } else { - *indexPtr = first - second; + /* value starts with valid integer... */ + + if ((*opPtr == '-') || (*opPtr == '+')) { + /* ... value continues with [-+] ... */ + + /* Save first integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t1); + if (t1 == TCL_NUMBER_INT) { + w1 = (*(Tcl_WideInt *)cd); + } + + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, + -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* ... value concludes with second valid integer */ + + /* Save second integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t2); + if (t2 == TCL_NUMBER_INT) { + w2 = (*(Tcl_WideInt *)cd); + } + } + } + /* Clear invalid intreps left by TclParseNumber */ + TclFreeIntRep(objPtr); + + if (t1 && t2) { + /* We have both integer values */ + if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { + /* Both are wide, do wide-integer math */ + if (*opPtr == '-') { + if ((w2 == WIDE_MIN) && (interp != NULL)) { + goto extreme; + } + w2 = -w2; + } + + if ((w1 ^ w2) < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = w1 + w2; + } else if (w1 >= 0) { + if (w1 < WIDE_MAX - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MAX; + } + } else { + if (w1 > WIDE_MIN - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MIN; + } + } + } else if (interp == NULL) { + /* + * We use an interp to do bignum index calculations. + * If we don't get one, call all indices with bignums errors, + * and rely on callers to handle it. + */ + return TCL_ERROR; + } else { + /* + * At least one is big, do bignum math. Little reason to + * value performance here. Re-use code. Parse has verified + * objPtr is an expression. Compute it. + */ + + Tcl_Obj *sum; + + extreme: + Tcl_ExprObj(interp, objPtr, &sum); + TclGetNumberFromObj(NULL, sum, &cd, &numType); + + if (numType == TCL_NUMBER_INT) { + /* sum holds an integer in the signed wide range */ + *widePtr = (Tcl_WideInt)(*(Tcl_WideInt *)cd); + } else { + /* sum holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + if (mp_isneg((mp_int *)cd)) { + *widePtr = WIDE_MIN; + } else { + *widePtr = WIDE_MAX; + } + } + Tcl_DecrRefCount(sum); + } + return TCL_OK; } - return TCL_OK; } - /* - * Report a parse error. - */ - + /* Report a parse error. */ parseError: if (interp != NULL) { - bytes = Tcl_GetString(objPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be integer?[+-]integer? or" - " end?[+-]integer?", bytes)); - if (!strncmp(bytes, "end-", 4)) { - bytes += 4; - } - TclCheckBadOctal(interp, bytes); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + char * bytes = TclGetString(objPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); + if (!strncmp(bytes, "end-", 4)) { + bytes += 4; + } + TclCheckBadOctal(interp, bytes); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } - return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- + * TclGetIntForIndex -- * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: - * None. + * The return value is normally TCL_OK, which means that the index was + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. * * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) +int +TclGetIntForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to an object containing either "end" + * or an integer. */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ { - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; + Tcl_WideInt wide; - memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { + return TCL_ERROR; } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; + if (wide < INT_MIN) { + *indexPtr = INT_MIN; + } else if (wide > INT_MAX) { + *indexPtr = INT_MAX; + } else { + *indexPtr = (int) wide; + } + return TCL_OK; } - /* *---------------------------------------------------------------------- * - * SetEndOffsetFromAny -- + * GetEndOffsetFromObj -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: - * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * Tcl return code. * * Side effects: - * If interp is not NULL, stores an error message in the interpreter - * result. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ static int -SetEndOffsetFromAny( - Tcl_Interp *interp, /* Tcl interpreter or NULL */ - Tcl_Obj *objPtr) /* Pointer to the object to parse */ +GetEndOffsetFromObj( + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + Tcl_WideInt endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + Tcl_WideInt *widePtr) /* Location filled in with an integer + * representing an index. */ { - int offset; /* Offset in the "end-offset" expression */ - register const char *bytes; /* String rep of the object */ - int length; /* Length of the object's string rep */ + Tcl_ObjIntRep *irPtr; + Tcl_WideInt offset = 0; /* Offset in the "end-offset" expression */ - /* - * If it's already the right type, we're fine. - */ + while ((irPtr = Tcl_FetchIntRep(objPtr, &endOffsetType)) == NULL) { + Tcl_ObjIntRep ir; + int length; + const char *bytes = TclGetStringFromObj(objPtr, &length); - if (objPtr->typePtr == &tclEndOffsetType) { - return TCL_OK; - } + if ((length < 3) || (length == 4)) { + /* Too short to be "end" or to be "end-$integer" */ + return TCL_ERROR; + } + if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) { + /* Value doesn't start with "end" */ + return TCL_ERROR; + } - /* - * Check for a string rep of the right form. - */ + if (length > 4) { + ClientData cd; + int t; - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; - } + /* Parse for the "end-..." or "end+..." formats */ - /* - * Convert the string rep. - */ + if ((bytes[3] != '-') && (bytes[3] != '+')) { + /* No operator where we need one */ + return TCL_ERROR; + } + if (TclIsSpaceProc(bytes[4])) { + /* Space after + or - not permitted. */ + return TCL_ERROR; + } - if (length <= 3) { - offset = 0; - } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { - /* - * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. - */ + /* Parse the integer offset */ + if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, + bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* Not a recognized integer format */ + return TCL_ERROR; + } - if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; - } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { - return TCL_ERROR; - } - if (bytes[3] == '-') { - offset = -offset; + /* Got an integer offset; pull it from where parser left it. */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t); + + if (t == TCL_NUMBER_BIG) { + /* Truncate to the signed wide range. */ + if (mp_isneg((mp_int *)cd)) { + offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN; + } else { + offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX; + } + } else { + /* assert (t == TCL_NUMBER_INT); */ + offset = (*(Tcl_WideInt *)cd); + if (bytes[3] == '-') { + offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset; + } + } } + + /* Success. Store the new internal rep. */ + ir.wideValue = offset; + Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); + } + + offset = irPtr->wideValue; + + if ((endValue ^ offset) < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = endValue + offset; + } else if (endValue >= 0) { + if (endValue < WIDE_MAX - offset) { + *widePtr = endValue + offset; + } else { + *widePtr = WIDE_MAX; + } } else { - /* - * Conversion failed. Report the error. - */ + if (endValue > WIDE_MIN - offset) { + *widePtr = endValue + offset; + } else { + *widePtr = WIDE_MIN; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclIndexEncode -- + * + * Parse objPtr to determine if it is an index value. Two cases + * are possible. The value objPtr might be parsed as an absolute + * index value in the C signed int range. Note that this includes + * index values that are integers as presented and it includes index + * arithmetic expressions. The absolute index values that can be + * directly meaningful as an index into either a list or a string are + * those integer values >= TCL_INDEX_START (0) + * and < TCL_INDEX_AFTER (INT_MAX). + * The largest string supported in Tcl 8 has bytelength INT_MAX. + * This means the largest supported character length is also INT_MAX, + * and the index of the last character in a string of length INT_MAX + * is INT_MAX-1. + * + * Any absolute index value parsed outside that range is encoded + * using the before and after values passed in by the + * caller as the encoding to use for indices that are either + * less than or greater than the usable index range. TCL_INDEX_AFTER + * is available as a good choice for most callers to use for + * after. Likewise, the value TCL_INDEX_BEFORE is good for + * most callers to use for before. Other values are possible + * when the caller knows it is helpful in producing its own behavior + * for indices before and after the indexed item. + * + * A token can also be parsed as an end-relative index expression. + * All end-relative expressions that indicate an index larger + * than end (end+2, end--5) point beyond the end of the indexed + * collection, and can be encoded as after. The end-relative + * expressions that indicate an index less than or equal to end + * are encoded relative to the value TCL_INDEX_END (-2). The + * index "end" is encoded as -2, down to the index "end-0x7ffffffe" + * which is encoded as INT_MIN. Since the largest index into a + * string possible in Tcl 8 is 0x7ffffffe, the interpretation of + * "end-0x7ffffffe" for that largest string would be 0. Thus, + * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed, + * they can be encoded with the before value. + * + * These details will require re-examination whenever string and + * list length limits are increased, but that will likely also + * mean a revised routine capable of returning Tcl_WideInt values. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * When TCL_OK is returned, the encoded index value is written + * to *indexPtr. + * + *---------------------------------------------------------------------- + */ - badIndexFormat: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); +int +TclIndexEncode( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* Index value to parse */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ + int *indexPtr) /* Where to write the encoded answer, not NULL */ +{ + ClientData cd; + Tcl_WideInt wide; + int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + + if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) { + /* We parsed a value in the range WIDE_MIN...WIDE_MAX */ + wide = (*(Tcl_WideInt *)cd); + integerEncode: + if (wide < TCL_INDEX_START) { + /* All negative absolute indices are "before the beginning" */ + idx = before; + } else if (wide >= INT_MAX) { + /* This index value is always "after the end" */ + idx = after; + } else { + idx = (int) wide; } + /* usual case, the absolute index value encodes itself */ + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) { + /* + * We parsed an end+offset index value. + * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. + */ + if (wide > 0) { + /* + * All end+postive or end-negative expressions + * always indicate "after the end". + */ + idx = after; + } else if (wide < INT_MIN - TCL_INDEX_END) { + /* These indices always indicate "before the beginning */ + idx = before; + } else { + /* Encoded end-positive (or end+negative) are offset */ + idx = (int)wide + TCL_INDEX_END; + } + + /* TODO: Consider flag to suppress repeated end-offset parse. */ + } else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) { + /* + * Only reach this case when the index value is a + * constant index arithmetic expression, and wide + * holds the result. Treat it the same as if it were + * parsed as an absolute integer value. + */ + goto integerEncode; + } else { return TCL_ERROR; } - - /* - * The conversion succeeded. Free the old internal rep and set the new - * one. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; - + *indexPtr = idx; return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclIndexDecode -- + * + * Decodes a value previously encoded by TclIndexEncode. The argument + * endValue indicates what value of "end" should be used in the + * decoding. + * + * Results: + * The decoded index value. + * + *---------------------------------------------------------------------- + */ + +int +TclIndexDecode( + int encoded, /* Value to decode */ + int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ +{ + if (encoded <= TCL_INDEX_END) { + return (encoded - TCL_INDEX_END) + endValue; + } + return encoded; +} + +/* + *---------------------------------------------------------------------- + * * TclCheckBadOctal -- * * This function checks for a bad octal value and appends a meaningful @@ -3985,9 +4367,10 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + bytes = TclGetString(newValue); + pgvPtr->numBytes = newValue->length; pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -4002,7 +4385,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -4028,7 +4411,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - int epoch = pgvPtr->epoch; + unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -4043,8 +4426,7 @@ TclGetProcessGlobalValue( Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); - pgvPtr->epoch++; - epoch = pgvPtr->epoch; + epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), @@ -4053,7 +4435,7 @@ TclGetProcessGlobalValue( ckfree(pgvPtr->value); pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), - (size_t) Tcl_DStringLength(&newValue) + 1); + Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; @@ -4063,7 +4445,7 @@ TclGetProcessGlobalValue( } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; @@ -4096,7 +4478,7 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); @@ -4179,11 +4561,10 @@ TclGetObjNameOfExecutable(void) const char * Tcl_GetNameOfExecutable(void) { - int numBytes; - const char *bytes = - Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); + Tcl_Obj *obj = TclGetObjNameOfExecutable(); + const char *bytes = TclGetString(obj); - if (numBytes == 0) { + if (obj->length == 0) { return NULL; } return bytes; diff --git a/generic/tclVar.c b/generic/tclVar.c index 3dd6790..dfe883f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -60,14 +60,12 @@ VarHashCreateVar( Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ @@ -92,11 +90,10 @@ VarHashFirstVar( { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } static inline Var * @@ -105,11 +102,10 @@ VarHashNextVar( { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ @@ -149,6 +145,7 @@ static const char *isArrayElement = */ typedef struct ArraySearch { + Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ @@ -168,14 +165,37 @@ typedef struct ArraySearch { } ArraySearch; /* + * TIP #508: [array default] + * + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); +static void ArrayPopulateSearch(Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Var *varPtr, + ArraySearch *searchPtr); +static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, + ArraySearch *searchPtr); +static Tcl_NRPostProc ArrayForLoopCallback; +static int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); +static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, + Var **varPtrPtr, int *isArrayPtr); +static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); @@ -188,8 +208,16 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static int SetArraySearchObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); + +/* + * TIP #508: [array default] + */ + +static int ArrayDefaultCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void DeleteArrayVar(Var *arrayPtr); +static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* * Functions defined in this file that may be exported in the future for use @@ -202,14 +230,9 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; -static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; -static Tcl_UpdateStringProc UpdateParsedVarName; - -static Tcl_UpdateStringProc PanicOnUpdateVarName; -static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. @@ -228,30 +251,52 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName + FreeLocalVarName, DupLocalVarName, NULL, NULL }; -static const Tcl_ObjType tclParsedVarNameType = { +#define LocalSetIntRep(objPtr, index, namePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr = (namePtr); \ + if (ptr) {Tcl_IncrRefCount(ptr);} \ + ir.twoPtrValue.ptr1 = ptr; \ + ir.twoPtrValue.ptr2 = INT2PTR(index); \ + Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ + } while (0) + +#define LocalGetIntRep(objPtr, index, name) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &localVarNameType); \ + (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ + } while (0) + +static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, NULL, NULL }; -/* - * Type of Tcl_Objs used to speed up array searches. - * - * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: searchIdNumber (cast to pointer) - * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) - * - * Note that the value stored in ptr2 is the offset into the string of the - * start of the variable name and not the address of the variable name itself, - * as this can be safely copied. - */ - -const Tcl_ObjType tclArraySearchType = { - "array search", - NULL, NULL, NULL, SetArraySearchObj -}; +#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr1 = (arrayPtr); \ + Tcl_Obj *ptr2 = (elem); \ + if (ptr1) {Tcl_IncrRefCount(ptr1);} \ + if (ptr2) {Tcl_IncrRefCount(ptr2);} \ + ir.twoPtrValue.ptr1 = ptr1; \ + ir.twoPtrValue.ptr2 = ptr2; \ + Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ + } while (0) + +#define ParsedGetIntRep(objPtr, parsed, array, elem) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &parsedVarNameType); \ + (parsed) = (irPtr != NULL); \ + (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) Var * TclVarHashCreateVar( @@ -269,6 +314,42 @@ TclVarHashCreateVar( return varPtr; } + +static int +LocateArray( + Tcl_Interp *interp, + Tcl_Obj *name, + Var **varPtrPtr, + int *isArrayPtr) +{ + Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) { + return TCL_ERROR; + } + if (varPtrPtr) { + *varPtrPtr = varPtr; + } + if (isArrayPtr) { + *isArrayPtr = varPtr && !TclIsVarUndefined(varPtr) + && TclIsVarArray(varPtr); + } + return TCL_OK; +} + +static int +NotArrayError( + Tcl_Interp *interp, + Tcl_Obj *name) +{ + const char *nameStr = Tcl_GetString(name); + + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- @@ -301,7 +382,8 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == (unsigned) + !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -310,7 +392,8 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == (unsigned) + !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { @@ -438,9 +521,8 @@ TclLookupVar( * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType, - * tclNsVarNameType or tclParsedVarNameType and caches as much of the - * lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType + * or parsedVarNameType and caches as much of the lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * @@ -522,24 +604,20 @@ TclObjLookupVarEx( * is set to NULL. */ { Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ - const char *part1; - int index, len1, len2; - int parsed = 0; - Tcl_Obj *objPtr; - const Tcl_ObjType *typePtr = part1Ptr->typePtr; const char *errMsg = NULL; - CallFrame *varFramePtr = iPtr->varFramePtr; - const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; - char *newPart2 = NULL; - *arrayPtrPtr = NULL; + int index, parsed = 0; + + int localIndex; + Tcl_Obj *namePtr, *arrayPtr, *elem; - if (typePtr == &localVarNameType) { - int localIndex; + *arrayPtrPtr = NULL; - localVarNameTypeHandling: - localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); + restart: + LocalGetIntRep(part1Ptr, localIndex, namePtr); + if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { @@ -547,8 +625,7 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); + Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { @@ -560,12 +637,11 @@ TclObjLookupVarEx( } /* - * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed - * parts. + * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. */ - if (typePtr == &tclParsedVarNameType) { - if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); + if (parsed && arrayPtr) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify @@ -579,33 +655,23 @@ TclObjLookupVarEx( } return NULL; } - part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; - if (newPart2) { - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } - } - part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; - typePtr = part1Ptr->typePtr; - if (typePtr == &localVarNameType) { - goto localVarNameTypeHandling; - } - } - parsed = 1; + part2Ptr = elem; + part1Ptr = arrayPtr; + goto restart; } - part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { + if (!parsed) { /* * part1Ptr is possibly an unparsed array element. */ - register int i; + int len; + const char *part1 = TclGetStringFromObj(part1Ptr, &len); + + if ((len > 1) && (part1[len - 1] == ')')) { + const char *part2 = strchr(part1, '('); - len2 = -1; - for (i = 0; i < len1; i++) { - if (*(part1 + i) == '(') { + if (part2) { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -616,49 +682,13 @@ TclObjLookupVarEx( return NULL; } - /* - * part1Ptr points to an array element; first copy the element - * name to a new string part2. - */ + arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); + part2Ptr = Tcl_NewStringObj(part2 + 1, + len - (part2 - part1) - 2); - part2 = part1 + i + 1; - len2 = len1 - i - 2; - len1 = i; - - newPart2 = ckalloc(len2 + 1); - memcpy(newPart2, part2, (unsigned) len2); - *(newPart2+len2) = '\0'; - part2 = newPart2; - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } + ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); - /* - * Free the internal rep of the original part1Ptr, now renamed - * objPtr, and set it to tclParsedVarNameType. - */ - - objPtr = part1Ptr; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclParsedVarNameType; - - /* - * Define a new string object to hold the new part1Ptr, i.e., - * the array name. Set the internal rep of objPtr, reset - * typePtr and part1 to contain the references to the array - * name. - */ - - TclNewStringObj(part1Ptr, part1, len1); - Tcl_IncrRefCount(part1Ptr); - - objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; - - typePtr = part1Ptr->typePtr; - part1 = TclGetString(part1Ptr); - break; + part1Ptr = arrayPtr; } } } @@ -669,8 +699,6 @@ TclObjLookupVarEx( * the cached types if possible. */ - TclFreeIntRep(part1Ptr); - varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { @@ -679,9 +707,6 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } return NULL; } @@ -693,28 +718,39 @@ TclObjLookupVarEx( /* * An indexed local variable. */ - Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); - - part1Ptr->typePtr = &localVarNameType; - if (part1Ptr != cachedNamePtr) { - part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; - Tcl_IncrRefCount(cachedNamePtr); - if (cachedNamePtr->typePtr != &localVarNameType - || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { - TclFreeIntRep(cachedNamePtr); - } + + Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); + + if (part1Ptr == cachedNamePtr) { + cachedNamePtr = NULL; } else { - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + /* + * [80304238ac] Trickiness here. We will store and incr the + * refcount on cachedNamePtr. Trouble is that it's possible + * (see test var-22.1) for cachedNamePtr to have an intrep + * that contains a stored and refcounted part1Ptr. This + * would be a reference cycle which leads to a memory leak. + * + * The solution here is to wipe away all intrep(s) in + * cachedNamePtr and leave it as string only. This is + * radical and destructive, so a better idea would be welcome. + */ + TclFreeIntRep(cachedNamePtr); + + /* + * Now go ahead and convert it the the "localVarName" type, + * since we suspect at least some use of the value as a + * varname and we want to resolve it quickly. + */ + LocalSetIntRep(cachedNamePtr, index, NULL); } - part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); + LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. */ - part1Ptr->typePtr = &tclParsedVarNameType; - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; - part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + ParsedSetIntRep(part1Ptr, NULL, NULL); } donePart1: @@ -730,9 +766,6 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } } return varPtr; } @@ -899,54 +932,61 @@ TclLookupSimpleVar( if (varPtr == NULL) { Tcl_Obj *tailPtr; - if (create) { /* Var wasn't found so create it. */ - TclGetNamespaceForQualName(interp, varName, cxtNsPtr, - flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; - return NULL; - } else if (tail == NULL) { - *errMsgPtr = missingName; - return NULL; - } - if (tail != varName) { - tailPtr = Tcl_NewStringObj(tail, -1); - } else { - tailPtr = varNamePtr; - } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, - &isNew); - if (lookGlobal) { - /* - * The variable was created starting from the global - * namespace: a global reference is returned even if it - * wasn't explicitly requested. - */ - - *indexPtr = -1; - } else { - *indexPtr = -2; - } - } else { /* Var wasn't found and not to create it. */ + if (!create) { /* Var wasn't found and not to create it. */ *errMsgPtr = noSuchVar; return NULL; } + + /* + * Var wasn't found so create it. + */ + + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, + &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { + *errMsgPtr = badNamespace; + return NULL; + } else if (tail == NULL) { + *errMsgPtr = missingName; + return NULL; + } + if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; + } + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); + if (lookGlobal) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if it wasn't + * explicitly requested. + */ + + *indexPtr = -1; + } else { + *indexPtr = -2; + } } } else { /* Local var: look in frame varFramePtr. */ - int localLen, localCt = varFramePtr->numCompiledLocals; - Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; - const char *localNameStr; + int localCt = varFramePtr->numCompiledLocals; + + if (localCt > 0) { + Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + const char *localNameStr; + int localLen; - for (i=0 ; i<localCt ; i++, objPtrPtr++) { - register Tcl_Obj *objPtr = *objPtrPtr; + for (i=0 ; i<localCt ; i++, objPtrPtr++) { + register Tcl_Obj *objPtr = *objPtrPtr; - if (objPtr) { - localNameStr = TclGetStringFromObj(objPtr, &localLen); + if (objPtr) { + localNameStr = TclGetStringFromObj(objPtr, &localLen); - if ((varLen == localLen) && (varName[0] == localNameStr[0]) + if ((varLen == localLen) && (varName[0] == localNameStr[0]) && !memcmp(varName, localNameStr, varLen)) { - *indexPtr = i; - return (Var *) &varFramePtr->compiledLocals[i]; + *indexPtr = i; + return (Var *) &varFramePtr->compiledLocals[i]; + } } } } @@ -1032,8 +1072,6 @@ TclLookupArrayElement( { int isNew; Var *varPtr; - TclVarHashTable *tablePtr; - Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array @@ -1066,16 +1104,7 @@ TclLookupArrayElement( return NULL; } - TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(TclVarHashTable)); - arrayPtr->value.tablePtr = tablePtr; - - if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { - nsPtr = TclGetVarNsPtr(arrayPtr); - } else { - nsPtr = NULL; - } - TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); + TclInitArrayVar(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, @@ -1131,6 +1160,7 @@ TclLookupArrayElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetVar const char * Tcl_GetVar( @@ -1151,6 +1181,7 @@ Tcl_GetVar( } return TclGetString(resultPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1423,6 +1454,28 @@ TclPtrGetVarIdx( return varPtr->value.objPtr; } + /* + * Return the array default value if any. + */ + + if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { + return TclGetArrayDefault(arrayPtr); + } + if (TclIsVarArrayElement(varPtr) && !arrayPtr) { + /* + * UGLY! Peek inside the implementation of things. This lets us get + * the default of an array even when we've been [upvar]ed to just an + * element of the array. + */ + + ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) + ((VarInHash *) varPtr)->entry.tablePtr; + + if (avhtPtr->defaultObj) { + return avhtPtr->defaultObj; + } + } + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { @@ -1520,6 +1573,7 @@ Tcl_SetObjCmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetVar const char * Tcl_SetVar( @@ -1532,18 +1586,15 @@ Tcl_SetVar( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); - - Tcl_IncrRefCount(varNamePtr); - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, Tcl_NewStringObj(newValue, -1), flags); - Tcl_DecrRefCount(varNamePtr); if (varValuePtr == NULL) { return NULL; } return TclGetString(varValuePtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1785,6 +1836,130 @@ TclPtrSetVar( /* *---------------------------------------------------------------------- * + * ListAppendInVar, StringAppendInVar -- + * + * Support functions for TclPtrSetVarIdx that implement various types of + * appending operations. + * + * Results: + * ListAppendInVar returns a Tcl result code (from the core list append + * operation). StringAppendInVar has no return value. + * + * Side effects: + * The variable or element of the array is updated. This may make the + * variable/element exist. Reference counts of values may be updated. + * + *---------------------------------------------------------------------- + */ + +static inline int +ListAppendInVar( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + if (oldValuePtr == NULL) { + /* + * No previous value. Check for defaults if there's an array we can + * ask this of. + */ + + if (arrayPtr) { + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); + + if (defValuePtr) { + oldValuePtr = Tcl_DuplicateObj(defValuePtr); + } + } + + if (oldValuePtr == NULL) { + /* + * No default. [lappend] semantics say this is like being an empty + * string. + */ + + TclNewObj(oldValuePtr); + } + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + + return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); +} + +static inline void +StringAppendInVar( + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + /* + * If there was no previous value, either we use the array's default (if + * this is an array with a default at all) or we treat this as a simple + * set. + */ + + if (oldValuePtr == NULL) { + if (arrayPtr) { + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); + + if (defValuePtr) { + /* + * This is *almost* the same as the shared path below, except + * that the original value reference in defValuePtr is not + * decremented. + */ + + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + return; + } + } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + return; + } + + /* + * We append newValuePtr's bytes but don't change its ref count. Unless + * the reference is shared, when we have to duplicate in order to be safe + * to modify at all. + */ + + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } +} + +/* + *---------------------------------------------------------------------- + * * TclPtrSetVarIdx -- * * This function is the same as Tcl_SetVar2Ex above, except that it @@ -1897,44 +2072,13 @@ TclPtrSetVarIdx( } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - result = Tcl_ListObjAppendElement(interp, oldValuePtr, + result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } else { - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } + StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); } } else if (newValuePtr != oldValuePtr) { /* @@ -2189,7 +2333,6 @@ TclPtrIncrObjVarIdx( } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for @@ -2225,6 +2368,7 @@ TclPtrIncrObjVarIdx( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UnsetVar int Tcl_UnsetVar( @@ -2253,6 +2397,7 @@ Tcl_UnsetVar( Tcl_DecrRefCount(varNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2929,173 +3074,308 @@ Tcl_LappendObjCmd( /* *---------------------------------------------------------------------- * - * TclArraySet -- + * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext -- * - * Set the elements of an array. If there are no elements to set, create - * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the - * TclSetupEnv routine. + * These functions implement the "array for" Tcl command. + * array for {k v} a {} + * The array for command iterates over the array, setting the the + * specified loop variables, and executing the body each iteration. * - * Results: - * A standard Tcl result object. + * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd(). * - * Side effects: - * A variable will be created if one does not already exist. - * Callers must Incr arrayNameObj if they pland to Decr it. + * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr + * inside the structure and calls VarHashFirstEntry to start the hash + * iteration. + * + * ArrayForNRCmd() does not execute the body or set the loop variables, + * it only initializes the iterator. + * + * ArrayForLoopCallback() iterates over the entire array, executing the + * body each time. * *---------------------------------------------------------------------- */ -int -TclArraySet( +static int +ArrayObjNext( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, /* array */ + Var *varPtr, /* array */ + ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the + * value written into, or NULL.*/ +{ + Tcl_Obj *keyObj; + Tcl_Obj *valueObj = NULL; + int gotValue; + int donerc; + + donerc = TCL_BREAK; + + if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) { + donerc = TCL_ERROR; + return donerc; + } + + gotValue = 0; + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + if (hPtr != NULL) { + searchPtr->nextEntry = NULL; + } else { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + gotValue = 0; + break; + } + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + + if (!gotValue) { + return donerc; + } + + donerc = TCL_CONTINUE; + + keyObj = VarHashGetKey(varPtr); + *keyPtrPtr = keyObj; + valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, + TCL_LEAVE_ERR_MSG); + *valuePtrPtr = valueObj; + + return donerc; +} + +static int +ArrayForObjCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *arrayNameObj, /* The array name. */ - Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is - * NULL, create an empty array. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Var *varPtr, *arrayPtr; - int result, i; + return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv); +} - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { +static int +ArrayForNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *varListObj, *arrayNameObj, *scriptObj; + ArraySearch *searchPtr = NULL; + Var *varPtr; + int isArray, numVars; + + /* + * array for {k v} a body + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script"); return TCL_ERROR; } - if (arrayPtr) { - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + + /* + * Parse arguments. + */ + + if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { + return TCL_ERROR; + } + + if (numVars != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - if (arrayElemObj == NULL) { - goto ensureArray; + if (!isArray) { + return NotArrayError(interp, arrayNameObj); } /* - * Install the contents of the dictionary or list into the array. + * Make a new array search, put it on the stack. */ - if (arrayElemObj->typePtr == &tclDictType) { - Tcl_Obj *keyPtr, *valuePtr; - Tcl_DictSearch search; - int done; + searchPtr = ckalloc(sizeof(ArraySearch)); + ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { - return TCL_ERROR; - } - if (done == 0) { - /* - * Empty, so we'll just force the array to be properly existing - * instead. - */ + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. + */ - goto ensureArray; - } + varListObj = TclListObjCopy(NULL, objv[1]); + scriptObj = objv[3]; + Tcl_IncrRefCount(scriptObj); - /* - * Don't need to look at result of Tcl_DictObjFirst as we've just - * successfully used a dictionary operation on the same object. - */ + /* + * Run the script. + */ - for (Tcl_DictObjFirst(interp, arrayElemObj, &search, - &keyPtr, &valuePtr, &done) ; !done ; - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { - /* - * At this point, it would be nice if the key was directly usable - * by the array. This isn't the case though. - */ + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TCL_OK; +} - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); +static int +ArrayForLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + ArraySearch *searchPtr = data[0]; + Tcl_Obj *varListObj = data[1]; + Tcl_Obj *arrayNameObj = data[2]; + Tcl_Obj *scriptObj = data[3]; + Tcl_Obj **varv; + Tcl_Obj *keyObj, *valueObj; + Var *varPtr; + Var *arrayPtr; + int done, varc; - if ((elemVarPtr == NULL) || - (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - } - return TCL_OK; - } else { - /* - * Not a dictionary, so assume (and convert to, for backward- - * -compatibility reasons) a list. - */ + /* + * Process the result from the previous execution of the script body. + */ - int elemLen; - Tcl_Obj **elemPtrs, *copyListObj; + done = TCL_ERROR; - result = TclListObjGetElements(interp, arrayElemObj, - &elemLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (elemLen & 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); - return TCL_ERROR; - } - if (elemLen == 0) { - goto ensureArray; + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"array for\" body line %d)", + Tcl_GetErrorLine(interp))); } + goto arrayfordone; + } - /* - * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVarIdx will return NULL so that we break out of - * the loop and return an error. - */ + /* + * Get the next mapping from the array. + */ - copyListObj = TclListObjCopy(NULL, arrayElemObj); - for (i=0 ; i<elemLen ; i+=2) { - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + keyObj = NULL; + valueObj = NULL; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + done = TCL_ERROR; + } else { + done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj, + &valueObj); + } - if ((elemVarPtr == NULL) || - (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ - result = TCL_ERROR; - break; - } + result = TCL_OK; + if (done != TCL_CONTINUE) { + Tcl_ResetResult(interp); + if (done == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array changed during iteration", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); + varPtr->flags |= TCL_LEAVE_ERR_MSG; + result = done; + } + goto arrayfordone; + } + + Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); + if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; + } + if (valueObj != NULL) { + if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; } - Tcl_DecrRefCount(copyListObj); - return result; } /* - * The list is empty make sure we have an array, or create one if - * necessary. + * Run the script. */ - ensureArray: - if (varPtr != NULL) { - if (TclIsVarArray(varPtr)) { - /* - * Already an array, done. - */ + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); - return TCL_OK; - } - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ + /* + * For unwinding everything once the iterating is done. + */ - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - return TCL_ERROR; - } + arrayfordone: + if (done != TCL_ERROR) { + /* + * If the search was terminated by an array change, the + * VAR_SEARCH_ACTIVE flag will no longer be set. + */ + + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); + ckfree(searchPtr); } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); - return TCL_OK; + + TclDecrRefCount(varListObj); + TclDecrRefCount(scriptObj); + return result; } /* + * ArrayPopulateSearch + */ + +static void +ArrayPopulateSearch( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, + Var *varPtr, + ArraySearch *searchPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int isNew; + + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + searchPtr->id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; + } else { + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, + TclGetString(arrayNameObj)); + Tcl_IncrRefCount(searchPtr->name); +} +/* *---------------------------------------------------------------------- * * ArrayStartSearchCmd -- @@ -3114,6 +3394,7 @@ TclArraySet( */ /* ARGSUSED */ + static int ArrayStartSearchCmd( ClientData clientData, @@ -3121,77 +3402,75 @@ ArrayStartSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_HashEntry *hPtr; - Tcl_Obj *varNameObj; - int isNew; + Var *varPtr; + int isArray; ArraySearch *searchPtr; - const char *varName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - varName = TclGetString(varNameObj); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + return TCL_ERROR; + } - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (!isArray) { + return NotArrayError(interp, objv[1]); } /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. + * Make a new array search with a free name. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", varName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return TCL_ERROR; - } + searchPtr = ckalloc(sizeof(ArraySearch)); + ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); + Tcl_SetObjResult(interp, searchPtr->name); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayDoneSearch -- + * + * Removes the search from the hash of active searches. + * + *---------------------------------------------------------------------- + */ +static void +ArrayDoneSearch( + Interp *iPtr, + Var *varPtr, + ArraySearch *searchPtr) +{ + Tcl_HashEntry *hPtr; + ArraySearch *prevPtr; /* - * Make a new array search with a free name. + * Unhook the search from the list of searches associated with the + * variable. */ - searchPtr = ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; + hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + if (hPtr == NULL) { + return; + } + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); - return TCL_OK; } /* @@ -3220,9 +3499,9 @@ ArrayAnyMoreCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - int gotValue; + int gotValue, isArray; ArraySearch *searchPtr; if (objc != 3) { @@ -3232,40 +3511,12 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3326,10 +3577,10 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3338,40 +3589,12 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3436,10 +3659,10 @@ ArrayDoneSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_HashEntry *hPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + ArraySearch *searchPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3448,40 +3671,12 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3493,27 +3688,8 @@ ArrayDoneSearchCmd( return TCL_ERROR; } - /* - * Unhook the search from the list of searches associated with the - * variable. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (searchPtr == Tcl_GetHashValue(hPtr)) { - if (searchPtr->nextPtr) { - Tcl_SetHashValue(hPtr, searchPtr->nextPtr); - } else { - varPtr->flags &= ~VAR_SEARCH_ACTIVE; - Tcl_DeleteHashEntry(hPtr); - } - } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); return TCL_OK; } @@ -3543,45 +3719,19 @@ ArrayExistsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *arrayNameObj; - int notArray; + Interp *iPtr = (Interp *)interp; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - arrayNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) { + return TCL_ERROR; } - /* - * Check whether we've actually got an array variable. - */ - - notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)); - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]); return TCL_OK; } @@ -3610,13 +3760,12 @@ ArrayGetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; + Var *varPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; Tcl_Obj **nameObjPtr, *patternObj; Tcl_HashSearch search; const char *pattern; - int i, count, result; + int i, count, result, isArray; switch (objc) { case 2: @@ -3632,35 +3781,12 @@ ArrayGetCmd( return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, it's an empty result. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + /* If not an array, it's an empty result. */ + if (!isArray) { return TCL_OK; } @@ -3798,39 +3924,20 @@ ArrayNamesCmd( "-exact", "-glob", "-regexp", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; - Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; + Var *varPtr, *varPtr2; + Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int mode = OPT_GLOB; + int isArray, mode = OPT_GLOB; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } - varNameObj = objv[1]; patternObj = (objc > 2 ? objv[objc-1] : NULL); - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + return TCL_ERROR; } /* @@ -3842,14 +3949,9 @@ ArrayNamesCmd( return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, the result is empty. - */ + /* If not an array, the result is empty. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } @@ -3986,36 +4088,155 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Tcl_Obj *arrayNameObj; + Tcl_Obj *arrayElemObj; Var *varPtr, *arrayPtr; + int result, i; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) { + return TCL_ERROR; + } + + arrayNameObj = objv[1]; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + /* - * Locate the array variable. + * Install the contents of the dictionary or list into the array. */ - varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + arrayElemObj = objv[2]; + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done; + + if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + return TCL_ERROR; + } + if (done == 0) { + /* + * Empty, so we'll just force the array to be properly existing + * instead. + */ + + goto ensureArray; + } + + /* + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. + */ + + for (Tcl_DictObjFirst(interp, arrayElemObj, &search, + &keyPtr, &valuePtr, &done) ; !done ; + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { + /* + * At this point, it would be nice if the key was directly usable + * by the array. This isn't the case though. + */ + + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + return TCL_OK; + } else { + /* + * Not a dictionary, so assume (and convert to, for backward- + * -compatibility reasons) a list. + */ + + int elemLen; + Tcl_Obj **elemPtrs, *copyListObj; + + result = TclListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list must have an even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + return TCL_ERROR; + } + if (elemLen == 0) { + goto ensureArray; + } + + /* + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVarIdx will return NULL so that we break out of + * the loop and return an error. + */ + + copyListObj = TclListObjCopy(NULL, arrayElemObj); + for (i=0 ; i<elemLen ; i+=2) { + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG, + -1) == NULL)) { + result = TCL_ERROR; + break; + } + } + Tcl_DecrRefCount(copyListObj); + return result; + } /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. + * The list is empty make sure we have an array, or create one if + * necessary. */ - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + ensureArray: + if (varPtr != NULL) { + if (TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } } - - return TclArraySet(interp, objv[1], objv[2]); + TclInitArrayVar(varPtr); + return TCL_OK; } /* @@ -4043,47 +4264,23 @@ ArraySizeCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *varNameObj; + Var *varPtr; Tcl_HashSearch search; Var *varPtr2; - int size = 0; + int isArray, size = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. We can only iterate over the array if it exists... - */ + /* We can only iterate over the array if it exists... */ - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (isArray) { /* * Must iterate in order to get chance to check for present but * "undefined" entries. @@ -4127,10 +4324,10 @@ ArrayStatsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj; char *stats; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); @@ -4138,40 +4335,12 @@ ArrayStatsCmd( } varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); @@ -4210,12 +4379,12 @@ ArrayUnsetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; + Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int isArray; switch (objc) { case 2: @@ -4231,35 +4400,11 @@ ArrayUnsetCmd( return TCL_ERROR; } - /* - * Locate the array variable - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } @@ -4370,8 +4515,10 @@ TclInitArrayCmd( { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, + {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -4396,7 +4543,7 @@ TclInitArrayCmd( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4490,7 +4637,7 @@ ObjMakeUpvar( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4681,6 +4828,7 @@ TclPtrObjMakeUpvarIdx( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UpVar int Tcl_UpVar( @@ -4714,6 +4862,7 @@ Tcl_UpVar( Tcl_DecrRefCount(localNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5169,75 +5318,6 @@ Tcl_UpvarObjCmd( /* *---------------------------------------------------------------------- * - * SetArraySearchObj -- - * - * This function converts the given tcl object into one that has the - * "array search" internal type. - * - * Results: - * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when - * an error message will be placed in the interpreter's result.) - * - * Side effects: - * Updates the internal type and representation of the object to make - * this an array-search object. See the tclArraySearchType declaration - * above for details of the internal representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetArraySearchObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - const char *string; - char *end; /* Can't be const due to strtoul defn. */ - int id; - size_t offset; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetString(objPtr); - - /* - * Parse the id into the three parts separated by dashes. - */ - - if ((string[0] != 's') || (string[1] != '-')) { - goto syntax; - } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - - /* - * Can't perform value check in this context, so place reference to place - * in string to use for the check in the object instead. - */ - - end++; - offset = end - string; - - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclArraySearchType; - objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); - return TCL_OK; - - syntax: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active @@ -5248,10 +5328,6 @@ SetArraySearchObj( * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. * - * Side effects: - * The tcl object might have its internal type and representation - * modified. - * *---------------------------------------------------------------------- */ @@ -5267,65 +5343,43 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - register const char *string; - register size_t offset; - int id; ArraySearch *searchPtr; - const char *varName = TclGetString(varNamePtr); - - /* - * Parse the id. - */ - - if ((handleObj->typePtr != &tclArraySearchType) - && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { - return NULL; - } - - /* - * Extract the information out of the Tcl_Obj. - */ - - id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); - string = TclGetString(handleObj); - offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); - - /* - * This test cannot be placed inside the Tcl_Obj machinery, since it is - * dependent on the variable context. - */ - - if (strcmp(string+offset, varName) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - string, varName)); - goto badLookup; - } - - /* - * Search through the list of active searches on the interpreter to see if - * the desired one exists. - * - * Note that we cannot store the searchPtr directly in the Tcl_Obj as that - * would run into trouble when DeleteSearches() was called so we must scan - * this list every time. - */ + const char *handle = TclGetString(handleObj); + char *end; if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + /* First look for same (Tcl_Obj *) */ + for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->name == handleObj) { + return searchPtr; + } + } + /* Fallback: do string compares. */ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { - if (searchPtr->id == id) { + if (strcmp(TclGetString(searchPtr->name), handle) == 0) { return searchPtr; } } } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", string)); - badLookup: - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + if ((handle[0] != 's') || (handle[1] != '-') + || (strtoul(handle + 2, &end, 10), end == (handle + 2)) + || (*end != '-')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", handle)); + } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + handle, TclGetString(varNamePtr))); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", handle)); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); return NULL; } @@ -5360,6 +5414,7 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; @@ -5596,9 +5651,6 @@ DeleteArray( Tcl_Obj *objPtr; VarTrace *tracePtr; - if (varPtr->flags & VAR_SEARCH_ACTIVE) { - DeleteSearches(iPtr, varPtr); - } for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search); elPtr != NULL; elPtr = VarHashNextVar(&search)) { if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { @@ -5654,8 +5706,7 @@ DeleteArray( TclClearVarNamespaceVar(elPtr); } - VarHashDeleteTable(varPtr->value.tablePtr); - ckfree(varPtr->value.tablePtr); + DeleteArrayVar(varPtr); } /* @@ -5733,28 +5784,6 @@ TclObjVarErrMsg( */ /* - * Panic functions that should never be called in normal operation. - */ - -static void -PanicOnUpdateVarName( - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "updateStringProc", - objPtr->typePtr->name); -} - -static int -PanicOnSetVarName( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", - objPtr->typePtr->name); - return TCL_ERROR; -} - -/* * localVarName - * * INTERNALREP DEFINITION: @@ -5767,12 +5796,15 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(objPtr, index, namePtr); + + index++; /* Compiler warning bait. */ if (namePtr) { Tcl_DecrRefCount(namePtr); } - objPtr->typePtr = NULL; } static void @@ -5780,17 +5812,14 @@ DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; - Tcl_IncrRefCount(namePtr); - - dupPtr->internalRep.twoPtrValue.ptr2 = - srcPtr->internalRep.twoPtrValue.ptr2; - dupPtr->typePtr = &localVarNameType; + LocalSetIntRep(dupPtr, index, namePtr); } /* @@ -5806,14 +5835,16 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *arrayPtr, *elem; + int parsed; + ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); + + parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - ckfree(elem); + TclDecrRefCount(elem); } - objPtr->typePtr = NULL; } static void @@ -5821,58 +5852,13 @@ DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; - char *elemCopy; - unsigned elemLen; + register Tcl_Obj *arrayPtr, *elem; + int parsed; - if (arrayPtr != NULL) { - Tcl_IncrRefCount(arrayPtr); - elemLen = strlen(elem); - elemCopy = ckalloc(elemLen + 1); - memcpy(elemCopy, elem, elemLen); - *(elemCopy + elemLen) = '\0'; - elem = elemCopy; - } + ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); - dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; - dupPtr->internalRep.twoPtrValue.ptr2 = elem; - dupPtr->typePtr = &tclParsedVarNameType; -} - -static void -UpdateParsedVarName( - Tcl_Obj *objPtr) -{ - Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - char *part2 = objPtr->internalRep.twoPtrValue.ptr2; - const char *part1; - char *p; - int len1, len2, totalLen; - - if (arrayPtr == NULL) { - /* - * This is a parsed scalar name: what is it doing here? - */ - - Tcl_Panic("scalar parsedVarName without a string rep"); - } - - part1 = TclGetStringFromObj(arrayPtr, &len1); - len2 = strlen(part2); - - totalLen = len1 + len2 + 2; - p = ckalloc(totalLen + 1); - objPtr->bytes = p; - objPtr->length = totalLen; - - memcpy(p, part1, (unsigned) len1); - p += len1; - *p++ = '('; - memcpy(p, part2, (unsigned) len2); - p += len2; - *p++ = ')'; - *p = '\0'; + parsed++; /* Silence compiler. */ + ParsedSetIntRep(dupPtr, arrayPtr, elem); } /* @@ -6201,7 +6187,7 @@ TclInfoVarsCmd( */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { @@ -6407,7 +6393,7 @@ AppendLocals( Interp *iPtr = (Interp *) interp; Var *varPtr; int i, localVarCt, added; - Tcl_Obj **varNamePtr, *objNamePtr; + Tcl_Obj *objNamePtr; const char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; @@ -6417,27 +6403,30 @@ AppendLocals( localVarCt = iPtr->varFramePtr->numCompiledLocals; varPtr = iPtr->varFramePtr->compiledLocals; localVarTablePtr = iPtr->varFramePtr->varTablePtr; - varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; if (includeLinks) { Tcl_InitObjHashTable(&addedTable); } - for (i = 0; i < localVarCt; i++, varNamePtr++) { - /* - * Skip nameless (temporary) variables and undefined variables. - */ + if (localVarCt > 0) { + Tcl_Obj **varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; - if (*varNamePtr && !TclIsVarUndefined(varPtr) + for (i = 0; i < localVarCt; i++, varNamePtr++) { + /* + * Skip nameless (temporary) variables and undefined variables. + */ + + if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - varName = TclGetString(*varNamePtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); - if (includeLinks) { - Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + varName = TclGetString(*varNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + } } } + varPtr++; } - varPtr++; } /* @@ -6494,25 +6483,50 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *contextPtr = iPtr->varFramePtr->clientData; - Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Method *mPtr = (Method *) + Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData); + PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { - FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Object *oPtr = mPtr->declaringObjectPtr; + + FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } else { - FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Class *clsPtr = mPtr->declaringClassPtr; + + FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } } Tcl_DeleteHashTable(&addedTable); @@ -6585,9 +6599,9 @@ CompareVarKeys( /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - - if (objPtr1 == objPtr2) return 1; - */ + * + * if (objPtr1 == objPtr2) return 1; + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a @@ -6606,6 +6620,264 @@ CompareVarKeys( return ((l1 == l2) && !memcmp(p1, p2, l1)); } +/*---------------------------------------------------------------------- + * + * ArrayDefaultCmd -- + * + * This function implements the 'array default' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayDefaultCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const options[] = { + "get", "set", "exists", "unset", NULL + }; + enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + Tcl_Obj *arrayNameObj, *defaultValueObj; + Var *varPtr, *arrayPtr; + int isArray, option; + + /* + * Parse arguments. + */ + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &option) != TCL_OK) { + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { + return TCL_ERROR; + } + + switch (option) { + case OPT_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + defaultValueObj = TclGetArrayDefault(varPtr); + if (!defaultValueObj) { + /* Array default must exist. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array has no default value", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, defaultValueObj); + return TCL_OK; + + case OPT_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); + return TCL_ERROR; + } + + /* + * Attempt to create array if needed. + */ + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + /* + * Not a valid array name. + */ + + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * Not an array. + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + return TCL_ERROR; + } + + if (!TclIsVarArray(varPtr)) { + TclInitArrayVar(varPtr); + } + defaultValueObj = objv[3]; + SetArrayDefault(varPtr, defaultValueObj); + return TCL_OK; + + case OPT_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + + /* + * Undefined variables (whether or not they have storage allocated) do + * not have defaults, and this is not an error case. + */ + + if (!varPtr || TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } else { + defaultValueObj = TclGetArrayDefault(varPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); + } + return TCL_OK; + + case OPT_UNSET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + + if (varPtr && !TclIsVarUndefined(varPtr)) { + if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } + SetArrayDefault(varPtr, NULL); + } + return TCL_OK; + } + + /* Unreached */ + return TCL_ERROR; +} + +/* + * Initialize array variable. + */ + +void +TclInitArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + /* + * Mark the variable as an array. + */ + + TclSetVarArray(arrayPtr); + + /* + * Regular TclVarHashTable initialization. + */ + + arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; + TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + + /* + * Default value initialization. + */ + + tablePtr->defaultObj = NULL; +} + +/* + * Cleanup array variable. + */ + +static void +DeleteArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Default value cleanup. + */ + + SetArrayDefault(arrayPtr, NULL); + + /* + * Regular TclVarHashTable cleanup. + */ + + VarHashDeleteTable(arrayPtr->value.tablePtr); + ckfree(tablePtr); +} + +/* + * Get array default value if any. + */ + +Tcl_Obj * +TclGetArrayDefault( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + return tablePtr->defaultObj; +} + +/* + * Set/replace/unset array default value. + */ + +static void +SetArrayDefault( + Var *arrayPtr, + Tcl_Obj *defaultObj) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Increment/decrement refcount twice to ensure that the object is shared, + * so that it doesn't get modified accidentally by the folling code: + * + * array default set v 1 + * lappend v(a) 2; # returns a new object {1 2} + * set v(b); # returns the original default object "1" + */ + + if (tablePtr->defaultObj) { + Tcl_DecrRefCount(tablePtr->defaultObj); + Tcl_DecrRefCount(tablePtr->defaultObj); + } + tablePtr->defaultObj = defaultObj; + if (tablePtr->defaultObj) { + Tcl_IncrRefCount(tablePtr->defaultObj); + Tcl_IncrRefCount(tablePtr->defaultObj); + } +} + /* * Local Variables: * mode: c diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c new file mode 100644 index 0000000..428be15 --- /dev/null +++ b/generic/tclZipfs.c @@ -0,0 +1,5011 @@ +/* + * tclZipfs.c -- + * + * Implementation of the ZIP filesystem used in TIP 430 + * Adapted from the implentation for AndroWish. + * + * Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com> + * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de> + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This file is distributed in two ways: + * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. + * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 + * projects. + */ + +#include "tclInt.h" +#include "tclFileSystem.h" + +#ifndef _WIN32 +#include <sys/mman.h> +#endif /* _WIN32*/ + +#ifndef MAP_FILE +#define MAP_FILE 0 +#endif /* !MAP_FILE */ + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "crypt.h" + +#ifdef CFG_RUNTIME_DLLFILE + +/* +** We are compiling as part of the core. +** TIP430 style zipfs prefix +*/ + +#define ZIPFS_VOLUME "//zipfs:/" +#define ZIPFS_VOLUME_LEN 9 +#define ZIPFS_APP_MOUNT "//zipfs:/app" +#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" + +#else /* !CFG_RUNTIME_DLLFILE */ + +/* +** We are compiling from the /compat folder of tclconfig +** Pre TIP430 style zipfs prefix +** //zipfs:/ doesn't work straight out of the box on either windows or Unix +** without other changes made to tip 430 +*/ + +#define ZIPFS_VOLUME "zipfs:/" +#define ZIPFS_VOLUME_LEN 7 +#define ZIPFS_APP_MOUNT "zipfs:/app" +#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" + +#endif /* CFG_RUNTIME_DLLFILE */ + +/* + * Various constants and offsets found in ZIP archive files + */ + +#define ZIP_SIG_LEN 4 + +/* + * Local header of ZIP archive member (at very beginning of each member). + */ + +#define ZIP_LOCAL_HEADER_SIG 0x04034b50 +#define ZIP_LOCAL_HEADER_LEN 30 +#define ZIP_LOCAL_SIG_OFFS 0 +#define ZIP_LOCAL_VERSION_OFFS 4 +#define ZIP_LOCAL_FLAGS_OFFS 6 +#define ZIP_LOCAL_COMPMETH_OFFS 8 +#define ZIP_LOCAL_MTIME_OFFS 10 +#define ZIP_LOCAL_MDATE_OFFS 12 +#define ZIP_LOCAL_CRC32_OFFS 14 +#define ZIP_LOCAL_COMPLEN_OFFS 18 +#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 +#define ZIP_LOCAL_PATHLEN_OFFS 26 +#define ZIP_LOCAL_EXTRALEN_OFFS 28 + +/* + * Central header of ZIP archive member at end of ZIP file. + */ + +#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 +#define ZIP_CENTRAL_HEADER_LEN 46 +#define ZIP_CENTRAL_SIG_OFFS 0 +#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 +#define ZIP_CENTRAL_VERSION_OFFS 6 +#define ZIP_CENTRAL_FLAGS_OFFS 8 +#define ZIP_CENTRAL_COMPMETH_OFFS 10 +#define ZIP_CENTRAL_MTIME_OFFS 12 +#define ZIP_CENTRAL_MDATE_OFFS 14 +#define ZIP_CENTRAL_CRC32_OFFS 16 +#define ZIP_CENTRAL_COMPLEN_OFFS 20 +#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 +#define ZIP_CENTRAL_PATHLEN_OFFS 28 +#define ZIP_CENTRAL_EXTRALEN_OFFS 30 +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 +#define ZIP_CENTRAL_DISKFILE_OFFS 34 +#define ZIP_CENTRAL_IATTR_OFFS 36 +#define ZIP_CENTRAL_EATTR_OFFS 38 +#define ZIP_CENTRAL_LOCALHDR_OFFS 42 + +/* + * Central end signature at very end of ZIP file. + */ + +#define ZIP_CENTRAL_END_SIG 0x06054b50 +#define ZIP_CENTRAL_END_LEN 22 +#define ZIP_CENTRAL_END_SIG_OFFS 0 +#define ZIP_CENTRAL_DISKNO_OFFS 4 +#define ZIP_CENTRAL_DISKDIR_OFFS 6 +#define ZIP_CENTRAL_ENTS_OFFS 8 +#define ZIP_CENTRAL_TOTALENTS_OFFS 10 +#define ZIP_CENTRAL_DIRSIZE_OFFS 12 +#define ZIP_CENTRAL_DIRSTART_OFFS 16 +#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 + +#define ZIP_MIN_VERSION 20 +#define ZIP_COMPMETH_STORED 0 +#define ZIP_COMPMETH_DEFLATED 8 + +#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 + +#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) + +/* + * Macros to report errors only if an interp is present. + */ + +#define ZIPFS_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ + } \ + } while (0) +#define ZIPFS_POSIX_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s: %s", errstr, Tcl_PosixError(interp))); \ + } \ + } while (0) + +/* + * Macros to read and write 16 and 32 bit integers from/to ZIP archives. + */ + +#define ZipReadInt(p) \ + ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) +#define ZipReadShort(p) \ + ((p)[0] | ((p)[1] << 8)) + +#define ZipWriteInt(p, v) \ + do { \ + (p)[0] = (v) & 0xff; \ + (p)[1] = ((v) >> 8) & 0xff; \ + (p)[2] = ((v) >> 16) & 0xff; \ + (p)[3] = ((v) >> 24) & 0xff; \ + } while (0) +#define ZipWriteShort(p, v) \ + do { \ + (p)[0] = (v) & 0xff; \ + (p)[1] = ((v) >> 8) & 0xff; \ + } while (0) + +/* + * Windows drive letters. + */ + +#ifdef _WIN32 +static const char drvletters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; +#endif /* _WIN32 */ + +/* + * Mutex to protect localtime(3) when no reentrant version available. + */ + +#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS +TCL_DECLARE_MUTEX(localtimeMutex) +#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ + +/* + * In-core description of mounted ZIP archive file. + */ + +typedef struct ZipFile { + char *name; /* Archive name */ + size_t nameLength; /* Length of archive name */ + char isMemBuffer; /* When true, not a file but a memory buffer */ + Tcl_Channel chan; /* Channel handle or NULL */ + unsigned char *data; /* Memory mapped or malloc'ed file */ + size_t length; /* Length of memory mapped file */ + void *ptrToFree; /* Non-NULL if malloc'ed file */ + size_t numFiles; /* Number of files in archive */ + size_t baseOffset; /* Archive start */ + size_t passOffset; /* Password start */ + size_t directoryOffset; /* Archive directory start */ + unsigned char passBuf[264]; /* Password buffer */ + size_t numOpen; /* Number of open files on archive */ + struct ZipEntry *entries; /* List of files in archive */ + struct ZipEntry *topEnts; /* List of top-level dirs in archive */ + char *mountPoint; /* Mount point name */ + size_t mountPointLen; /* Length of mount point name */ +#ifdef _WIN32 + HANDLE mountHandle; /* Handle used for direct file access. */ +#endif /* _WIN32 */ +} ZipFile; + +/* + * In-core description of file contained in mounted ZIP archive. + */ + +typedef struct ZipEntry { + char *name; /* The full pathname of the virtual file */ + ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ + Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */ + int numBytes; /* Uncompressed size of the virtual file */ + int numCompressedBytes; /* Compressed size of the virtual file */ + int compressMethod; /* Compress method */ + int isDirectory; /* Set to 1 if directory, or -1 if root */ + int depth; /* Number of slashes in path. */ + int crc32; /* CRC-32 */ + int timestamp; /* Modification time */ + int isEncrypted; /* True if data is encrypted */ + unsigned char *data; /* File data if written */ + struct ZipEntry *next; /* Next file in the same archive */ + struct ZipEntry *tnext; /* Next top-level dir in archive */ +} ZipEntry; + +/* + * File channel for file contained in mounted ZIP archive. + */ + +typedef struct ZipChannel { + ZipFile *zipFilePtr; /* The ZIP file holding this channel */ + ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ + size_t maxWrite; /* Maximum size for write */ + size_t numBytes; /* Number of bytes of uncompressed data */ + size_t numRead; /* Position of next byte to be read from the + * channel */ + unsigned char *ubuf; /* Pointer to the uncompressed data */ + int iscompr; /* True if data is compressed */ + int isDirectory; /* Set to 1 if directory, or -1 if root */ + int isEncrypted; /* True if data is encrypted */ + int isWriting; /* True if open for writing */ + unsigned long keys[3]; /* Key for decryption */ +} ZipChannel; + +/* + * Global variables. + * + * Most are kept in single ZipFS struct. When build with threading support + * this struct is protected by the ZipFSMutex (see below). + * + * The "fileHash" component is the process wide global table of all known ZIP + * archive members in all mounted ZIP archives. + * + * The "zipHash" components is the process wide global table of all mounted + * ZIP archive files. + */ + +static struct { + int initialized; /* True when initialized */ + int lock; /* RW lock, see below */ + int waiters; /* RW lock, see below */ + int wrmax; /* Maximum write size of a file */ + int idCount; /* Counter for channel names */ + Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ + Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ +} ZipFS = { + 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, +}; + +/* + * For password rotation. + */ + +static const char pwrot[16] = { + 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, + 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 +}; + +/* + * Table to compute CRC32. + */ + +static const z_crc_t crc32tab[256] = { + 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, + 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, + 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, + 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, + 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, + 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, + 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d, +}; + +static const char *zipfs_literal_tcl_library = NULL; + +/* Function prototypes */ + +static inline int DescribeMounted(Tcl_Interp *interp, + const char *mountPoint); +static inline int ListMountPoints(Tcl_Interp *interp); +static int ZipfsAppHookFindTclInit(const char *archive); +static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, + ClientData *clientDataPtr); +static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); +static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr); +static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode); +static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, + Tcl_Obj *pathPtr, int mode, int permissions); +static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, + const char *pattern, Tcl_GlobTypeData *types); +static Tcl_Obj * ZipFSListVolumesProc(void); +static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef); +static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, + Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); +static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, + Tcl_Obj *pathPtr, Tcl_Obj *objPtr); +static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static void ZipfsSetup(void); +static int ZipChannelClose(ClientData instanceData, + Tcl_Interp *interp); +static int ZipChannelGetFile(ClientData instanceData, + int direction, ClientData *handlePtr); +static int ZipChannelRead(ClientData instanceData, char *buf, + int toRead, int *errloc); +static int ZipChannelSeek(ClientData instanceData, long offset, + int mode, int *errloc); +static void ZipChannelWatchChannel(ClientData instanceData, + int mask); +static int ZipChannelWrite(ClientData instanceData, + const char *buf, int toWrite, int *errloc); + +/* + * Define the ZIP filesystem dispatch table. + */ + +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; + +const Tcl_Filesystem zipfsFilesystem = { + "zipfs", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + ZipFSPathInFilesystemProc, + NULL, /* dupInternalRepProc */ + NULL, /* freeInternalRepProc */ + NULL, /* internalToNormalizedProc */ + NULL, /* createInternalRepProc */ + NULL, /* normalizePathProc */ + ZipFSFilesystemPathTypeProc, + ZipFSFilesystemSeparatorProc, + ZipFSStatProc, + ZipFSAccessProc, + ZipFSOpenFileChannelProc, + ZipFSMatchInDirectoryProc, + NULL, /* utimeProc */ + NULL, /* linkProc */ + ZipFSListVolumesProc, + ZipFSFileAttrStringsProc, + ZipFSFileAttrsGetProc, + ZipFSFileAttrsSetProc, + NULL, /* createDirectoryProc */ + NULL, /* removeDirectoryProc */ + NULL, /* deleteFileProc */ + NULL, /* copyFileProc */ + NULL, /* renameFileProc */ + NULL, /* copyDirectoryProc */ + NULL, /* lstatProc */ + (Tcl_FSLoadFileProc *) ZipFSLoadFile, + NULL, /* getCwdProc */ + NULL, /* chdirProc */ +}; + +/* + * The channel type/driver definition used for ZIP archive members. + */ + +static Tcl_ChannelType ZipChannelType = { + "zip", /* Type name. */ + TCL_CHANNEL_VERSION_5, + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + NULL, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + NULL, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ + NULL, /* Truncate function, NULL'able */ +}; + +/* + * Miscellaneous constants. + */ + +#define ERROR_LENGTH ((size_t) -1) + +/* + *------------------------------------------------------------------------- + * + * ReadLock, WriteLock, Unlock -- + * + * POSIX like rwlock functions to support multiple readers and single + * writer on internal structs. + * + * Limitations: + * - a read lock cannot be promoted to a write lock + * - a write lock may not be nested + * + *------------------------------------------------------------------------- + */ + +TCL_DECLARE_MUTEX(ZipFSMutex) + +#if TCL_THREADS + +static Tcl_Condition ZipFSCond; + +static void +ReadLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock < 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock++; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +WriteLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock != 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock = -1; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +Unlock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + if (ZipFS.lock > 0) { + --ZipFS.lock; + } else if (ZipFS.lock < 0) { + ZipFS.lock = 0; + } + if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { + Tcl_ConditionNotify(&ZipFSCond); + } + Tcl_MutexUnlock(&ZipFSMutex); +} + +#else /* !TCL_THREADS */ +#define ReadLock() do {} while (0) +#define WriteLock() do {} while (0) +#define Unlock() do {} while (0) +#endif /* TCL_THREADS */ + +/* + *------------------------------------------------------------------------- + * + * DosTimeDate, ToDosTime, ToDosDate -- + * + * Functions to perform conversions between DOS time stamps and POSIX + * time_t. + * + *------------------------------------------------------------------------- + */ + +static time_t +DosTimeDate( + int dosDate, + int dosTime) +{ + struct tm tm; + time_t ret; + + memset(&tm, 0, sizeof(struct tm)); + tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80; + tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; + tm.tm_mday = dosDate & 0x1f; + tm.tm_hour = (dosTime & 0xf800) >> 11; + tm.tm_min = (dosTime & 0x7e) >> 5; + tm.tm_sec = (dosTime & 0x1f) << 1; + ret = mktime(&tm); + if (ret == (time_t) -1) { + /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ + ret = (time_t) 315532800; + } + return ret; +} + +static int +ToDosTime( + time_t when) +{ + struct tm *tmp, tm; + +#if !TCL_THREADS || defined(_WIN32) + /* Not threaded, or on Win32 which uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#elif defined(HAVE_LOCALTIME_R) + /* Threaded, have reentrant API */ + tmp = &tm; + localtime_r(&when, tmp); +#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ + /* Only using a mutex is safe. */ + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif + return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); +} + +static int +ToDosDate( + time_t when) +{ + struct tm *tmp, tm; + +#if !TCL_THREADS || defined(_WIN32) + /* Not threaded, or on Win32 which uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R) + /* Threaded, have reentrant API */ + tmp = &tm; + localtime_r(&when, tmp); +#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ + /* Only using a mutex is safe. */ + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif + return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; +} + +/* + *------------------------------------------------------------------------- + * + * CountSlashes -- + * + * This function counts the number of slashes in a pathname string. + * + * Results: + * Number of slashes found in string. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +CountSlashes( + const char *string) +{ + int count = 0; + const char *p = string; + + while (*p != '\0') { + if (*p == '/') { + count++; + } + p++; + } + return count; +} + +/* + *------------------------------------------------------------------------- + * + * CanonicalPath -- + * + * This function computes the canonical path from a directory and file + * name components into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the canonical path contained in the specified + * Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +CanonicalPath( + const char *root, + const char *tail, + Tcl_DString *dsPtr, + int inZipfs) +{ + char *path; + int i, j, c, isUNC = 0, isVfs = 0, n = 0; + int haveZipfsPath = 1; + +#ifdef _WIN32 + if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') { + tail += 2; + haveZipfsPath = 0; + } + /* UNC style path */ + if (tail[0] == '\\') { + root = ""; + ++tail; + haveZipfsPath = 0; + } + if (tail[0] == '\\') { + root = "/"; + ++tail; + haveZipfsPath = 0; + } +#endif /* _WIN32 */ + + if (haveZipfsPath) { + /* UNC style path */ + if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { + isVfs = 1; + } else if (tail && + strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { + isVfs = 2; + } + if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) { + isUNC = 1; + } + } + + if (isVfs != 2) { + if (tail[0] == '/') { + if (isVfs != 1) { + root = ""; + } + ++tail; + isUNC = 0; + } + if (tail[0] == '/') { + if (isVfs != 1) { + root = "/"; + } + ++tail; + isUNC = 1; + } + } + i = strlen(root); + j = strlen(tail); + + switch (isVfs) { + case 1: + if (i > ZIPFS_VOLUME_LEN) { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + memcpy(path + i, tail, j); + } + break; + case 2: + Tcl_DStringSetLength(dsPtr, j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, tail, j); + break; + default: + if (inZipfs) { + Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); + path = Tcl_DStringValue(dsPtr); + memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); + memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } + break; + } + +#ifdef _WIN32 + for (i = 0; path[i] != '\0'; i++) { + if (path[i] == '\\') { + path[i] = '/'; + } + } +#endif /* _WIN32 */ + + if (inZipfs) { + n = ZIPFS_VOLUME_LEN; + } else { + n = 0; + } + + for (i = j = n; (c = path[i]) != '\0'; i++) { + if (c == '/') { + int c2 = path[i + 1]; + + if (c2 == '\0' || c2 == '/') { + continue; + } + if (c2 == '.') { + int c3 = path[i + 2]; + + if ((c3 == '/') || (c3 == '\0')) { + i++; + continue; + } + if ((c3 == '.') + && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) { + i += 2; + while ((j > 0) && (path[j - 1] != '/')) { + j--; + } + if (j > isUNC) { + --j; + while ((j > 1 + isUNC) && (path[j - 2] == '/')) { + j--; + } + } + continue; + } + } + } + path[j++] = c; + } + if (j == 0) { + path[j++] = '/'; + } + path[j] = 0; + Tcl_DStringSetLength(dsPtr, j); + return Tcl_DStringValue(dsPtr); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookup -- + * + * This function returns the ZIP entry struct corresponding to the ZIP + * archive member of the given file name. Caller must hold the right + * lock. + * + * Results: + * Returns the pointer to ZIP entry struct or NULL if the the given file + * name could not be found in the global list of ZIP archive members. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static ZipEntry * +ZipFSLookup( + char *filename) +{ + Tcl_HashEntry *hPtr; + ZipEntry *z = NULL; + + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); + if (hPtr) { + z = Tcl_GetHashValue(hPtr); + } + return z; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookupMount -- + * + * This function returns an indication if the given file name corresponds + * to a mounted ZIP archive file. + * + * Results: + * Returns true, if the given file name is a mounted ZIP archive file. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +#ifdef NEVER_USED +static int +ZipFSLookupMount( + char *filename) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (strcmp(zf->mountPoint, filename) == 0) { + return 1; + } + } + return 0; +} +#endif /* NEVER_USED */ + +/* + *------------------------------------------------------------------------- + * + * ZipFSCloseArchive -- + * + * This function closes a mounted ZIP archive file. + * + * Results: + * None. + * + * Side effects: + * A memory mapped ZIP archive is unmapped, allocated memory is released. + * The ZipFile pointer is *NOT* deallocated by this function. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSCloseArchive( + Tcl_Interp *interp, /* Current interpreter. */ + ZipFile *zf) +{ + if (zf->nameLength) { + ckfree(zf->name); + } + if (zf->isMemBuffer) { + /* Pointer to memory */ + if (zf->ptrToFree) { + ckfree(zf->ptrToFree); + zf->ptrToFree = NULL; + } + zf->data = NULL; + return; + } + +#ifdef _WIN32 + if (zf->data && !zf->ptrToFree) { + UnmapViewOfFile(zf->data); + zf->data = NULL; + } + if (zf->mountHandle != INVALID_HANDLE_VALUE) { + CloseHandle(zf->mountHandle); + } +#else /* !_WIN32 */ + if ((zf->data != MAP_FAILED) && !zf->ptrToFree) { + munmap(zf->data, zf->length); + zf->data = MAP_FAILED; + } +#endif /* _WIN32 */ + + if (zf->ptrToFree) { + ckfree(zf->ptrToFree); + zf->ptrToFree = NULL; + } + if (zf->chan) { + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFindTOC -- + * + * This function takes a memory mapped zip file and indexes the contents. + * When "needZip" is zero an embedded ZIP archive in an executable file + * is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * The given ZipFile struct is filled with information about the ZIP + * archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFindTOC( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + int needZip, + ZipFile *zf) +{ + size_t i; + unsigned char *p, *q; + + p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (p >= zf->data) { + if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { + break; + } + p -= ZIP_SIG_LEN; + } else { + --p; + } + } + if (p < zf->data) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "wrong end signature"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); + } + goto error; + } + zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); + if (zf->numFiles == 0) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "empty archive"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + } + goto error; + } + q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < zf->data) || (p > zf->data + zf->length) + || (q < zf->data) || (q > zf->data + zf->length)) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "archive directory not found"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); + } + goto error; + } + zf->baseOffset = zf->passOffset = p - q; + zf->directoryOffset = p - zf->data; + q = p; + for (i = 0; i < zf->numFiles; i++) { + int pathlen, comlen, extra; + + if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { + ZIPFS_ERROR(interp, "wrong header length"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); + } + goto error; + } + if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { + ZIPFS_ERROR(interp, "wrong header signature"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); + } + goto error; + } + pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + q = zf->data + zf->baseOffset; + if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { + i = q[-5]; + if (q - 5 - i > zf->data) { + zf->passBuf[0] = i; + memcpy(zf->passBuf + 1, q - 5 - i, i); + zf->passOffset -= i ? (5 + i) : 0; + } + } + return TCL_OK; + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenArchive -- + * + * This function opens a ZIP archive file for reading. An attempt is made + * to memory map that file. Otherwise it is read into an allocated memory + * buffer. The ZIP archive header is verified and must be valid for the + * function to succeed. When "needZip" is zero an embedded ZIP archive in + * an executable file is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * ZIP archive is memory mapped or read into allocated memory, the given + * ZipFile struct is filled with information about the ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSOpenArchive( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *zipname, /* Path to ZIP file to open. */ + int needZip, + ZipFile *zf) +{ + size_t i; + ClientData handle; + + zf->nameLength = 0; + zf->isMemBuffer = 0; +#ifdef _WIN32 + zf->data = NULL; + zf->mountHandle = INVALID_HANDLE_VALUE; +#else /* !_WIN32 */ + zf->data = MAP_FAILED; +#endif /* _WIN32 */ + zf->length = 0; + zf->numFiles = 0; + zf->baseOffset = zf->passOffset = 0; + zf->ptrToFree = NULL; + zf->passBuf[0] = 0; + zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); + if (!zf->chan) { + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); + if (zf->length == ERROR_LENGTH) { + ZIPFS_POSIX_ERROR(interp, "seek error"); + goto error; + } + if ((zf->length - ZIP_CENTRAL_END_LEN) + > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { + ZIPFS_ERROR(interp, "illegal file size"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); + } + goto error; + } + if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) { + ZIPFS_POSIX_ERROR(interp, "seek error"); + goto error; + } + zf->ptrToFree = zf->data = attemptckalloc(zf->length); + if (!zf->ptrToFree) { + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + ZIPFS_POSIX_ERROR(interp, "file read error"); + goto error; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } else { +#ifdef _WIN32 + int readSuccessful; +# ifdef _WIN64 + i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); + readSuccessful = (i != 0); +# else /* !_WIN64 */ + zf->length = GetFileSize((HANDLE) handle, 0); + readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); +# endif /* _WIN64 */ + if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + goto error; + } + zf->mountHandle = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, + 0, zf->length, 0); + if (zf->mountHandle == INVALID_HANDLE_VALUE) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } + zf->data = MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, + zf->length); + if (!zf->data) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } +#else /* !_WIN32 */ + zf->length = lseek(PTR2INT(handle), 0, SEEK_END); + if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + goto error; + } + lseek(PTR2INT(handle), 0, SEEK_SET); + zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, + MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0); + if (zf->data == MAP_FAILED) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } +#endif /* _WIN32 */ + } + return ZipFSFindTOC(interp, needZip, zf); + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootNode -- + * + * This function generates the root node for a ZIPFS filesystem. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * ... + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCatalogFilesystem( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + ZipFile *zf0, + const char *mountPoint, /* Mount point path. */ + const char *passwd, /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ + const char *zipname) /* Path to ZIP file to build a catalog of. */ +{ + int pwlen, isNew; + size_t i; + ZipFile *zf; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, dsm, fpBuf; + unsigned char *q; + + /* + * Basic verification of the password for sanity. + */ + + pwlen = 0; + if (passwd) { + pwlen = strlen(passwd); + if ((pwlen > 255) || strchr(passwd, 0xff)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + } + return TCL_ERROR; + } + } + + WriteLock(); + + /* + * Mount point sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringInit(&dsm); + if (strcmp(mountPoint, "/") == 0) { + mountPoint = ""; + } else { + mountPoint = CanonicalPath("", mountPoint, &dsm, 1); + } + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); + if (!isNew) { + if (interp) { + zf = Tcl_GetHashValue(hPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s is already mounted on %s", zf->name, mountPoint)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + Unlock(); + + *zf = *zf0; + zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + zf->mountPointLen = strlen(zf->mountPoint); + zf->nameLength = strlen(zipname); + zf->name = ckalloc(zf->nameLength + 1); + memcpy(zf->name, zipname, zf->nameLength + 1); + zf->entries = NULL; + zf->topEnts = NULL; + zf->numOpen = 0; + Tcl_SetHashValue(hPtr, zf); + if ((zf->passBuf[0] == 0) && pwlen) { + int k = 0; + + zf->passBuf[k++] = pwlen; + for (i = pwlen; i-- > 0 ;) { + zf->passBuf[k++] = (passwd[i] & 0x0f) + | pwrot[(passwd[i] >> 4) & 0x0f]; + } + zf->passBuf[k] = '\0'; + } + if (mountPoint[0] != '\0') { + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); + if (isNew) { + z = ckalloc(sizeof(ZipEntry)); + Tcl_SetHashValue(hPtr, z); + + z->tnext = NULL; + z->depth = CountSlashes(mountPoint); + z->zipFilePtr = zf; + z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */ + z->isEncrypted = 0; + z->offset = zf->baseOffset; + z->crc32 = 0; + z->timestamp = 0; + z->numBytes = z->numCompressedBytes = 0; + z->compressMethod = ZIP_COMPMETH_STORED; + z->data = NULL; + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + } + } + q = zf->data + zf->directoryOffset; + Tcl_DStringInit(&fpBuf); + for (i = 0; i < zf->numFiles; i++) { + int extra, isdir = 0, dosTime, dosDate, nbcompr; + size_t offs, pathlen, comlen; + unsigned char *lq, *gq = NULL; + char *fullpath, *path; + + pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); + path = Tcl_DStringValue(&ds); + if ((pathlen > 0) && (path[pathlen - 1] == '/')) { + Tcl_DStringSetLength(&ds, pathlen - 1); + path = Tcl_DStringValue(&ds); + isdir = 1; + } + if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { + goto nextent; + } + lq = zf->data + zf->baseOffset + + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < zf->data) || (lq > zf->data + zf->length)) { + goto nextent; + } + nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); + if (!isdir && (nbcompr == 0) + && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) + && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + gq = q; + nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); + } + offs = (lq - zf->data) + + ZIP_LOCAL_HEADER_LEN + + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) + + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); + if (offs + nbcompr > zf->length) { + goto nextent; + } + if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { +#ifdef ANDROID + /* + * When mounting the ZIP archive on the root directory try to + * remap top level regular files of the archive to + * /assets/.root/... since this directory should not be in a valid + * APK due to the leading dot in the file name component. This + * trick should make the files AndroidManifest.xml, + * resources.arsc, and classes.dex visible to Tcl. + */ + Tcl_DString ds2; + + Tcl_DStringInit(&ds2); + Tcl_DStringAppend(&ds2, "assets/.root/", -1); + Tcl_DStringAppend(&ds2, path, -1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); + if (hPtr) { + /* should not happen but skip it anyway */ + Tcl_DStringFree(&ds2); + goto nextent; + } + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), + Tcl_DStringLength(&ds2)); + path = Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds2); +#else /* !ANDROID */ + /* + * Regular files skipped when mounting on root. + */ + goto nextent; +#endif /* ANDROID */ + } + Tcl_DStringSetLength(&fpBuf, 0); + fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); + z = ckalloc(sizeof(ZipEntry)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(fullpath); + z->zipFilePtr = zf; + z->isDirectory = isdir; + z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + && (nbcompr > 12); + z->offset = offs; + if (gq) { + z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); + } else { + z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS); + } + z->numCompressedBytes = nbcompr; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + ckfree(z); + } else { + Tcl_SetHashValue(hPtr, z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topEnts; + zf->topEnts = z; + } + if (!z->isDirectory && (z->depth > 1)) { + char *dir, *end; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + for (end = strrchr(dir, '/'); end && (end != dir); + end = strrchr(dir, '/')) { + Tcl_DStringSetLength(&ds, end - dir); + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + break; + } + zd = ckalloc(sizeof(ZipEntry)); + zd->name = NULL; + zd->tnext = NULL; + zd->depth = CountSlashes(dir); + zd->zipFilePtr = zf; + zd->isDirectory = 1; + zd->isEncrypted = 0; + zd->offset = z->offset; + zd->crc32 = 0; + zd->timestamp = z->timestamp; + zd->numBytes = zd->numCompressedBytes = 0; + zd->compressMethod = ZIP_COMPMETH_STORED; + zd->data = NULL; + Tcl_SetHashValue(hPtr, zd); + zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mountPoint[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topEnts; + zf->topEnts = zd; + } + } + } + } + nextent: + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_FSMountsChanged(NULL); + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipfsSetup -- + * + * Common initialisation code. ZipFS.initialized must *not* be set prior + * to the call. + * + *------------------------------------------------------------------------- + */ + +static void +ZipfsSetup(void) +{ +#if TCL_THREADS + static const Tcl_Time t = { 0, 0 }; + + /* + * Inflate condition variable. + */ + + Tcl_MutexLock(&ZipFSMutex); + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); + Tcl_MutexUnlock(&ZipFSMutex); +#endif /* TCL_THREADS */ + + Tcl_FSRegister(NULL, &zipfsFilesystem); + Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); + ZipFS.idCount = 1; + ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.initialized = 1; +} + +/* + *------------------------------------------------------------------------- + * + * ListMountPoints -- + * + * This procedure lists the mount points and what's mounted there, or + * reports whether there are any mounts (if there's no interpreter). The + * read lock must be held by the caller. + * + * Results: + * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no + * interpreter). + * + * Side effects: + * Interpreter result may be updated. + * + *------------------------------------------------------------------------- + */ + +static inline int +ListMountPoints( + Tcl_Interp *interp) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + if (!interp) { + return TCL_OK; + } + zf = Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, zf->mountPoint); + Tcl_AppendElement(interp, zf->name); + } + return (interp ? TCL_OK : TCL_BREAK); +} + +/* + *------------------------------------------------------------------------- + * + * DescribeMounted -- + * + * This procedure describes what is mounted at the given the mount point. + * The interpreter result is not updated if there is nothing mounted at + * the given point. The read lock must be held by the caller. + * + * Results: + * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there + * and no interpreter). + * + * Side effects: + * Interpreter result may be updated. + * + *------------------------------------------------------------------------- + */ + +static inline int +DescribeMounted( + Tcl_Interp *interp, + const char *mountPoint) +{ + Tcl_HashEntry *hPtr; + ZipFile *zf; + + if (interp) { + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + if (hPtr) { + zf = Tcl_GetHashValue(hPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1)); + return TCL_OK; + } + } + return (interp ? TCL_OK : TCL_BREAK); +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount -- + * + * This procedure is invoked to mount a given ZIP archive file on a given + * mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + const char *zipname, /* Path to ZIP file to mount. */ + const char *passwd) /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ +{ + ZipFile *zf; + + ReadLock(); + if (!ZipFS.initialized) { + ZipfsSetup(); + } + + /* + * No mount point, so list all mount points and what is mounted there. + */ + + if (!mountPoint) { + int ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + /* + * Mount point but no file, so describe what is mounted at that mount + * point. + */ + + if (!zipname) { + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + Unlock(); + + /* + * Have both a mount point and a file (name) to mount there. + */ + + if (passwd) { + if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + } + return TCL_ERROR; + } + } + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { + return TCL_ERROR; + } + return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname); +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_MountBuffer -- + * + * This procedure is invoked to mount a given ZIP archive file on a given + * mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_MountBuffer( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + unsigned char *data, + size_t datalen, + int copy) +{ + ZipFile *zf; + + ReadLock(); + if (!ZipFS.initialized) { + ZipfsSetup(); + } + + /* + * No mount point, so list all mount points and what is mounted there. + */ + + if (!mountPoint) { + int ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + /* + * Mount point but no data, so describe what is mounted at that mount + * point. + */ + + if (!data) { + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + Unlock(); + + /* + * Have both a mount point and data to mount there. + */ + + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + zf->isMemBuffer = 1; + zf->length = datalen; + if (copy) { + zf->data = attemptckalloc(datalen); + if (!zf->data) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + memcpy(zf->data, data, datalen); + zf->ptrToFree = zf->data; + } else { + zf->data = data; + zf->ptrToFree = NULL; + } + if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { + return TCL_ERROR; + } + return ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, + "Memory Buffer"); +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Unmount -- + * + * This procedure is invoked to unmount a given ZIP archive. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Unmount( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint) /* Mount point path. */ +{ + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + Tcl_DString dsm; + int ret = TCL_OK, unmounted = 0; + + WriteLock(); + if (!ZipFS.initialized) { + goto done; + } + + /* + * Mount point sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + + Tcl_DStringInit(&dsm); + mountPoint = CanonicalPath("", mountPoint, &dsm, 1); + + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + /* don't report no-such-mount as an error */ + if (!hPtr) { + goto done; + } + + zf = Tcl_GetHashValue(hPtr); + if (zf->numOpen > 0) { + ZIPFS_ERROR(interp, "filesystem is busy"); + ret = TCL_ERROR; + goto done; + } + Tcl_DeleteHashEntry(hPtr); + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data) { + ckfree(z->data); + } + ckfree(z); + } + ZipFSCloseArchive(interp, zf); + ckfree(zf); + unmounted = 1; + done: + Unlock(); + if (unmounted) { + Tcl_FSMountsChanged(NULL); + } + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountObjCmd -- + * + * This procedure is invoked to process the [zipfs mount] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?mountpoint? ?zipfile? ?password?"); + return TCL_ERROR; + } + + return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, + (objc > 2) ? Tcl_GetString(objv[2]) : NULL, + (objc > 3) ? Tcl_GetString(objv[3]) : NULL); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountBufferObjCmd -- + * + * This procedure is invoked to process the [zipfs mount_data] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountBufferObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *mountPoint; /* Mount point path. */ + unsigned char *data; + int length; + + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); + return TCL_ERROR; + } + if (objc < 2) { + int ret; + + ReadLock(); + ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + mountPoint = Tcl_GetString(objv[1]); + if (objc < 3) { + ReadLock(); + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + + data = Tcl_GetByteArrayFromObj(objv[2], &length); + return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootObjCmd -- + * + * This procedure is invoked to process the [zipfs root] command. It + * returns the root that all zipfs file systems are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSRootObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSUnmountObjCmd -- + * + * This procedure is invoked to process the [zipfs unmount] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSUnmountObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); + return TCL_ERROR; + } + return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkKeyObjCmd -- + * + * This procedure is invoked to process the [zipfs mkkey] command. It + * produces a rotated password to be embedded into an image file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkKeyObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int len, i = 0; + char *pw, passBuf[264]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "password"); + return TCL_ERROR; + } + pw = Tcl_GetString(objv[1]); + len = strlen(pw); + if (len == 0) { + return TCL_OK; + } + if ((len > 255) || strchr(pw, 0xff)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + while (len > 0) { + int ch = pw[len - 1]; + + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + passBuf[i] = i; + ++i; + passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + passBuf[i] = '\0'; + Tcl_AppendResult(interp, passBuf, (char *) NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipAddFile -- + * + * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to + * the output ZIP archive file being written. A ZipEntry struct about the + * input file is added to the given fileHash table for later creation of + * the central ZIP directory. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Input file is read and (compressed and) written to the output ZIP + * archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipAddFile( + Tcl_Interp *interp, /* Current interpreter. */ + const char *path, + const char *name, + Tcl_Channel out, + const char *passwd, /* Password for encoding the file, or NULL if + * the file is to be unprotected. */ + char *buf, + int bufsize, + Tcl_HashTable *fileHash) +{ + Tcl_Channel in; + Tcl_HashEntry *hPtr; + ZipEntry *z; + z_stream stream; + const char *zpath; + int crc, flush, zpathlen; + size_t nbyte, nbytecompr, len, olen, align = 0; + Tcl_WideInt pos[3]; + int mtime = 0, isNew, compMeth; + unsigned long keys[3], keys0[3]; + char obuf[4096]; + + /* + * Trim leading '/' characters. If this results in an empty string, we've + * nothing to do. + */ + + zpath = name; + while (zpath && zpath[0] == '/') { + zpath++; + } + if (!zpath || (zpath[0] == '\0')) { + return TCL_OK; + } + + zpathlen = strlen(zpath); + if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "path too long for \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); + return TCL_ERROR; + } + in = Tcl_OpenFileChannel(interp, path, "rb", 0); + if (!in) { +#ifdef _WIN32 + /* hopefully a directory */ + if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } +#endif /* _WIN32 */ + Tcl_Close(interp, in); + return TCL_ERROR; + } else { + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_StatBuf statBuf; + + Tcl_IncrRefCount(pathObj); + if (Tcl_FSStat(pathObj, &statBuf) != -1) { + mtime = statBuf.st_mtime; + } + Tcl_DecrRefCount(pathObj); + } + Tcl_ResetResult(interp); + crc = 0; + nbyte = nbytecompr = 0; + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + if (nbyte == 0 && errno == EISDIR) { + Tcl_Close(interp, in); + return TCL_OK; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if (len == 0) { + break; + } + crc = crc32(crc, (unsigned char *) buf, len); + nbyte += len; + } + if (Tcl_Seek(in, 0, SEEK_SET) == -1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + pos[0] = Tcl_Tell(out); + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + len = zpathlen + ZIP_LOCAL_HEADER_LEN; + if ((size_t) Tcl_Write(out, buf, len) != len) { + wrerr: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error on %s: %s", path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if ((len + pos[0]) & 3) { + unsigned char abuf[8]; + + /* + * Align payload to next 4-byte boundary using a dummy extra entry + * similar to the zipalign tool from Android's SDK. + */ + + align = 4 + ((len + pos[0]) & 3); + ZipWriteShort(abuf, 0xffff); + ZipWriteShort(abuf + 2, align - 4); + ZipWriteInt(abuf + 4, 0x03020100); + if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { + goto wrerr; + } + } + if (passwd) { + int i, ch, tmp; + unsigned char kvbuf[24]; + Tcl_Obj *ret; + + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + double r; + + if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { + Tcl_Obj *eiPtr = Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + i); + + Tcl_AppendObjToErrorInfo(interp, eiPtr); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { + Tcl_Obj *eiPtr = Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + i); + + Tcl_AppendObjToErrorInfo(interp, eiPtr); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ch = (int) (r * 256); + kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); + } + Tcl_ResetResult(interp); + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + kvbuf[i] = (unsigned char) + zencode(keys, crc32tab, kvbuf[i + 12], tmp); + } + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); + len = Tcl_Write(out, (char *) kvbuf, 12); + memset(kvbuf, 0, 24); + if (len != 12) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error on %s: %s", path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + memcpy(keys0, keys, sizeof(keys0)); + nbytecompr += 12; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + compMeth = ZIP_COMPMETH_DEFLATED; + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, + Z_DEFAULT_STRATEGY) != Z_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "compression init error on \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + do { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read error on %s: %s", path, Tcl_PosixError(interp))); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + stream.avail_in = len; + stream.next_in = (unsigned char *) buf; + flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; + do { + stream.avail_out = sizeof(obuf); + stream.next_out = (unsigned char *) obuf; + len = deflate(&stream, flush); + if (len == (size_t) Z_STREAM_ERROR) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "deflate error on %s", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + olen = sizeof(obuf) - stream.avail_out; + if (passwd) { + size_t i; + int tmp; + + for (i = 0; i < olen; i++) { + obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); + } + } + if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += olen; + } while (stream.avail_out == 0); + } while (flush != Z_FINISH); + deflateEnd(&stream); + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { + /* + * Compressed file larger than input, write it again uncompressed. + */ + if (Tcl_Seek(in, 0, SEEK_SET) != 0) { + goto seekErr; + } + if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { + seekErr: + Tcl_Close(interp, in); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + nbytecompr = (passwd ? 12 : 0); + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } else if (len == 0) { + break; + } + if (passwd) { + size_t i; + int tmp; + + for (i = 0; i < len; i++) { + buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); + } + } + if ((size_t) Tcl_Write(out, buf, len) != len) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += len; + } + compMeth = ZIP_COMPMETH_STORED; + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + Tcl_TruncateChannel(out, pos[1]); + } + Tcl_Close(interp, in); + + hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "non-unique path name \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL); + return TCL_ERROR; + } + + z = ckalloc(sizeof(ZipEntry)); + Tcl_SetHashValue(hPtr, z); + z->name = NULL; + z->tnext = NULL; + z->depth = 0; + z->zipFilePtr = NULL; + z->isDirectory = 0; + z->isEncrypted = (passwd ? 1 : 0); + z->offset = pos[0]; + z->crc32 = crc; + z->timestamp = mtime; + z->numBytes = nbyte; + z->numCompressedBytes = nbytecompr; + z->compressMethod = compMeth; + z->data = NULL; + z->name = Tcl_GetHashKey(fileHash, hPtr); + z->next = NULL; + + /* + * Write final local header information. + */ + ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod); + ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); + ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); + ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes); + ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); + ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); + if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_Flush(out); + if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImgObjCmd -- + * + * This procedure is creates a new ZIP archive file or image file given + * output filename, input directory of files to be archived, optional + * password, and optional image to be prepended to the output ZIP archive + * file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new ZIP archive file or image file is written. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipOrImgObjCmd( + Tcl_Interp *interp, /* Current interpreter. */ + int isImg, + int isList, + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel out; + int pwlen = 0, count, ret = TCL_ERROR, lobjc; + size_t len, slen = 0, i = 0; + Tcl_WideInt pos[3]; + Tcl_Obj **lobjv, *list = NULL; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; + + /* + * Caller has verified that the number of arguments is correct. + */ + + passBuf[0] = 0; + if (objc > (isList ? 3 : 4)) { + pw = Tcl_GetString(objv[isList ? 3 : 4]); + pwlen = strlen(pw); + if ((pwlen > 255) || strchr(pw, 0xff)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + return TCL_ERROR; + } + } + if (isList) { + list = objv[2]; + Tcl_IncrRefCount(list); + } else { + Tcl_Obj *cmd[3]; + + cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); + cmd[2] = objv[2]; + cmd[0] = Tcl_NewListObj(2, cmd + 1); + Tcl_IncrRefCount(cmd[0]); + if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { + Tcl_DecrRefCount(cmd[0]); + return TCL_ERROR; + } + Tcl_DecrRefCount(cmd[0]); + list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + } + if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (isList && (lobjc % 2)) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("need even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); + return TCL_ERROR; + } + if (lobjc == 0) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + return TCL_ERROR; + } + out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + if (out == NULL) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (pwlen <= 0) { + pw = NULL; + pwlen = 0; + } + if (isImg) { + ZipFile *zf, zf0; + int isMounted = 0; + const char *imgName; + + if (isList) { + imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + Tcl_GetNameOfExecutable(); + } else { + imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + Tcl_GetNameOfExecutable(); + } + if (pwlen) { + i = 0; + for (len = pwlen; len-- > 0;) { + int ch = pw[len]; + + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + } + passBuf[i] = i; + ++i; + passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + passBuf[i] = '\0'; + } + + /* + * Check for mounted image. + */ + + WriteLock(); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + zf = Tcl_GetHashValue(hPtr); + if (strcmp(zf->name, imgName) == 0) { + isMounted = 1; + zf->numOpen++; + break; + } + } + Unlock(); + if (!isMounted) { + zf = &zf0; + } + if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) { + if ((size_t) Tcl_Write(out, (char *) zf->data, + zf->passOffset) != zf->passOffset) { + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, out); + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->numOpen--; + Unlock(); + } + return TCL_ERROR; + } + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->numOpen--; + Unlock(); + } + } else { + size_t k; + int m, n; + Tcl_Channel in; + const char *errMsg = "seek error"; + + /* + * Fall back to read it as plain file which hopefully is a static + * tclsh or wish binary with proper zipfs infrastructure built in. + */ + + Tcl_ResetResult(interp); + in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); + if (!in) { + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + i = Tcl_Seek(in, 0, SEEK_END); + if (i == ERROR_LENGTH) { + cperr: + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: %s", errMsg, Tcl_PosixError(interp))); + Tcl_Close(interp, out); + Tcl_Close(interp, in); + return TCL_ERROR; + } + Tcl_Seek(in, 0, SEEK_SET); + for (k = 0; k < i; k += m) { + m = i - k; + if (m > (int) sizeof(buf)) { + m = (int) sizeof(buf); + } + n = Tcl_Read(in, buf, m); + if (n == -1) { + errMsg = "read error"; + goto cperr; + } else if (n == 0) { + break; + } + m = Tcl_Write(out, buf, n); + if (m != n) { + errMsg = "write error"; + goto cperr; + } + } + Tcl_Close(interp, in); + } + len = strlen(passBuf); + if (len > 0) { + i = Tcl_Write(out, passBuf, len); + if (i != len) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, out); + return TCL_ERROR; + } + } + memset(passBuf, 0, sizeof(passBuf)); + Tcl_Flush(out); + } + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); + pos[0] = Tcl_Tell(out); + if (!isList && (objc > 3)) { + strip = Tcl_GetString(objv[3]); + slen = strlen(strip); + } + for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), + &fileHash) != TCL_OK) { + goto done; + } + } + pos[1] = Tcl_Tell(out); + count = 0; + for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + hPtr = Tcl_FindHashEntry(&fileHash, name); + if (!hPtr) { + continue; + } + z = Tcl_GetHashValue(hPtr); + len = strlen(z->name); + ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); + ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod); + ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); + ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); + ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes); + ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); + ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0); + ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0); + ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); + if ((Tcl_Write(out, buf, + ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) + || ((size_t) Tcl_Write(out, z->name, len) != len)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + goto done; + } + count++; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); + ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); + ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); + ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); + ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); + ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + goto done; + } + Tcl_Flush(out); + ret = TCL_OK; + + done: + if (ret == TCL_OK) { + ret = Tcl_Close(interp, out); + } else { + Tcl_Close(interp, out); + } + Tcl_DecrRefCount(list); + for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + z = Tcl_GetHashValue(hPtr); + ckfree(z); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&fileHash); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- + * + * These procedures are invoked to process the [zipfs mkzip] and [zipfs + * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv); +} + +static int +ZipFSLMkZipObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- + * + * These procedures are invoked to process the [zipfs mkimg] and [zipfs + * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkImgObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "outfile indir ?strip? ?password? ?infile?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv); +} + +static int +ZipFSLMkImgObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSCanonicalObjCmd -- + * + * This procedure is invoked to process the [zipfs canonical] command. + * It returns the canonical name for a file within zipfs + * + * Results: + * Always TCL_OK provided the right number of arguments are supplied. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCanonicalObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *mntpoint = NULL; + char *filename = NULL; + char *result; + Tcl_DString dPath; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?"); + return TCL_ERROR; + } + Tcl_DStringInit(&dPath); + if (objc == 2) { + filename = Tcl_GetString(objv[1]); + result = CanonicalPath("", filename, &dPath, 1); + } else if (objc == 3) { + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result = CanonicalPath(mntpoint, filename, &dPath, 1); + } else { + int zipfs = 0; + + if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { + return TCL_ERROR; + } + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result = CanonicalPath(mntpoint, filename, &dPath, zipfs); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the [zipfs exists] command. It + * tests for the existence of a file in the ZIP filesystem and places a + * boolean into the interp's result. + * + * Results: + * Always TCL_OK provided the right number of arguments are supplied. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSExistsObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *filename; + int exists; + Tcl_DString ds; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + + /* + * Prepend ZIPFS_VOLUME to filename, eliding the final / + */ + + filename = Tcl_GetString(objv[1]); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1); + Tcl_DStringAppend(&ds, filename, -1); + filename = Tcl_DStringValue(&ds); + + ReadLock(); + exists = ZipFSLookup(filename) != NULL; + Unlock(); + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSInfoObjCmd -- + * + * This procedure is invoked to process the [zipfs info] command. On + * success, it returns a Tcl list made up of name of ZIP archive file, + * size uncompressed, size compressed, and archive offset of a file in + * the ZIP filesystem. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSInfoObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *filename; + ZipEntry *z; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetString(objv[1]); + ReadLock(); + z = ZipFSLookup(filename); + if (z) { + Tcl_Obj *result = Tcl_GetObjResult(interp); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->zipFilePtr->name, -1)); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewWideIntObj(z->numBytes)); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewWideIntObj(z->numCompressedBytes)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset)); + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListObjCmd -- + * + * This procedure is invoked to process the [zipfs list] command. On + * success, it returns a Tcl list of files of the ZIP filesystem which + * match a search pattern (glob or regexp). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *pattern = NULL; + Tcl_RegExp regexp = NULL; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *result = Tcl_GetObjResult(interp); + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); + return TCL_ERROR; + } + if (objc == 3) { + int n; + char *what = Tcl_GetStringFromObj(objv[1], &n); + + if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + pattern = Tcl_GetString(objv[2]); + } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + if (!regexp) { + return TCL_ERROR; + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown option \"%s\"", what)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL); + return TCL_ERROR; + } + } else if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + ReadLock(); + if (pattern) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if (Tcl_StringMatch(z->name, pattern)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else if (regexp) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_TclLibrary -- + * + * This procedure gets (and possibly finds) the root that Tcl's library + * files are mounted under. + * + * Results: + * A Tcl object holding the location (with zero refcount), or NULL if no + * Tcl library can be found. + * + * Side effects: + * May initialise the cache of where such library files are to be found. + * This cache is never cleared. + * + *------------------------------------------------------------------------- + */ + +#ifdef _WIN32 +#define LIBRARY_SIZE 64 + +static inline int +WCharToUtf( + const WCHAR *wSrc, + char *dst) +{ + char *start = dst; + + while (*wSrc != '\0') { + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + *dst = '\0'; + return (int) (dst - start); +} +#endif /* _WIN32 */ + +Tcl_Obj * +TclZipfs_TclLibrary(void) +{ + Tcl_Obj *vfsInitScript; + int found; +#ifdef _WIN32 + HMODULE hModule; + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; +#endif /* _WIN32 */ + + /* + * Use the cached value if that has been set; we don't want to repeat the + * searching and mounting. + */ + + if (zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + + /* + * Look for the library file system within the executable. + */ + + vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", + -1); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + + /* + * Look for the library file system within the DLL/shared library. Note + * that we must mount the zip file and dll before releasing to search. + */ + +#if defined(_WIN32) + hModule = TclWinGetTclInstance(); + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, dllName, MAX_PATH); + } else { + WCharToUtf(wName, dllName); + } + + if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE) + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */ + + /* + * If we're configured to know about a ZIP archive we should use, do that. + */ + +#ifdef CFG_RUNTIME_ZIPFILE + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#endif /* CFG_RUNTIME_ZIPFILE */ + + /* + * If anything set the cache (but subsequently failed) go with that + * anyway. + */ + + if (zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSTclLibraryObjCmd -- + * + * This procedure is invoked to process the + * [::tcl::zipfs::tcl_library_init] command, usually called during the + * execution of Tcl's interpreter startup. It returns the root that Tcl's + * library files are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May initialise the cache of where such library files are to be found. + * This cache is never cleared. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSTclLibraryObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (!Tcl_IsSafe(interp)) { + Tcl_Obj *pResult = TclZipfs_TclLibrary(); + + if (!pResult) { + pResult = Tcl_NewObj(); + } + Tcl_SetObjResult(interp, pResult); + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelClose -- + * + * This function is called to close a channel. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * Resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelClose( + ClientData instanceData, + Tcl_Interp *interp) /* Current interpreter. */ +{ + ZipChannel *info = instanceData; + + if (info->iscompr && info->ubuf) { + ckfree(info->ubuf); + info->ubuf = NULL; + } + if (info->isEncrypted) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + } + if (info->isWriting) { + ZipEntry *z = info->zipEntryPtr; + unsigned char *newdata = attemptckrealloc(info->ubuf, info->numRead); + + if (newdata) { + if (z->data) { + ckfree(z->data); + } + z->data = newdata; + z->numBytes = z->numCompressedBytes = info->numBytes; + z->compressMethod = ZIP_COMPMETH_STORED; + z->timestamp = time(NULL); + z->isDirectory = 0; + z->isEncrypted = 0; + z->offset = 0; + z->crc32 = 0; + } else { + ckfree(info->ubuf); + } + } + WriteLock(); + info->zipFilePtr->numOpen--; + Unlock(); + ckfree(info); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelRead -- + * + * This function is called to read data from channel. + * + * Results: + * Number of bytes read or -1 on error with error number set. + * + * Side effects: + * Data is read and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelRead( + ClientData instanceData, + char *buf, + int toRead, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (info->isDirectory < 0) { + /* + * Special case: when executable combined with ZIP archive file read + * data in front of ZIP, i.e. the executable itself. + */ + + nextpos = info->numRead + toRead; + if (nextpos > info->zipFilePtr->baseOffset) { + toRead = info->zipFilePtr->baseOffset - info->numRead; + nextpos = info->zipFilePtr->baseOffset; + } + if (toRead == 0) { + return 0; + } + memcpy(buf, info->zipFilePtr->data, toRead); + info->numRead = nextpos; + *errloc = 0; + return toRead; + } + if (info->isDirectory) { + *errloc = EISDIR; + return -1; + } + nextpos = info->numRead + toRead; + if (nextpos > info->numBytes) { + toRead = info->numBytes - info->numRead; + nextpos = info->numBytes; + } + if (toRead == 0) { + return 0; + } + if (info->isEncrypted) { + int i; + + for (i = 0; i < toRead; i++) { + int ch = info->ubuf[i + info->numRead]; + + buf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(buf, info->ubuf + info->numRead, toRead); + } + info->numRead = nextpos; + *errloc = 0; + return toRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWrite -- + * + * This function is called to write data into channel. + * + * Results: + * Number of bytes written or -1 on error with error number set. + * + * Side effects: + * Data is written and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelWrite( + ClientData instanceData, + const char *buf, + int toWrite, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (!info->isWriting) { + *errloc = EINVAL; + return -1; + } + nextpos = info->numRead + toWrite; + if (nextpos > info->maxWrite) { + toWrite = info->maxWrite - info->numRead; + nextpos = info->maxWrite; + } + if (toWrite == 0) { + return 0; + } + memcpy(info->ubuf + info->numRead, buf, toWrite); + info->numRead = nextpos; + if (info->numRead > info->numBytes) { + info->numBytes = info->numRead; + } + *errloc = 0; + return toWrite; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelSeek -- + * + * This function is called to position file pointer of channel. + * + * Results: + * New file position or -1 on error with error number set. + * + * Side effects: + * File pointer is repositioned according to offset and mode. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelSeek( + ClientData instanceData, + long offset, + int mode, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long end; + + if (!info->isWriting && (info->isDirectory < 0)) { + /* + * Special case: when executable combined with ZIP archive file, seek + * within front of ZIP, i.e. the executable itself. + */ + end = info->zipFilePtr->baseOffset; + } else if (info->isDirectory) { + *errloc = EINVAL; + return -1; + } else { + end = info->numBytes; + } + switch (mode) { + case SEEK_CUR: + offset += info->numRead; + break; + case SEEK_END: + offset += end; + break; + case SEEK_SET: + break; + default: + *errloc = EINVAL; + return -1; + } + if (offset < 0) { + *errloc = EINVAL; + return -1; + } + if (info->isWriting) { + if ((unsigned long) offset > info->maxWrite) { + *errloc = EINVAL; + return -1; + } + if ((unsigned long) offset > info->numBytes) { + info->numBytes = offset; + } + } else if ((unsigned long) offset > end) { + *errloc = EINVAL; + return -1; + } + info->numRead = (unsigned long) offset; + return info->numRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWatchChannel -- + * + * This function is called for event notifications on channel. Does + * nothing. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +ZipChannelWatchChannel( + ClientData instanceData, + int mask) +{ + return; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelGetFile -- + * + * This function is called to retrieve OS handle for channel. + * + * Results: + * Always TCL_ERROR since there's never an OS handle for a file within a + * ZIP archive. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelGetFile( + ClientData instanceData, + int direction, + ClientData *handlePtr) +{ + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelOpen -- + * + * This function opens a Tcl_Channel on a file from a mounted ZIP archive + * according to given open mode. + * + * Results: + * Tcl_Channel on success, or NULL on error. + * + * Side effects: + * Memory is allocated, the file from the ZIP archive is uncompressed. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipChannelOpen( + Tcl_Interp *interp, /* Current interpreter. */ + char *filename, + int mode, + int permissions) +{ + ZipEntry *z; + ZipChannel *info; + int i, ch, trunc, wr, flags = 0; + char cname[128]; + + if ((mode & O_APPEND) + || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported open mode", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); + } + return NULL; + } + WriteLock(); + z = ZipFSLookup(filename); + if (!z) { + Tcl_SetErrno(ENOENT); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file not found \"%s\": %s", filename, + Tcl_PosixError(interp))); + } + goto error; + } + trunc = (mode & O_TRUNC) != 0; + wr = (mode & (O_WRONLY | O_RDWR)) != 0; + if ((z->compressMethod != ZIP_COMPMETH_STORED) + && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { + ZIPFS_ERROR(interp, "unsupported compression method"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); + } + goto error; + } + if (wr && z->isDirectory) { + ZIPFS_ERROR(interp, "unsupported file type"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); + } + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { + ZIPFS_ERROR(interp, "decryption failed"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); + } + goto error; + } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { + ZIPFS_ERROR(interp, "file too large"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); + } + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = attemptckalloc(sizeof(ZipChannel)); + if (!info) { + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + info->zipFilePtr = z->zipFilePtr; + info->zipEntryPtr = z; + info->numRead = 0; + if (wr) { + flags |= TCL_WRITABLE; + info->isWriting = 1; + info->isDirectory = 0; + info->maxWrite = ZipFS.wrmax; + info->iscompr = 0; + info->isEncrypted = 0; + info->ubuf = attemptckalloc(info->maxWrite); + if (!info->ubuf) { + merror0: + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + memset(info->ubuf, 0, info->maxWrite); + if (trunc) { + info->numBytes = 0; + } else if (z->data) { + unsigned int j = z->numBytes; + + if (j > info->maxWrite) { + j = info->maxWrite; + } + memcpy(info->ubuf, z->data, j); + info->numBytes = j; + } else { + unsigned char *zbuf = z->zipFilePtr->data + z->offset; + + if (z->isEncrypted) { + int len = z->zipFilePtr->passBuf[0]; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + zbuf += i; + } + if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { + z_stream stream; + int err; + unsigned char *cbuf = NULL; + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (z->isEncrypted) { + unsigned int j; + + stream.avail_in -= 12; + cbuf = attemptckalloc(stream.avail_in); + if (!cbuf) { + goto merror0; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + cbuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = cbuf; + } else { + stream.next_in = zbuf; + } + stream.next_out = info->ubuf; + stream.avail_out = info->maxWrite; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror0; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) + || ((err == Z_OK) && (stream.avail_in == 0))) { + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + goto wrapchan; + } + cerror0: + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "decompression error"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + } + goto error; + } else if (z->isEncrypted) { + for (i = 0; i < z->numBytes - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(info->ubuf, zbuf, z->numBytes); + } + memset(info->keys, 0, sizeof(info->keys)); + goto wrapchan; + } + } else if (z->data) { + flags |= TCL_READABLE; + info->isWriting = 0; + info->iscompr = 0; + info->isDirectory = 0; + info->isEncrypted = 0; + info->numBytes = z->numBytes; + info->maxWrite = 0; + info->ubuf = z->data; + } else { + flags |= TCL_READABLE; + info->isWriting = 0; + info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); + info->ubuf = z->zipFilePtr->data + z->offset; + info->isDirectory = z->isDirectory; + info->isEncrypted = z->isEncrypted; + info->numBytes = z->numBytes; + info->maxWrite = 0; + if (info->isEncrypted) { + int len = z->zipFilePtr->passBuf[0]; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + if (info->iscompr) { + z_stream stream; + int err; + unsigned char *ubuf = NULL; + unsigned int j; + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (info->isEncrypted) { + stream.avail_in -= 12; + ubuf = attemptckalloc(stream.avail_in); + if (!ubuf) { + info->ubuf = NULL; + goto merror; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = attemptckalloc(info->numBytes); + if (!info->ubuf) { + merror: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + ckfree(info); + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + stream.avail_out = info->numBytes; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) + || ((err == Z_OK) && (stream.avail_in == 0))) { + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + goto wrapchan; + } + cerror: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "decompression error"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + } + goto error; + } + } + + wrapchan: + sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, + ZipFS.idCount++); + z->zipFilePtr->numOpen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + + error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryStat -- + * + * This function implements the ZIP filesystem specific version of the + * library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryStat( + char *path, + Tcl_StatBuf *buf) +{ + ZipEntry *z; + int ret = -1; + + ReadLock(); + z = ZipFSLookup(path); + if (z) { + memset(buf, 0, sizeof(Tcl_StatBuf)); + if (z->isDirectory) { + buf->st_mode = S_IFDIR | 0555; + } else { + buf->st_mode = S_IFREG | 0555; + } + buf->st_size = z->numBytes; + buf->st_mtime = z->timestamp; + buf->st_ctime = z->timestamp; + buf->st_atime = z->timestamp; + ret = 0; + } + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryAccess -- + * + * This function implements the ZIP filesystem specific version of the + * library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryAccess( + char *path, + int mode) +{ + ZipEntry *z; + + if (mode & 3) { + return -1; + } + ReadLock(); + z = ZipFSLookup(path); + Unlock(); + return (z ? 0 : -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenFileChannelProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipFSOpenFileChannelProc( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *pathPtr, + int mode, + int permissions) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return NULL; + } + return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, + permissions); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSStatProc -- + * + * This function implements the ZIP filesystem specific version of the + * library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSStatProc( + Tcl_Obj *pathPtr, + Tcl_StatBuf *buf) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSAccessProc -- + * + * This function implements the ZIP filesystem specific version of the + * library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSAccessProc( + Tcl_Obj *pathPtr, + int mode) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFilesystemSeparatorProc -- + * + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFilesystemSeparatorProc( + Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("/", -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMatchInDirectoryProc -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * lappend'ed to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMatchInDirectoryProc( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *result, + Tcl_Obj *pathPtr, + const char *pattern, + Tcl_GlobTypeData *types) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + int scnt, l, dirOnly = -1, prefixLen, strip = 0; + size_t len; + char *pat, *prefix, *path; + Tcl_DString dsPref; + + if (!normPathPtr) { + return -1; + } + if (types) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + + /* + * The prefix that gets prepended to results. + */ + + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + + /* + * The (normalized) path we're searching. + */ + + path = Tcl_GetString(normPathPtr); + len = normPathPtr->length; + + Tcl_DStringInit(&dsPref); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + + if (strcmp(prefix, path) == 0) { + prefix = NULL; + } else { + strip = len + 1; + } + if (prefix) { + Tcl_DStringAppend(&dsPref, "/", 1); + prefixLen++; + prefix = Tcl_DStringValue(&dsPref); + } + ReadLock(); + if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if (!pattern || (pattern[0] == '\0')) { + pattern = "*"; + } + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + for (z = zf->topEnts; z; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) + && (z->name[len] == '/') + && (CountSlashes(z->name) == l) + && Tcl_StringCaseMatch(z->name + len + 1, pattern, + 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name, lenz); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, lenz)); + } + } + } + } else if ((zf->mountPointLen > len + 1) + && (strncmp(zf->mountPoint, path, len) == 0) + && (zf->mountPoint[len] == '/') + && (CountSlashes(zf->mountPoint) == l) + && Tcl_StringCaseMatch(zf->mountPoint + len + 1, + pattern, 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, zf->mountPoint, + zf->mountPointLen); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(zf->mountPoint, + zf->mountPointLen)); + } + } + } + goto end; + } + + if (!pattern || (pattern[0] == '\0')) { + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) + || (dirOnly && z->isDirectory)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } + goto end; + } + + l = strlen(pattern); + pat = ckalloc(len + l + 2); + memcpy(pat, path, len); + while ((len > 1) && (pat[len - 1] == '/')) { + --len; + } + if ((len > 1) || (pat[0] != '/')) { + pat[len] = '/'; + ++len; + } + memcpy(pat + len, pattern, l + 1); + scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) + || (!dirOnly && z->isDirectory))) { + continue; + } + if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name + strip, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name + strip, -1)); + } + } + } + ckfree(pat); + + end: + Unlock(); + Tcl_DStringFree(&dsPref); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSPathInFilesystemProc -- + * + * This function determines if the given path object is in the ZIP + * filesystem. + * + * Results: + * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSPathInFilesystemProc( + Tcl_Obj *pathPtr, + ClientData *clientDataPtr) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int ret = -1; + size_t len; + char *path; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + + path = Tcl_GetString(pathPtr); + if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { + return -1; + } + + len = pathPtr->length; + + ReadLock(); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr) { + ret = TCL_OK; + goto endloop; + } + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + for (z = zf->topEnts; z != NULL; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { + ret = TCL_OK; + goto endloop; + } + } + } else if ((len >= zf->mountPointLen) && + (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { + ret = TCL_OK; + break; + } + } + + endloop: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListVolumesProc -- + * + * Lists the currently mounted ZIP filesystem volumes. + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSListVolumesProc(void) +{ + return Tcl_NewStringObj(ZIPFS_VOLUME, -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrStringsProc -- + * + * This function implements the ZIP filesystem dependent 'file + * attributes' subcommand, for listing the set of possible attribute + * strings. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static const char *const * +ZipFSFileAttrStringsProc( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + static const char *const attrs[] = { + "-uncompsize", + "-compsize", + "-offset", + "-mount", + "-archive", + "-permissions", + NULL, + }; + return attrs; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrsGetProc -- + * + * This function implements the ZIP filesystem specific 'file attributes' + * subcommand, for 'get' operations. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFileAttrsGetProc( + Tcl_Interp *interp, /* Current interpreter. */ + int index, + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + int len, ret = TCL_OK; + char *path; + ZipEntry *z; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (!z) { + Tcl_SetErrno(ENOENT); + ZIPFS_POSIX_ERROR(interp, "file not found"); + ret = TCL_ERROR; + goto done; + } + switch (index) { + case 0: + *objPtrRef = Tcl_NewWideIntObj(z->numBytes); + break; + case 1: + *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes); + break; + case 2: + *objPtrRef = Tcl_NewWideIntObj(z->offset); + break; + case 3: + *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, + z->zipFilePtr->mountPointLen); + break; + case 4: + *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); + break; + case 5: + *objPtrRef = Tcl_NewStringObj("0555", -1); + break; + default: + ZIPFS_ERROR(interp, "unknown attribute"); + ret = TCL_ERROR; + } + + done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrsSetProc -- + * + * This function implements the ZIP filesystem specific 'file attributes' + * subcommand, for 'set' operations. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFileAttrsSetProc( + Tcl_Interp *interp, /* Current interpreter. */ + int index, + Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) +{ + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFilesystemPathTypeProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFilesystemPathTypeProc( + Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("zip", -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLoadFile -- + * + * This functions deals with loading native object code. If the given + * path object refers to a file within the ZIP filesystem, an approriate + * error code is returned to delegate loading to the caller (by copying + * the file to temp store and loading from there). As fallback when the + * file refers to the ZIP file system but is not present, it is looked up + * relative to the executable and loaded from there when available. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with error message left. + * + * Side effects: + * Loads native code into the process address space. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSLoadFile( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *path, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, + int flags) +{ + Tcl_FSLoadFileProc2 *loadFileProc; +#ifdef ANDROID + /* + * Force loadFileProc to native implementation since the package manager + * already extracted the shared libraries from the APK at install time. + */ + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc) { + return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } + Tcl_SetErrno(ENOENT); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + return TCL_ERROR; +#else /* !ANDROID */ + Tcl_Obj *altPath = NULL; + int ret = TCL_ERROR; + Tcl_Obj *objs[2] = { NULL, NULL }; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + + Tcl_SetErrno(EXDEV); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + return ret; + } + + objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); + if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + + /* + * Shared object is not in ZIP but its path prefix is, thus try to + * load from directory where the executable came from. + */ + + TclDecrRefCount(objs[1]); + objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); + + /* + * Get directory name of executable manually to deal with cases where + * [file dirname [info nameofexecutable]] is equal to [info + * nameofexecutable] due to VFS effects. + */ + + if (execName) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (!objs[0]) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } + if (objs[0]) { + altPath = TclJoinPath(2, objs); + if (altPath) { + Tcl_IncrRefCount(altPath); + if (Tcl_FSAccess(altPath, R_OK) == 0) { + path = altPath; + } + } + } + } + if (objs[0]) { + Tcl_DecrRefCount(objs[0]); + } + if (objs[1]) { + Tcl_DecrRefCount(objs[1]); + } + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc) { + ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } else { + Tcl_SetErrno(ENOENT); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + } + if (altPath) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif /* ANDROID */ +} + +#endif /* HAVE_ZLIB */ + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Init -- + * + * Perform per interpreter initialization of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds module + * related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclZipfs_Init( + Tcl_Interp *interp) /* Current interpreter. */ +{ +#ifdef HAVE_ZLIB + static const EnsembleImplMap initMap[] = { + {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1}, + {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1}, + {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1}, + {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1}, + /* The 4 entries above are not available in safe interpreters */ + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1}, + {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1}, + {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1}, + {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1}, + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, + {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char findproc[] = + "namespace eval ::tcl::zipfs {}\n" + "proc ::tcl::zipfs::Find dir {\n" + " set result {}\n" + " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n" + " return $result\n" + " }\n" + " foreach file $list {\n" + " if {[file tail $file] in {. ..}} {\n" + " continue\n" + " }\n" + " lappend result $file {*}[Find $file]\n" + " }\n" + " return $result\n" + "}\n" + "proc ::tcl::zipfs::find {directoryName} {\n" + " return [lsort [Find $directoryName]]\n" + "}\n"; + + /* + * One-time initialization. + */ + + WriteLock(); + /* Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); */ + if (!ZipFS.initialized) { + ZipfsSetup(); + } + Unlock(); + + if (interp) { + Tcl_Command ensemble; + Tcl_Obj *mapObj; + + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + ensemble = TclMakeEnsemble(interp, "zipfs", + Tcl_IsSafe(interp) ? (initMap + 4) : initMap); + + /* + * Add the [zipfs find] subcommand. + */ + + Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); + Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1), + Tcl_NewStringObj("::tcl::zipfs::find", -1)); + Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init", + ZipFSTclLibraryObjCmd, NULL, NULL); + Tcl_PkgProvide(interp, "zipfs", "2.0"); + } + return TCL_OK; +#else /* !HAVE_ZLIB */ + ZIPFS_ERROR(interp, "no zlib available"); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + return TCL_ERROR; +#endif /* HAVE_ZLIB */ +} + +static int +ZipfsAppHookFindTclInit( + const char *archive) +{ + Tcl_Obj *vfsInitScript; + int found; + + if (zipfs_literal_tcl_library) { + return TCL_ERROR; + } + if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) { + /* Either the file doesn't exist or it is not a zip archive */ + return TCL_ERROR; + } + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == 0) { + zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT; + return TCL_OK; + } + + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == 0) { + zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library"; + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_AppHook -- + * + * Performs the argument munging for the shell + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_AppHook( + int *argcPtr, /* Pointer to argc */ +#ifdef _WIN32 + TCHAR +#else /* !_WIN32 */ + char +#endif /* _WIN32 */ + ***argvPtr) /* Pointer to argv */ +{ + char *archive; + + Tcl_FindExecutable((*argvPtr)[0]); + archive = (char *) Tcl_GetNameOfExecutable(); + TclZipfs_Init(NULL); + + /* + * Look for init.tcl in one of the locations mounted later in this + * function. + */ + + if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsInitScript; + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + /* + * Startup script should be set before calling Tcl_AppInit + */ + + Tcl_SetStartupScript(vfsInitScript, NULL); + } else { + Tcl_DecrRefCount(vfsInitScript); + } + + /* + * Set Tcl Encodings + */ + + if (!zipfs_literal_tcl_library) { + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } +#ifdef SUPPORT_BUILTIN_ZIP_INSTALL + } else if (*argcPtr > 1) { + /* + * If the first argument is "install", run the supplied installer + * script. + */ + +#ifdef _WIN32 + Tcl_DString ds; + + archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds); +#else /* !_WIN32 */ + archive = (*argvPtr)[1]; +#endif /* _WIN32 */ + if (strcmp(archive, "install") == 0) { + Tcl_Obj *vfsInitScript; + + /* + * Run this now to ensure the file is present by the time Tcl_Main + * wants it. + */ + + TclZipfs_TclLibrary(); + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + Tcl_SetStartupScript(vfsInitScript, NULL); + } + return TCL_OK; + } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsInitScript; + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + /* + * Startup script should be set before calling Tcl_AppInit + */ + + Tcl_SetStartupScript(vfsInitScript, NULL); + } else { + Tcl_DecrRefCount(vfsInitScript); + } + /* Set Tcl Encodings */ + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } +#ifdef _WIN32 + Tcl_DStringFree(&ds); +#endif /* _WIN32 */ +#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ + } + return TCL_OK; +} + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount( + Tcl_Interp *interp, /* Current interpreter. */ + const char *mountPoint, /* Mount point path. */ + const char *zipname, /* Path to ZIP file to mount. */ + const char *passwd) /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} + +int +TclZipfs_MountBuffer( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + unsigned char *data, + size_t datalen, + int copy) +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} + +int +TclZipfs_Unmount( + Tcl_Interp *interp, /* Current interpreter. */ + const char *mountPoint) /* Mount point path. */ +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} +#endif /* !HAVE_ZLIB */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index fc20d7e..d4a8ecb 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -117,7 +117,7 @@ typedef struct { z_stream outStream; /* Structure used by zlib for compression of * output. */ char *inBuffer, *outBuffer; /* Working buffers. */ - int inAllocated, outAllocated; + size_t inAllocated, outAllocated; /* Sizes of working buffers. */ GzipHeader inHeader; /* Header read from input stream, when * decompressing a gzip stream. */ @@ -440,7 +440,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -461,7 +461,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; @@ -1515,7 +1515,7 @@ Tcl_ZlibStreamGet( Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); if (itemLen-zshPtr->outPos >= count-dataPos) { - unsigned len = count - dataPos; + size_t len = count - dataPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); zshPtr->outPos += len; @@ -1524,7 +1524,7 @@ Tcl_ZlibStreamGet( zshPtr->outPos = 0; } } else { - unsigned len = itemLen - zshPtr->outPos; + size_t len = itemLen - zshPtr->outPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); dataPos += len; @@ -2931,7 +2931,7 @@ ZlibTransformClose( result = TCL_ERROR; break; } - if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) { + if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) { /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem then * interp may be NULL */ @@ -3130,7 +3130,7 @@ ZlibTransformOutput( break; } - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) { *errorCodePtr = Tcl_GetErrno(); return -1; } @@ -3186,7 +3186,7 @@ ZlibTransformFlush( * Write the bytes we've received to the next layer. */ - if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { + if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", Tcl_PosixError(interp))); @@ -3387,7 +3387,7 @@ ZlibTransformGetOption( } else { if (cd->compDictObj) { int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + const char *str = TclGetStringFromObj(cd->compDictObj, &len); Tcl_DStringAppend(dsPtr, str, len); } @@ -3909,6 +3909,12 @@ TclZlibInit( Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); /* + * Allow command type introspection to do something sensible with streams. + */ + + TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream"); + + /* * Formally provide the package as a Tcl built-in. */ |