diff options
| author | dgp <dgp@users.sourceforge.net> | 2016-06-16 14:48:35 (GMT) |
|---|---|---|
| committer | dgp <dgp@users.sourceforge.net> | 2016-06-16 14:48:35 (GMT) |
| commit | b700360ad9501defb0b1e2d86353ac8d0db8eef4 (patch) | |
| tree | 8b3bcb3adb8bd2eb44bcf16bb091722274e03e9e /generic | |
| parent | c755ef08151343eb145710489f8c999edbef15ff (diff) | |
| parent | 296aebbd6ee092a25741684fa37ee31ef5a3e222 (diff) | |
| download | tcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.zip tcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.tar.gz tcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.tar.bz2 | |
Merge up to the 8.6.0 release.
Diffstat (limited to 'generic')
117 files changed, 30247 insertions, 12215 deletions
diff --git a/generic/README b/generic/README index 0faffb9..d1c078e 100644 --- a/generic/README +++ b/generic/README @@ -1,5 +1,3 @@ This directory contains Tcl source files that work on all the platforms where Tcl runs (e.g. UNIX, PCs, and MacOSX). Platform-specific sources are in the directories ../unix, ../win, and ../macosx. - -RCS: @(#) $Id: README,v 1.3 2004/03/17 18:14:12 das Exp $ diff --git a/generic/regc_lex.c b/generic/regc_lex.c index f3a46da..132e757 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -742,6 +742,7 @@ lexescape( struct vars *v) { chr c; + int i; static const chr alert[] = { CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t') }; @@ -818,18 +819,23 @@ lexescape( RETV(PLAIN, CHR('\t')); break; case CHR('u'): - c = lexdigits(v, 16, 4, 4); + c = (uchr) lexdigits(v, 16, 1, 4); if (ISERR()) { FAILW(REG_EESCAPE); } RETV(PLAIN, c); break; case CHR('U'): - c = lexdigits(v, 16, 8, 8); + i = lexdigits(v, 16, 1, 8); if (ISERR()) { FAILW(REG_EESCAPE); } - RETV(PLAIN, c); + if (i > 0xFFFF) { + /* TODO: output a Surrogate pair + */ + i = 0xFFFD; + } + RETV(PLAIN, (uchr) i); break; case CHR('v'): RETV(PLAIN, CHR('\v')); @@ -844,7 +850,7 @@ lexescape( break; case CHR('x'): NOTE(REG_UUNPORT); - c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */ + c = (uchr) lexdigits(v, 16, 1, 2); if (ISERR()) { FAILW(REG_EESCAPE); } @@ -866,7 +872,7 @@ lexescape( case CHR('9'): save = v->now; v->now--; /* put first digit back */ - c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ + c = (uchr) lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ if (ISERR()) { FAILW(REG_EESCAPE); } @@ -893,10 +899,15 @@ lexescape( case CHR('0'): NOTE(REG_UUNPORT); v->now--; /* put first digit back */ - c = lexdigits(v, 8, 1, 3); + c = (uchr) lexdigits(v, 8, 1, 3); if (ISERR()) { FAILW(REG_EESCAPE); } + if (c > 0xff) { + /* out of range, so we handled one digit too much */ + v->now--; + c >>= 3; + } RETV(PLAIN, c); break; default: @@ -909,16 +920,16 @@ lexescape( /* - lexdigits - slurp up digits and return chr value - ^ static chr lexdigits(struct vars *, int, int, int); + ^ static int lexdigits(struct vars *, int, int, int); */ -static chr /* chr value; errors signalled via ERR */ +static int /* chr value; errors signalled via ERR */ lexdigits( struct vars *v, int base, int minlen, int maxlen) { - uchr n; /* unsigned to avoid overflow misbehavior */ + int n; int len; chr c; int d; @@ -926,6 +937,10 @@ lexdigits( n = 0; for (len = 0; len < maxlen && !ATEOS(); len++) { + if (n > 0x10fff) { + /* Stop when continuing would otherwise overflow */ + break; + } c = *v->now++; switch (c) { case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): @@ -958,7 +973,7 @@ lexdigits( ERR(REG_EESCAPE); } - return (chr)n; + return n; } /* diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 98df798..f3db471 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: regc_locale.c,v 1.21 2008/10/16 22:34:18 nijtmans Exp $ */ /* ASCII character-name table */ @@ -131,84 +129,172 @@ typedef struct crange { * and used in generic/regc_locale.c. Do not modify by hand. */ -/* Unicode: alphabetic characters */ +/* + * Unicode: alphabetic characters. + */ static const crange alphaRangeTable[] = { - {0x0041, 0x005a}, {0x0061, 0x007a}, {0x00c0, 0x00d6}, {0x00d8, 0x00f6}, - {0x00f8, 0x021f}, {0x0222, 0x0233}, {0x0250, 0x02ad}, {0x02b0, 0x02b8}, - {0x02bb, 0x02c1}, {0x02e0, 0x02e4}, {0x0388, 0x038a}, {0x038e, 0x03a1}, - {0x03a3, 0x03ce}, {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x0481}, - {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0561, 0x0587}, - {0x05d0, 0x05ea}, {0x05f0, 0x05f2}, {0x0621, 0x063a}, {0x0640, 0x064a}, - {0x0671, 0x06d3}, {0x06fa, 0x06fc}, {0x0712, 0x072c}, {0x0780, 0x07a5}, - {0x0905, 0x0939}, {0x0958, 0x0961}, {0x0985, 0x098c}, {0x0993, 0x09a8}, - {0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09df, 0x09e1}, {0x0a05, 0x0a0a}, - {0x0a13, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a59, 0x0a5c}, {0x0a72, 0x0a74}, - {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91}, {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0}, - {0x0ab5, 0x0ab9}, {0x0b05, 0x0b0c}, {0x0b13, 0x0b28}, {0x0b2a, 0x0b30}, - {0x0b36, 0x0b39}, {0x0b5f, 0x0b61}, {0x0b85, 0x0b8a}, {0x0b8e, 0x0b90}, - {0x0b92, 0x0b95}, {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5}, {0x0bb7, 0x0bb9}, - {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, {0x0c12, 0x0c28}, {0x0c2a, 0x0c33}, - {0x0c35, 0x0c39}, {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8}, - {0x0caa, 0x0cb3}, {0x0cb5, 0x0cb9}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10}, - {0x0d12, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1}, - {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0e01, 0x0e30}, {0x0e40, 0x0e46}, - {0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb0}, - {0x0ec0, 0x0ec4}, {0x0f40, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f88, 0x0f8b}, - {0x1000, 0x1021}, {0x1023, 0x1027}, {0x1050, 0x1055}, {0x10a0, 0x10c5}, - {0x10d0, 0x10f6}, {0x1100, 0x1159}, {0x115f, 0x11a2}, {0x11a8, 0x11f9}, - {0x1200, 0x1206}, {0x1208, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256}, - {0x125a, 0x125d}, {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae}, - {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce}, - {0x12d0, 0x12d6}, {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315}, - {0x1318, 0x131e}, {0x1320, 0x1346}, {0x1348, 0x135a}, {0x13a0, 0x13f4}, - {0x1401, 0x166c}, {0x166f, 0x1676}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, - {0x1780, 0x17b3}, {0x1820, 0x1877}, {0x1880, 0x18a8}, {0x1e00, 0x1e9b}, - {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, - {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, - {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, - {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, - {0x210a, 0x2113}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2131}, - {0x2133, 0x2139}, {0x3031, 0x3035}, {0x3041, 0x3094}, {0x30a1, 0x30fa}, - {0x30fc, 0x30fe}, {0x3105, 0x312c}, {0x3131, 0x318e}, {0x31a0, 0x31b7}, - {0x3400, 0x4db5}, {0x4e00, 0x9fa5}, {0xa000, 0xa48c}, {0xac00, 0xd7a3}, - {0xf900, 0xfa2d}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, - {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, - {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, {0xfe70, 0xfe72}, - {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, {0xff66, 0xffbe}, - {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc} + {0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6}, + {0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374}, + {0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5}, + {0x3f7, 0x481}, {0x48a, 0x527}, {0x531, 0x556}, {0x561, 0x587}, + {0x5d0, 0x5ea}, {0x5f0, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, + {0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea}, + {0x800, 0x815}, {0x840, 0x858}, {0x8a2, 0x8ac}, {0x904, 0x939}, + {0x958, 0x961}, {0x971, 0x977}, {0x979, 0x97f}, {0x985, 0x98c}, + {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9df, 0x9e1}, + {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa59, 0xa5c}, + {0xa72, 0xa74}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, + {0xaaa, 0xab0}, {0xab5, 0xab9}, {0xb05, 0xb0c}, {0xb13, 0xb28}, + {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb5f, 0xb61}, {0xb85, 0xb8a}, + {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9}, + {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, {0xc2a, 0xc33}, + {0xc35, 0xc39}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8}, + {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, + {0xd12, 0xd3a}, {0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, + {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46}, + {0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb0}, + {0xec0, 0xec4}, {0xedc, 0xedf}, {0xf40, 0xf47}, {0xf49, 0xf6c}, + {0xf88, 0xf8c}, {0x1000, 0x102a}, {0x1050, 0x1055}, {0x105a, 0x105d}, + {0x106e, 0x1070}, {0x1075, 0x1081}, {0x10a0, 0x10c5}, {0x10d0, 0x10fa}, + {0x10fc, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, + {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, + {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, + {0x1312, 0x1315}, {0x1318, 0x135a}, {0x1380, 0x138f}, {0x13a0, 0x13f4}, + {0x1401, 0x166c}, {0x166f, 0x167f}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, + {0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751}, + {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1877}, + {0x1880, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1950, 0x196d}, + {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19c1, 0x19c7}, {0x1a00, 0x1a16}, + {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b}, {0x1b83, 0x1ba0}, + {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d}, + {0x1ce9, 0x1cec}, {0x1cee, 0x1cf1}, {0x1d00, 0x1dbf}, {0x1e00, 0x1f15}, + {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, + {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, + {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, + {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x2090, 0x209c}, {0x210a, 0x2113}, + {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, {0x213c, 0x213f}, + {0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2ce4}, + {0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, {0x2d80, 0x2d96}, + {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, + {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, + {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, {0x30a1, 0x30fa}, + {0x30fc, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x31a0, 0x31ba}, + {0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fcc}, {0xa000, 0xa48c}, + {0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e}, + {0xa67f, 0xa697}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788}, + {0xa78b, 0xa78e}, {0xa790, 0xa793}, {0xa7a0, 0xa7aa}, {0xa7f8, 0xa801}, + {0xa803, 0xa805}, {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873}, + {0xa882, 0xa8b3}, {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946}, + {0xa960, 0xa97c}, {0xa984, 0xa9b2}, {0xaa00, 0xaa28}, {0xaa40, 0xaa42}, + {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, {0xaa80, 0xaaaf}, {0xaab9, 0xaabd}, + {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, + {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, + {0xabc0, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, + {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, + {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, + {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, + {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, + {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, + {0xffda, 0xffdc} +#if TCL_UTF_MAX > 4 + ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, + {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10280, 0x1029c}, {0x102a0, 0x102d0}, + {0x10300, 0x1031e}, {0x10330, 0x10340}, {0x10342, 0x10349}, {0x10380, 0x1039d}, + {0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, {0x10800, 0x10805}, + {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10900, 0x10915}, {0x10920, 0x10939}, + {0x10980, 0x109b7}, {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, + {0x10a60, 0x10a7c}, {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, + {0x10c00, 0x10c48}, {0x11003, 0x11037}, {0x11083, 0x110af}, {0x110d0, 0x110e8}, + {0x11103, 0x11126}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, {0x11680, 0x116aa}, + {0x12000, 0x1236e}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44}, + {0x16f93, 0x16f9f}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, + {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, + {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, + {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d6c0}, + {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6fa}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d734}, + {0x1d736, 0x1d74e}, {0x1d750, 0x1d76e}, {0x1d770, 0x1d788}, {0x1d78a, 0x1d7a8}, + {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7cb}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, + {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, + {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, + {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, + {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2f800, 0x2fa1d} +#endif }; #define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange)) static const chr alphaCharTable[] = { - 0x00aa, 0x00b5, 0x00ba, 0x02d0, 0x02d1, 0x02ee, 0x037a, 0x0386, 0x038c, - 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0559, 0x06d5, 0x06e5, - 0x06e6, 0x0710, 0x093d, 0x0950, 0x098f, 0x0990, 0x09b2, 0x09dc, 0x09dd, - 0x09f0, 0x09f1, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38, - 0x0a39, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0abd, 0x0ad0, 0x0ae0, 0x0b0f, - 0x0b10, 0x0b32, 0x0b33, 0x0b3d, 0x0b5c, 0x0b5d, 0x0b99, 0x0b9a, 0x0b9c, - 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0c60, 0x0c61, 0x0cde, 0x0ce0, 0x0ce1, - 0x0d60, 0x0d61, 0x0dbd, 0x0e32, 0x0e33, 0x0e81, 0x0e82, 0x0e84, 0x0e87, - 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0eb2, 0x0eb3, - 0x0ebd, 0x0ec6, 0x0edc, 0x0edd, 0x0f00, 0x1029, 0x102a, 0x1248, 0x1258, - 0x1288, 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x207f, - 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x3005, 0x3006, 0x309d, - 0x309e, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74, 0xfffe + 0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x386, 0x38c, + 0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef, 0x6ff, + 0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828, 0x8a0, + 0x93d, 0x950, 0x98f, 0x990, 0x9b2, 0x9bd, 0x9ce, 0x9dc, 0x9dd, + 0x9f0, 0x9f1, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, + 0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1, 0xb0f, + 0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71, 0xb83, 0xb99, + 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xc3d, 0xc58, + 0xc59, 0xc60, 0xc61, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1, 0xcf2, + 0xd3d, 0xd4e, 0xd60, 0xd61, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82, + 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, + 0xeb2, 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065, 0x1066, + 0x108e, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa, 0x1aa7, + 0x1bae, 0x1baf, 0x1cf5, 0x1cf6, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x2071, + 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, + 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, + 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, + 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44 +#if TCL_UTF_MAX > 4 + ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x109be, 0x109bf, 0x10a00, + 0x16f50, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, + 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, + 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, + 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e +#endif }; #define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr)) /* - * Unicode: decimal digit characters + * Unicode: control characters. + */ + +static const crange controlRangeTable[] = { + {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e}, + {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} +#if TCL_UTF_MAX > 4 + ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} +#endif +}; + +#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) + +static const chr controlCharTable[] = { + 0xad, 0x6dd, 0x70f, 0xfeff +#if TCL_UTF_MAX > 4 + ,0x110bd, 0xe0001 +#endif +}; + +#define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr)) + +/* + * Unicode: decimal digit characters. */ static const crange digitRangeTable[] = { - {0x0030, 0x0039}, {0x0660, 0x0669}, {0x06f0, 0x06f9}, {0x0966, 0x096f}, - {0x09e6, 0x09ef}, {0x0a66, 0x0a6f}, {0x0ae6, 0x0aef}, {0x0b66, 0x0b6f}, - {0x0be7, 0x0bef}, {0x0c66, 0x0c6f}, {0x0ce6, 0x0cef}, {0x0d66, 0x0d6f}, - {0x0e50, 0x0e59}, {0x0ed0, 0x0ed9}, {0x0f20, 0x0f29}, {0x1040, 0x1049}, - {0x1369, 0x1371}, {0x17e0, 0x17e9}, {0x1810, 0x1819}, {0xff10, 0xff19} + {0x30, 0x39}, {0x660, 0x669}, {0x6f0, 0x6f9}, {0x7c0, 0x7c9}, + {0x966, 0x96f}, {0x9e6, 0x9ef}, {0xa66, 0xa6f}, {0xae6, 0xaef}, + {0xb66, 0xb6f}, {0xbe6, 0xbef}, {0xc66, 0xc6f}, {0xce6, 0xcef}, + {0xd66, 0xd6f}, {0xe50, 0xe59}, {0xed0, 0xed9}, {0xf20, 0xf29}, + {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9}, {0x1810, 0x1819}, + {0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89}, {0x1a90, 0x1a99}, + {0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49}, {0x1c50, 0x1c59}, + {0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909}, {0xa9d0, 0xa9d9}, + {0xaa50, 0xaa59}, {0xabf0, 0xabf9}, {0xff10, 0xff19} +#if TCL_UTF_MAX > 4 + ,{0x104a0, 0x104a9}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, {0x11136, 0x1113f}, + {0x111d0, 0x111d9}, {0x116c0, 0x116c9}, {0x1d7ce, 0x1d7ff} +#endif }; #define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange)) @@ -222,25 +308,43 @@ static const crange digitRangeTable[] = { */ static const crange punctRangeTable[] = { - {0x0021, 0x0023}, {0x0025, 0x002a}, {0x002c, 0x002f}, {0x005b, 0x005d}, - {0x055a, 0x055f}, {0x066a, 0x066d}, {0x0700, 0x070d}, {0x0f04, 0x0f12}, - {0x0f3a, 0x0f3d}, {0x104a, 0x104f}, {0x1361, 0x1368}, {0x16eb, 0x16ed}, - {0x17d4, 0x17da}, {0x1800, 0x180a}, {0x2010, 0x2027}, {0x2030, 0x2043}, - {0x2048, 0x204d}, {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, - {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff61, 0xff65} + {0x21, 0x23}, {0x25, 0x2a}, {0x2c, 0x2f}, {0x5b, 0x5d}, + {0x55a, 0x55f}, {0x66a, 0x66d}, {0x700, 0x70d}, {0x7f7, 0x7f9}, + {0x830, 0x83e}, {0xf04, 0xf12}, {0xf3a, 0xf3d}, {0xfd0, 0xfd4}, + {0x104a, 0x104f}, {0x1360, 0x1368}, {0x16eb, 0x16ed}, {0x17d4, 0x17d6}, + {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, + {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, + {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, + {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, + {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, + {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, + {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, + {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, + {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} +#if TCL_UTF_MAX > 4 + ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d}, + {0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473} +#endif }; #define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange)) static const chr punctCharTable[] = { - 0x003a, 0x003b, 0x003f, 0x0040, 0x005f, 0x007b, 0x007d, 0x00a1, 0x00ab, - 0x00ad, 0x00b7, 0x00bb, 0x00bf, 0x037e, 0x0387, 0x0589, 0x058a, 0x05be, - 0x05c0, 0x05c3, 0x05f3, 0x05f4, 0x060c, 0x061b, 0x061f, 0x06d4, 0x0964, - 0x0965, 0x0970, 0x0df4, 0x0e4f, 0x0e5a, 0x0e5b, 0x0f85, 0x10fb, 0x166d, - 0x166e, 0x169b, 0x169c, 0x17dc, 0x2045, 0x2046, 0x207d, 0x207e, 0x208d, - 0x208e, 0x2329, 0x232a, 0x3030, 0x30fb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, - 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d + 0x3a, 0x3b, 0x3f, 0x40, 0x5f, 0x7b, 0x7d, 0xa1, 0xa7, + 0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a, + 0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c, + 0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970, + 0xaf0, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, 0xf85, 0xfd9, 0xfda, + 0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, 0x1735, 0x1736, 0x1944, + 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, 0x207d, 0x207e, 0x208d, + 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, 0x29fd, 0x2cfe, 0x2cff, + 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, 0xa4ff, 0xa673, 0xa67e, + 0xa8ce, 0xa8cf, 0xa92e, 0xa92f, 0xa95f, 0xa9de, 0xa9df, 0xaade, 0xaadf, + 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, 0xfe6a, 0xfe6b, + 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d +#if TCL_UTF_MAX > 4 + ,0x1039f, 0x103d0, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc +#endif }; #define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr)) @@ -250,75 +354,113 @@ static const chr punctCharTable[] = { */ static const crange spaceRangeTable[] = { - {0x0009, 0x000d}, {0x2000, 0x200b} + {0x9, 0xd}, {0x2000, 0x200b} }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x0020, 0x00a0, 0x1680, 0x2028, 0x2029, 0x202f, 0x3000 + 0x20, 0x85, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, + 0x2060, 0x3000, 0xfeff }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) /* - * Unicode: lowercase characters + * Unicode: lowercase characters. */ static const crange lowerRangeTable[] = { - {0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x017e, 0x0180}, - {0x0199, 0x019b}, {0x01bd, 0x01bf}, {0x0250, 0x02ad}, {0x03ac, 0x03ce}, - {0x03d5, 0x03d7}, {0x03ef, 0x03f3}, {0x0430, 0x045f}, {0x0561, 0x0587}, - {0x1e95, 0x1e9b}, {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, - {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, - {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, - {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, - {0x1ff2, 0x1ff4}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} + {0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180}, + {0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293}, + {0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7}, + {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x561, 0x587}, {0x1d00, 0x1d2b}, + {0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07}, + {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, + {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, + {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, + {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149}, + {0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731}, + {0xa771, 0xa778}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} +#if TCL_UTF_MAX > 4 + ,{0x10428, 0x1044f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467}, + {0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf}, + {0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f}, + {0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f}, + {0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714}, + {0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788}, + {0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9} +#endif }; #define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange)) static const chr lowerCharTable[] = { - 0x00aa, 0x00b5, 0x00ba, 0x0101, 0x0103, 0x0105, 0x0107, 0x0109, 0x010b, - 0x010d, 0x010f, 0x0111, 0x0113, 0x0115, 0x0117, 0x0119, 0x011b, 0x011d, - 0x011f, 0x0121, 0x0123, 0x0125, 0x0127, 0x0129, 0x012b, 0x012d, 0x012f, - 0x0131, 0x0133, 0x0135, 0x0137, 0x0138, 0x013a, 0x013c, 0x013e, 0x0140, - 0x0142, 0x0144, 0x0146, 0x0148, 0x0149, 0x014b, 0x014d, 0x014f, 0x0151, - 0x0153, 0x0155, 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163, - 0x0165, 0x0167, 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175, - 0x0177, 0x017a, 0x017c, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d, 0x0192, - 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01aa, 0x01ab, 0x01ad, - 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01c6, 0x01c9, 0x01cc, 0x01ce, - 0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dc, 0x01dd, 0x01df, - 0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01ef, 0x01f0, - 0x01f3, 0x01f5, 0x01f9, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, - 0x0207, 0x0209, 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, - 0x0219, 0x021b, 0x021d, 0x021f, 0x0223, 0x0225, 0x0227, 0x0229, 0x022b, - 0x022d, 0x022f, 0x0231, 0x0233, 0x0390, 0x03d0, 0x03d1, 0x03db, 0x03dd, - 0x03df, 0x03e1, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed, 0x03f5, - 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d, 0x046f, 0x0471, - 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f, 0x0481, 0x048d, - 0x048f, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f, - 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1, - 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4, - 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd, - 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ed, 0x04ef, - 0x04f1, 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, - 0x1e0b, 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, - 0x1e1d, 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, - 0x1e2f, 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, - 0x1e41, 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, - 0x1e53, 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, - 0x1e65, 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, - 0x1e77, 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, - 0x1e89, 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1ea1, 0x1ea3, 0x1ea5, - 0x1ea7, 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, - 0x1eb9, 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, - 0x1ecb, 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, - 0x1edd, 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, - 0x1eef, 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fbe, - 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a, 0x210e, - 0x210f, 0x2113, 0x212f, 0x2134, 0x2139 + 0xb5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10b, 0x10d, 0x10f, + 0x111, 0x113, 0x115, 0x117, 0x119, 0x11b, 0x11d, 0x11f, 0x121, + 0x123, 0x125, 0x127, 0x129, 0x12b, 0x12d, 0x12f, 0x131, 0x133, + 0x135, 0x137, 0x138, 0x13a, 0x13c, 0x13e, 0x140, 0x142, 0x144, + 0x146, 0x148, 0x149, 0x14b, 0x14d, 0x14f, 0x151, 0x153, 0x155, + 0x157, 0x159, 0x15b, 0x15d, 0x15f, 0x161, 0x163, 0x165, 0x167, + 0x169, 0x16b, 0x16d, 0x16f, 0x171, 0x173, 0x175, 0x177, 0x17a, + 0x17c, 0x183, 0x185, 0x188, 0x18c, 0x18d, 0x192, 0x195, 0x19e, + 0x1a1, 0x1a3, 0x1a5, 0x1a8, 0x1aa, 0x1ab, 0x1ad, 0x1b0, 0x1b4, + 0x1b6, 0x1b9, 0x1ba, 0x1c6, 0x1c9, 0x1cc, 0x1ce, 0x1d0, 0x1d2, + 0x1d4, 0x1d6, 0x1d8, 0x1da, 0x1dc, 0x1dd, 0x1df, 0x1e1, 0x1e3, + 0x1e5, 0x1e7, 0x1e9, 0x1eb, 0x1ed, 0x1ef, 0x1f0, 0x1f3, 0x1f5, + 0x1f9, 0x1fb, 0x1fd, 0x1ff, 0x201, 0x203, 0x205, 0x207, 0x209, + 0x20b, 0x20d, 0x20f, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21b, + 0x21d, 0x21f, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22b, 0x22d, + 0x22f, 0x231, 0x23c, 0x23f, 0x240, 0x242, 0x247, 0x249, 0x24b, + 0x24d, 0x371, 0x373, 0x377, 0x390, 0x3d0, 0x3d1, 0x3d9, 0x3db, + 0x3dd, 0x3df, 0x3e1, 0x3e3, 0x3e5, 0x3e7, 0x3e9, 0x3eb, 0x3ed, + 0x3f5, 0x3f8, 0x3fb, 0x3fc, 0x461, 0x463, 0x465, 0x467, 0x469, + 0x46b, 0x46d, 0x46f, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47b, + 0x47d, 0x47f, 0x481, 0x48b, 0x48d, 0x48f, 0x491, 0x493, 0x495, + 0x497, 0x499, 0x49b, 0x49d, 0x49f, 0x4a1, 0x4a3, 0x4a5, 0x4a7, + 0x4a9, 0x4ab, 0x4ad, 0x4af, 0x4b1, 0x4b3, 0x4b5, 0x4b7, 0x4b9, + 0x4bb, 0x4bd, 0x4bf, 0x4c2, 0x4c4, 0x4c6, 0x4c8, 0x4ca, 0x4cc, + 0x4ce, 0x4cf, 0x4d1, 0x4d3, 0x4d5, 0x4d7, 0x4d9, 0x4db, 0x4dd, + 0x4df, 0x4e1, 0x4e3, 0x4e5, 0x4e7, 0x4e9, 0x4eb, 0x4ed, 0x4ef, + 0x4f1, 0x4f3, 0x4f5, 0x4f7, 0x4f9, 0x4fb, 0x4fd, 0x4ff, 0x501, + 0x503, 0x505, 0x507, 0x509, 0x50b, 0x50d, 0x50f, 0x511, 0x513, + 0x515, 0x517, 0x519, 0x51b, 0x51d, 0x51f, 0x521, 0x523, 0x525, + 0x527, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f, + 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21, + 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f, 0x1e31, 0x1e33, + 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41, 0x1e43, 0x1e45, + 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53, 0x1e55, 0x1e57, + 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65, 0x1e67, 0x1e69, + 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77, 0x1e79, 0x1e7b, + 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89, 0x1e8b, 0x1e8d, + 0x1e8f, 0x1e91, 0x1e93, 0x1e9f, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7, 0x1ea9, + 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9, 0x1ebb, + 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb, 0x1ecd, + 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd, 0x1edf, + 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, 0x1ef1, + 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1efb, 0x1efd, 0x1fb6, 0x1fb7, 0x1fbe, + 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x210a, 0x210e, 0x210f, + 0x2113, 0x212f, 0x2134, 0x2139, 0x213c, 0x213d, 0x214e, 0x2184, 0x2c61, + 0x2c65, 0x2c66, 0x2c68, 0x2c6a, 0x2c6c, 0x2c71, 0x2c73, 0x2c74, 0x2c81, + 0x2c83, 0x2c85, 0x2c87, 0x2c89, 0x2c8b, 0x2c8d, 0x2c8f, 0x2c91, 0x2c93, + 0x2c95, 0x2c97, 0x2c99, 0x2c9b, 0x2c9d, 0x2c9f, 0x2ca1, 0x2ca3, 0x2ca5, + 0x2ca7, 0x2ca9, 0x2cab, 0x2cad, 0x2caf, 0x2cb1, 0x2cb3, 0x2cb5, 0x2cb7, + 0x2cb9, 0x2cbb, 0x2cbd, 0x2cbf, 0x2cc1, 0x2cc3, 0x2cc5, 0x2cc7, 0x2cc9, + 0x2ccb, 0x2ccd, 0x2ccf, 0x2cd1, 0x2cd3, 0x2cd5, 0x2cd7, 0x2cd9, 0x2cdb, + 0x2cdd, 0x2cdf, 0x2ce1, 0x2ce3, 0x2ce4, 0x2cec, 0x2cee, 0x2cf3, 0x2d27, + 0x2d2d, 0xa641, 0xa643, 0xa645, 0xa647, 0xa649, 0xa64b, 0xa64d, 0xa64f, + 0xa651, 0xa653, 0xa655, 0xa657, 0xa659, 0xa65b, 0xa65d, 0xa65f, 0xa661, + 0xa663, 0xa665, 0xa667, 0xa669, 0xa66b, 0xa66d, 0xa681, 0xa683, 0xa685, + 0xa687, 0xa689, 0xa68b, 0xa68d, 0xa68f, 0xa691, 0xa693, 0xa695, 0xa697, + 0xa723, 0xa725, 0xa727, 0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, + 0xa739, 0xa73b, 0xa73d, 0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, + 0xa74b, 0xa74d, 0xa74f, 0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, + 0xa75d, 0xa75f, 0xa761, 0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, + 0xa76f, 0xa77a, 0xa77c, 0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, + 0xa78e, 0xa791, 0xa793, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9, 0xa7fa +#if TCL_UTF_MAX > 4 + ,0x1d4bb, 0x1d7cb +#endif }; #define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) @@ -328,59 +470,95 @@ static const chr lowerCharTable[] = { */ static const crange upperRangeTable[] = { - {0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b}, - {0x018e, 0x0191}, {0x0196, 0x0198}, {0x01b1, 0x01b3}, {0x01f6, 0x01f8}, - {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab}, {0x03d2, 0x03d4}, - {0x0400, 0x042f}, {0x0531, 0x0556}, {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, - {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, - {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, - {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112}, - {0x2119, 0x211d}, {0x212a, 0x212d}, {0xff21, 0xff3a} + {0x41, 0x5a}, {0xc0, 0xd6}, {0xd8, 0xde}, {0x189, 0x18b}, + {0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8}, + {0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab}, + {0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5}, + {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, + {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, + {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, + {0x2110, 0x2112}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, + {0x2c00, 0x2c2e}, {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, + {0xff21, 0xff3a} +#if TCL_UTF_MAX > 4 + ,{0x10400, 0x10427}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481}, + {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a}, + {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, + {0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed}, + {0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0}, + {0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8} +#endif }; #define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange)) static const chr upperCharTable[] = { - 0x0100, 0x0102, 0x0104, 0x0106, 0x0108, 0x010a, 0x010c, 0x010e, 0x0110, - 0x0112, 0x0114, 0x0116, 0x0118, 0x011a, 0x011c, 0x011e, 0x0120, 0x0122, - 0x0124, 0x0126, 0x0128, 0x012a, 0x012c, 0x012e, 0x0130, 0x0132, 0x0134, - 0x0136, 0x0139, 0x013b, 0x013d, 0x013f, 0x0141, 0x0143, 0x0145, 0x0147, - 0x014a, 0x014c, 0x014e, 0x0150, 0x0152, 0x0154, 0x0156, 0x0158, 0x015a, - 0x015c, 0x015e, 0x0160, 0x0162, 0x0164, 0x0166, 0x0168, 0x016a, 0x016c, - 0x016e, 0x0170, 0x0172, 0x0174, 0x0176, 0x0178, 0x0179, 0x017b, 0x017d, - 0x0181, 0x0182, 0x0184, 0x0186, 0x0187, 0x0193, 0x0194, 0x019c, 0x019d, - 0x019f, 0x01a0, 0x01a2, 0x01a4, 0x01a6, 0x01a7, 0x01a9, 0x01ac, 0x01ae, - 0x01af, 0x01b5, 0x01b7, 0x01b8, 0x01bc, 0x01c4, 0x01c7, 0x01ca, 0x01cd, - 0x01cf, 0x01d1, 0x01d3, 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0, - 0x01e2, 0x01e4, 0x01e6, 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4, - 0x01fa, 0x01fc, 0x01fe, 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a, - 0x020c, 0x020e, 0x0210, 0x0212, 0x0214, 0x0216, 0x0218, 0x021a, 0x021c, - 0x021e, 0x0222, 0x0224, 0x0226, 0x0228, 0x022a, 0x022c, 0x022e, 0x0230, - 0x0232, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc, 0x03de, 0x03e0, - 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee, 0x03f4, 0x0460, - 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470, 0x0472, - 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x048c, 0x048e, - 0x0490, 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0, - 0x04a2, 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2, - 0x04b4, 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c0, 0x04c1, 0x04c3, - 0x04c7, 0x04cb, 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc, - 0x04de, 0x04e0, 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ec, 0x04ee, - 0x04f0, 0x04f2, 0x04f4, 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, - 0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, - 0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, - 0x1e2e, 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, - 0x1e40, 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, - 0x1e52, 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, - 0x1e64, 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, - 0x1e76, 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, - 0x1e88, 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1ea0, 0x1ea2, - 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, - 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, - 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, - 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, - 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1f59, 0x1f5b, - 0x1f5d, 0x1f5f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x2130, - 0x2131, 0x2133 + 0x100, 0x102, 0x104, 0x106, 0x108, 0x10a, 0x10c, 0x10e, 0x110, + 0x112, 0x114, 0x116, 0x118, 0x11a, 0x11c, 0x11e, 0x120, 0x122, + 0x124, 0x126, 0x128, 0x12a, 0x12c, 0x12e, 0x130, 0x132, 0x134, + 0x136, 0x139, 0x13b, 0x13d, 0x13f, 0x141, 0x143, 0x145, 0x147, + 0x14a, 0x14c, 0x14e, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15a, + 0x15c, 0x15e, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16a, 0x16c, + 0x16e, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17b, 0x17d, + 0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19c, 0x19d, + 0x19f, 0x1a0, 0x1a2, 0x1a4, 0x1a6, 0x1a7, 0x1a9, 0x1ac, 0x1ae, + 0x1af, 0x1b5, 0x1b7, 0x1b8, 0x1bc, 0x1c4, 0x1c7, 0x1ca, 0x1cd, + 0x1cf, 0x1d1, 0x1d3, 0x1d5, 0x1d7, 0x1d9, 0x1db, 0x1de, 0x1e0, + 0x1e2, 0x1e4, 0x1e6, 0x1e8, 0x1ea, 0x1ec, 0x1ee, 0x1f1, 0x1f4, + 0x1fa, 0x1fc, 0x1fe, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20a, + 0x20c, 0x20e, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21a, 0x21c, + 0x21e, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22a, 0x22c, 0x22e, + 0x230, 0x232, 0x23a, 0x23b, 0x23d, 0x23e, 0x241, 0x248, 0x24a, + 0x24c, 0x24e, 0x370, 0x372, 0x376, 0x386, 0x38c, 0x38e, 0x38f, + 0x3cf, 0x3d8, 0x3da, 0x3dc, 0x3de, 0x3e0, 0x3e2, 0x3e4, 0x3e6, + 0x3e8, 0x3ea, 0x3ec, 0x3ee, 0x3f4, 0x3f7, 0x3f9, 0x3fa, 0x460, + 0x462, 0x464, 0x466, 0x468, 0x46a, 0x46c, 0x46e, 0x470, 0x472, + 0x474, 0x476, 0x478, 0x47a, 0x47c, 0x47e, 0x480, 0x48a, 0x48c, + 0x48e, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49a, 0x49c, 0x49e, + 0x4a0, 0x4a2, 0x4a4, 0x4a6, 0x4a8, 0x4aa, 0x4ac, 0x4ae, 0x4b0, + 0x4b2, 0x4b4, 0x4b6, 0x4b8, 0x4ba, 0x4bc, 0x4be, 0x4c0, 0x4c1, + 0x4c3, 0x4c5, 0x4c7, 0x4c9, 0x4cb, 0x4cd, 0x4d0, 0x4d2, 0x4d4, + 0x4d6, 0x4d8, 0x4da, 0x4dc, 0x4de, 0x4e0, 0x4e2, 0x4e4, 0x4e6, + 0x4e8, 0x4ea, 0x4ec, 0x4ee, 0x4f0, 0x4f2, 0x4f4, 0x4f6, 0x4f8, + 0x4fa, 0x4fc, 0x4fe, 0x500, 0x502, 0x504, 0x506, 0x508, 0x50a, + 0x50c, 0x50e, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51a, 0x51c, + 0x51e, 0x520, 0x522, 0x524, 0x526, 0x10c7, 0x10cd, 0x1e00, 0x1e02, + 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, + 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, + 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38, + 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a, + 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c, + 0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e, + 0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80, + 0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92, + 0x1e94, 0x1e9e, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac, + 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe, + 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0, + 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2, + 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4, + 0x1ef6, 0x1ef8, 0x1efa, 0x1efc, 0x1efe, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, + 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x213e, 0x213f, 0x2145, + 0x2183, 0x2c60, 0x2c67, 0x2c69, 0x2c6b, 0x2c72, 0x2c75, 0x2c82, 0x2c84, + 0x2c86, 0x2c88, 0x2c8a, 0x2c8c, 0x2c8e, 0x2c90, 0x2c92, 0x2c94, 0x2c96, + 0x2c98, 0x2c9a, 0x2c9c, 0x2c9e, 0x2ca0, 0x2ca2, 0x2ca4, 0x2ca6, 0x2ca8, + 0x2caa, 0x2cac, 0x2cae, 0x2cb0, 0x2cb2, 0x2cb4, 0x2cb6, 0x2cb8, 0x2cba, + 0x2cbc, 0x2cbe, 0x2cc0, 0x2cc2, 0x2cc4, 0x2cc6, 0x2cc8, 0x2cca, 0x2ccc, + 0x2cce, 0x2cd0, 0x2cd2, 0x2cd4, 0x2cd6, 0x2cd8, 0x2cda, 0x2cdc, 0x2cde, + 0x2ce0, 0x2ce2, 0x2ceb, 0x2ced, 0x2cf2, 0xa640, 0xa642, 0xa644, 0xa646, + 0xa648, 0xa64a, 0xa64c, 0xa64e, 0xa650, 0xa652, 0xa654, 0xa656, 0xa658, + 0xa65a, 0xa65c, 0xa65e, 0xa660, 0xa662, 0xa664, 0xa666, 0xa668, 0xa66a, + 0xa66c, 0xa680, 0xa682, 0xa684, 0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, + 0xa690, 0xa692, 0xa694, 0xa696, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, + 0xa72c, 0xa72e, 0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, + 0xa740, 0xa742, 0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, + 0xa752, 0xa754, 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, + 0xa764, 0xa766, 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, + 0xa77e, 0xa780, 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, + 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7aa +#if TCL_UTF_MAX > 4 + ,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538, + 0x1d539, 0x1d546, 0x1d7ca +#endif }; #define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) @@ -390,221 +568,147 @@ static const chr upperCharTable[] = { */ static const crange graphRangeTable[] = { - {0x0021, 0x007e}, {0x00a0, 0x011f}, {0x0121, 0x021f}, {0x0222, 0x0233}, - {0x0250, 0x02ad}, {0x02b0, 0x02ee}, {0x0300, 0x031f}, {0x0321, 0x034e}, - {0x0360, 0x0362}, {0x0384, 0x038a}, {0x038e, 0x03a1}, {0x03a3, 0x03ce}, - {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x041f}, {0x0421, 0x0486}, - {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0559, 0x055f}, - {0x0561, 0x0587}, {0x0591, 0x05a1}, {0x05a3, 0x05b9}, {0x05bb, 0x05c4}, - {0x05d0, 0x05ea}, {0x05f0, 0x05f4}, {0x0621, 0x063a}, {0x0640, 0x0655}, - {0x0660, 0x066d}, {0x0670, 0x06ed}, {0x06f0, 0x06fe}, {0x0700, 0x070d}, - {0x0710, 0x071f}, {0x0721, 0x072c}, {0x0730, 0x074a}, {0x0780, 0x07b0}, - {0x0901, 0x0903}, {0x0905, 0x091f}, {0x0921, 0x0939}, {0x093c, 0x094d}, - {0x0950, 0x0954}, {0x0958, 0x0970}, {0x0981, 0x0983}, {0x0985, 0x098c}, - {0x0993, 0x09a8}, {0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09be, 0x09c4}, - {0x09cb, 0x09cd}, {0x09df, 0x09e3}, {0x09e6, 0x09fa}, {0x0a05, 0x0a0a}, - {0x0a13, 0x0a1f}, {0x0a21, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a3e, 0x0a42}, - {0x0a4b, 0x0a4d}, {0x0a59, 0x0a5c}, {0x0a66, 0x0a74}, {0x0a81, 0x0a83}, - {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91}, {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0}, - {0x0ab5, 0x0ab9}, {0x0abc, 0x0ac5}, {0x0ac7, 0x0ac9}, {0x0acb, 0x0acd}, - {0x0ae6, 0x0aef}, {0x0b01, 0x0b03}, {0x0b05, 0x0b0c}, {0x0b13, 0x0b1f}, - {0x0b21, 0x0b28}, {0x0b2a, 0x0b30}, {0x0b36, 0x0b39}, {0x0b3c, 0x0b43}, - {0x0b4b, 0x0b4d}, {0x0b5f, 0x0b61}, {0x0b66, 0x0b70}, {0x0b85, 0x0b8a}, - {0x0b8e, 0x0b90}, {0x0b92, 0x0b95}, {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5}, - {0x0bb7, 0x0bb9}, {0x0bbe, 0x0bc2}, {0x0bc6, 0x0bc8}, {0x0bca, 0x0bcd}, - {0x0be7, 0x0bf2}, {0x0c01, 0x0c03}, {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, - {0x0c12, 0x0c1f}, {0x0c21, 0x0c28}, {0x0c2a, 0x0c33}, {0x0c35, 0x0c39}, - {0x0c3e, 0x0c44}, {0x0c46, 0x0c48}, {0x0c4a, 0x0c4d}, {0x0c66, 0x0c6f}, - {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3}, - {0x0cb5, 0x0cb9}, {0x0cbe, 0x0cc4}, {0x0cc6, 0x0cc8}, {0x0cca, 0x0ccd}, - {0x0ce6, 0x0cef}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10}, {0x0d12, 0x0d1f}, - {0x0d21, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d3e, 0x0d43}, {0x0d46, 0x0d48}, - {0x0d4a, 0x0d4d}, {0x0d66, 0x0d6f}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1}, - {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0dcf, 0x0dd4}, {0x0dd8, 0x0ddf}, - {0x0df2, 0x0df4}, {0x0e01, 0x0e1f}, {0x0e21, 0x0e3a}, {0x0e3f, 0x0e5b}, - {0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb9}, - {0x0ebb, 0x0ebd}, {0x0ec0, 0x0ec4}, {0x0ec8, 0x0ecd}, {0x0ed0, 0x0ed9}, - {0x0f00, 0x0f1f}, {0x0f21, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f71, 0x0f8b}, - {0x0f90, 0x0f97}, {0x0f99, 0x0fbc}, {0x0fbe, 0x0fcc}, {0x1000, 0x101f}, - {0x1023, 0x1027}, {0x102c, 0x1032}, {0x1036, 0x1039}, {0x1040, 0x1059}, - {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, {0x1100, 0x111f}, {0x1121, 0x1159}, - {0x115f, 0x11a2}, {0x11a8, 0x11f9}, {0x1200, 0x1206}, {0x1208, 0x121f}, - {0x1221, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, - {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae}, {0x12b2, 0x12b5}, - {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce}, {0x12d0, 0x12d6}, - {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315}, {0x1318, 0x131e}, - {0x1321, 0x1346}, {0x1348, 0x135a}, {0x1361, 0x137c}, {0x13a0, 0x13f4}, - {0x1401, 0x141f}, {0x1421, 0x151f}, {0x1521, 0x161f}, {0x1621, 0x1676}, - {0x1680, 0x169c}, {0x16a0, 0x16f0}, {0x1780, 0x17dc}, {0x17e0, 0x17e9}, - {0x1800, 0x180a}, {0x1810, 0x1819}, {0x1821, 0x1877}, {0x1880, 0x18a9}, - {0x1e00, 0x1e1f}, {0x1e21, 0x1e9b}, {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, - {0x1f18, 0x1f1d}, {0x1f21, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, - {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, - {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, - {0x2000, 0x200b}, {0x2010, 0x201f}, {0x2021, 0x2029}, {0x202f, 0x2046}, - {0x2048, 0x204d}, {0x2074, 0x208e}, {0x20a0, 0x20af}, {0x20d0, 0x20e3}, - {0x2100, 0x211f}, {0x2121, 0x213a}, {0x2153, 0x2183}, {0x2190, 0x21f3}, - {0x2200, 0x221f}, {0x2221, 0x22f1}, {0x2300, 0x231f}, {0x2321, 0x237b}, - {0x237d, 0x239a}, {0x2400, 0x241f}, {0x2421, 0x2426}, {0x2440, 0x244a}, - {0x2460, 0x24ea}, {0x2500, 0x251f}, {0x2521, 0x2595}, {0x25a0, 0x25f7}, - {0x2600, 0x2613}, {0x2619, 0x261f}, {0x2621, 0x2671}, {0x2701, 0x2704}, - {0x2706, 0x2709}, {0x270c, 0x271f}, {0x2721, 0x2727}, {0x2729, 0x274b}, - {0x274f, 0x2752}, {0x2758, 0x275e}, {0x2761, 0x2767}, {0x2776, 0x2794}, - {0x2798, 0x27af}, {0x27b1, 0x27be}, {0x2800, 0x281f}, {0x2821, 0x28ff}, - {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2f1f}, {0x2f21, 0x2fd5}, - {0x2ff0, 0x2ffb}, {0x3000, 0x301f}, {0x3021, 0x303a}, {0x3041, 0x3094}, - {0x3099, 0x309e}, {0x30a1, 0x30fe}, {0x3105, 0x311f}, {0x3121, 0x312c}, - {0x3131, 0x318e}, {0x3190, 0x31b7}, {0x3200, 0x321c}, {0x3221, 0x3243}, - {0x3260, 0x327b}, {0x327f, 0x32b0}, {0x32c0, 0x32cb}, {0x32d0, 0x32fe}, - {0x3300, 0x331f}, {0x3321, 0x3376}, {0x337b, 0x33dd}, {0x33e0, 0x33fe}, - {0x3400, 0x341f}, {0x3421, 0x351f}, {0x3521, 0x361f}, {0x3621, 0x371f}, - {0x3721, 0x381f}, {0x3821, 0x391f}, {0x3921, 0x3a1f}, {0x3a21, 0x3b1f}, - {0x3b21, 0x3c1f}, {0x3c21, 0x3d1f}, {0x3d21, 0x3e1f}, {0x3e21, 0x3f1f}, - {0x3f21, 0x401f}, {0x4021, 0x411f}, {0x4121, 0x421f}, {0x4221, 0x431f}, - {0x4321, 0x441f}, {0x4421, 0x451f}, {0x4521, 0x461f}, {0x4621, 0x471f}, - {0x4721, 0x481f}, {0x4821, 0x491f}, {0x4921, 0x4a1f}, {0x4a21, 0x4b1f}, - {0x4b21, 0x4c1f}, {0x4c21, 0x4d1f}, {0x4d21, 0x4db5}, {0x4e00, 0x4e1f}, - {0x4e21, 0x4f1f}, {0x4f21, 0x501f}, {0x5021, 0x511f}, {0x5121, 0x521f}, - {0x5221, 0x531f}, {0x5321, 0x541f}, {0x5421, 0x551f}, {0x5521, 0x561f}, - {0x5621, 0x571f}, {0x5721, 0x581f}, {0x5821, 0x591f}, {0x5921, 0x5a1f}, - {0x5a21, 0x5b1f}, {0x5b21, 0x5c1f}, {0x5c21, 0x5d1f}, {0x5d21, 0x5e1f}, - {0x5e21, 0x5f1f}, {0x5f21, 0x601f}, {0x6021, 0x611f}, {0x6121, 0x621f}, - {0x6221, 0x631f}, {0x6321, 0x641f}, {0x6421, 0x651f}, {0x6521, 0x661f}, - {0x6621, 0x671f}, {0x6721, 0x681f}, {0x6821, 0x691f}, {0x6921, 0x6a1f}, - {0x6a21, 0x6b1f}, {0x6b21, 0x6c1f}, {0x6c21, 0x6d1f}, {0x6d21, 0x6e1f}, - {0x6e21, 0x6f1f}, {0x6f21, 0x701f}, {0x7021, 0x711f}, {0x7121, 0x721f}, - {0x7221, 0x731f}, {0x7321, 0x741f}, {0x7421, 0x751f}, {0x7521, 0x761f}, - {0x7621, 0x771f}, {0x7721, 0x781f}, {0x7821, 0x791f}, {0x7921, 0x7a1f}, - {0x7a21, 0x7b1f}, {0x7b21, 0x7c1f}, {0x7c21, 0x7d1f}, {0x7d21, 0x7e1f}, - {0x7e21, 0x7f1f}, {0x7f21, 0x801f}, {0x8021, 0x811f}, {0x8121, 0x821f}, - {0x8221, 0x831f}, {0x8321, 0x841f}, {0x8421, 0x851f}, {0x8521, 0x861f}, - {0x8621, 0x871f}, {0x8721, 0x881f}, {0x8821, 0x891f}, {0x8921, 0x8a1f}, - {0x8a21, 0x8b1f}, {0x8b21, 0x8c1f}, {0x8c21, 0x8d1f}, {0x8d21, 0x8e1f}, - {0x8e21, 0x8f1f}, {0x8f21, 0x901f}, {0x9021, 0x911f}, {0x9121, 0x921f}, - {0x9221, 0x931f}, {0x9321, 0x941f}, {0x9421, 0x951f}, {0x9521, 0x961f}, - {0x9621, 0x971f}, {0x9721, 0x981f}, {0x9821, 0x991f}, {0x9921, 0x9a1f}, - {0x9a21, 0x9b1f}, {0x9b21, 0x9c1f}, {0x9c21, 0x9d1f}, {0x9d21, 0x9e1f}, - {0x9e21, 0x9f1f}, {0x9f21, 0x9fa5}, {0xa000, 0xa01f}, {0xa021, 0xa11f}, - {0xa121, 0xa21f}, {0xa221, 0xa31f}, {0xa321, 0xa41f}, {0xa421, 0xa48c}, - {0xa490, 0xa4a1}, {0xa4a4, 0xa4b3}, {0xa4b5, 0xa4c0}, {0xa4c2, 0xa4c4}, - {0xac00, 0xac1f}, {0xac21, 0xad1f}, {0xad21, 0xae1f}, {0xae21, 0xaf1f}, - {0xaf21, 0xb01f}, {0xb021, 0xb11f}, {0xb121, 0xb21f}, {0xb221, 0xb31f}, - {0xb321, 0xb41f}, {0xb421, 0xb51f}, {0xb521, 0xb61f}, {0xb621, 0xb71f}, - {0xb721, 0xb81f}, {0xb821, 0xb91f}, {0xb921, 0xba1f}, {0xba21, 0xbb1f}, - {0xbb21, 0xbc1f}, {0xbc21, 0xbd1f}, {0xbd21, 0xbe1f}, {0xbe21, 0xbf1f}, - {0xbf21, 0xc01f}, {0xc021, 0xc11f}, {0xc121, 0xc21f}, {0xc221, 0xc31f}, - {0xc321, 0xc41f}, {0xc421, 0xc51f}, {0xc521, 0xc61f}, {0xc621, 0xc71f}, - {0xc721, 0xc81f}, {0xc821, 0xc91f}, {0xc921, 0xca1f}, {0xca21, 0xcb1f}, - {0xcb21, 0xcc1f}, {0xcc21, 0xcd1f}, {0xcd21, 0xce1f}, {0xce21, 0xcf1f}, - {0xcf21, 0xd01f}, {0xd021, 0xd11f}, {0xd121, 0xd21f}, {0xd221, 0xd31f}, - {0xd321, 0xd41f}, {0xd421, 0xd51f}, {0xd521, 0xd61f}, {0xd621, 0xd71f}, - {0xd721, 0xd7a3}, {0xf900, 0xf91f}, {0xf921, 0xfa1f}, {0xfa21, 0xfa2d}, - {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb1f}, {0xfb21, 0xfb36}, - {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfc1f}, {0xfc21, 0xfd1f}, - {0xfd21, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, - {0xfe21, 0xfe23}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe66}, - {0xfe68, 0xfe6b}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, {0xff01, 0xff1f}, - {0xff21, 0xff5e}, {0xff61, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, - {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee}, - {0xfffc, 0xffff} + {0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37e}, + {0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x527}, {0x531, 0x556}, + {0x559, 0x55f}, {0x561, 0x587}, {0x591, 0x5c7}, {0x5d0, 0x5ea}, + {0x5f0, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d}, + {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x800, 0x82d}, + {0x830, 0x83e}, {0x840, 0x85b}, {0x8a2, 0x8ac}, {0x8e4, 0x8fe}, + {0x900, 0x977}, {0x979, 0x97f}, {0x981, 0x983}, {0x985, 0x98c}, + {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, + {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fb}, {0xa01, 0xa03}, + {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42}, + {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa75}, {0xa81, 0xa83}, + {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, {0xaaa, 0xab0}, + {0xab5, 0xab9}, {0xabc, 0xac5}, {0xac7, 0xac9}, {0xacb, 0xacd}, + {0xae0, 0xae3}, {0xae6, 0xaf1}, {0xb01, 0xb03}, {0xb05, 0xb0c}, + {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb3c, 0xb44}, + {0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, {0xb85, 0xb8a}, + {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9}, + {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, {0xbe6, 0xbfa}, + {0xc01, 0xc03}, {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, + {0xc2a, 0xc33}, {0xc35, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48}, + {0xc4a, 0xc4d}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc78, 0xc7f}, + {0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3}, + {0xcb5, 0xcb9}, {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd}, + {0xce0, 0xce3}, {0xce6, 0xcef}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, + {0xd12, 0xd3a}, {0xd3d, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4e}, + {0xd60, 0xd63}, {0xd66, 0xd75}, {0xd79, 0xd7f}, {0xd85, 0xd96}, + {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xdcf, 0xdd4}, + {0xdd8, 0xddf}, {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, + {0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb9}, + {0xebb, 0xebd}, {0xec0, 0xec4}, {0xec8, 0xecd}, {0xed0, 0xed9}, + {0xedc, 0xedf}, {0xf00, 0xf47}, {0xf49, 0xf6c}, {0xf71, 0xf97}, + {0xf99, 0xfbc}, {0xfbe, 0xfcc}, {0xfce, 0xfda}, {0x1000, 0x10c5}, + {0x10d0, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, + {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, + {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, + {0x1312, 0x1315}, {0x1318, 0x135a}, {0x135d, 0x137c}, {0x1380, 0x1399}, + {0x13a0, 0x13f4}, {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f0}, + {0x1700, 0x170c}, {0x170e, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, + {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17dd}, {0x17e0, 0x17e9}, + {0x17f0, 0x17f9}, {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1877}, + {0x1880, 0x18aa}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1920, 0x192b}, + {0x1930, 0x193b}, {0x1944, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, + {0x19b0, 0x19c9}, {0x19d0, 0x19da}, {0x19de, 0x1a1b}, {0x1a1e, 0x1a5e}, + {0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad}, + {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37}, + {0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf6}, + {0x1d00, 0x1de6}, {0x1dfc, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, + {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, + {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, + {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, + {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0}, + {0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a}, + {0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e}, + {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, + {0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, + {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, + {0x2dd8, 0x2dde}, {0x2de0, 0x2e3b}, {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, + {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, {0x3001, 0x303f}, {0x3041, 0x3096}, + {0x3099, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x3190, 0x31ba}, + {0x31c0, 0x31e3}, {0x31f0, 0x321e}, {0x3220, 0x32fe}, {0x3300, 0x4db5}, + {0x4dc0, 0x9fcc}, {0xa000, 0xa48c}, {0xa490, 0xa4c6}, {0xa4d0, 0xa62b}, + {0xa640, 0xa697}, {0xa69f, 0xa6f7}, {0xa700, 0xa78e}, {0xa790, 0xa793}, + {0xa7a0, 0xa7aa}, {0xa7f8, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, + {0xa880, 0xa8c4}, {0xa8ce, 0xa8d9}, {0xa8e0, 0xa8fb}, {0xa900, 0xa953}, + {0xa95f, 0xa97c}, {0xa980, 0xa9cd}, {0xa9cf, 0xa9d9}, {0xaa00, 0xaa36}, + {0xaa40, 0xaa4d}, {0xaa50, 0xaa59}, {0xaa5c, 0xaa7b}, {0xaa80, 0xaac2}, + {0xaadb, 0xaaf6}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, + {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabed}, {0xabf0, 0xabf9}, + {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, + {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, + {0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, + {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe26}, + {0xfe30, 0xfe52}, {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, + {0xfe76, 0xfefc}, {0xff01, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, + {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee} +#if TCL_UTF_MAX > 4 + ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, + {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133}, + {0x10137, 0x1018a}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, + {0x102a0, 0x102d0}, {0x10300, 0x1031e}, {0x10320, 0x10323}, {0x10330, 0x1034a}, + {0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, {0x10400, 0x1049d}, + {0x104a0, 0x104a9}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, + {0x10857, 0x1085f}, {0x10900, 0x1091b}, {0x1091f, 0x10939}, {0x10980, 0x109b7}, + {0x10a00, 0x10a03}, {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, + {0x10a38, 0x10a3a}, {0x10a3f, 0x10a47}, {0x10a50, 0x10a58}, {0x10a60, 0x10a7f}, + {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, {0x10b78, 0x10b7f}, + {0x10c00, 0x10c48}, {0x10e60, 0x10e7e}, {0x11000, 0x1104d}, {0x11052, 0x1106f}, + {0x11080, 0x110bc}, {0x110be, 0x110c1}, {0x110d0, 0x110e8}, {0x110f0, 0x110f9}, + {0x11100, 0x11134}, {0x11136, 0x11143}, {0x11180, 0x111c8}, {0x111d0, 0x111d9}, + {0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x12000, 0x1236e}, {0x12400, 0x12462}, + {0x12470, 0x12473}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44}, + {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, + {0x1d129, 0x1d172}, {0x1d17b, 0x1d1dd}, {0x1d200, 0x1d245}, {0x1d300, 0x1d356}, + {0x1d360, 0x1d371}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, + {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, + {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, + {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb}, + {0x1d7ce, 0x1d7ff}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, + {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, + {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, + {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b}, + {0x1f030, 0x1f093}, {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0be}, {0x1f0c1, 0x1f0cf}, + {0x1f0d1, 0x1f0df}, {0x1f100, 0x1f10a}, {0x1f110, 0x1f12e}, {0x1f130, 0x1f16b}, + {0x1f170, 0x1f19a}, {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23a}, {0x1f240, 0x1f248}, + {0x1f300, 0x1f320}, {0x1f330, 0x1f335}, {0x1f337, 0x1f37c}, {0x1f380, 0x1f393}, + {0x1f3a0, 0x1f3c4}, {0x1f3c6, 0x1f3ca}, {0x1f3e0, 0x1f3f0}, {0x1f400, 0x1f43e}, + {0x1f442, 0x1f4f7}, {0x1f4f9, 0x1f4fc}, {0x1f500, 0x1f53d}, {0x1f540, 0x1f543}, + {0x1f550, 0x1f567}, {0x1f5fb, 0x1f640}, {0x1f645, 0x1f64f}, {0x1f680, 0x1f6c5}, + {0x1f700, 0x1f773}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, + {0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef} +#endif }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) static const chr graphCharTable[] = { - 0x0374, 0x0375, 0x037a, 0x037e, 0x038c, 0x0488, 0x0489, 0x04c7, 0x04c8, - 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0589, 0x058a, 0x060c, 0x061b, 0x061f, - 0x098f, 0x0990, 0x09b2, 0x09bc, 0x09c7, 0x09c8, 0x09d7, 0x09dc, 0x09dd, - 0x0a02, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38, 0x0a39, - 0x0a3c, 0x0a47, 0x0a48, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0ad0, 0x0ae0, - 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b47, 0x0b48, 0x0b56, 0x0b57, 0x0b5c, - 0x0b5d, 0x0b82, 0x0b83, 0x0b99, 0x0b9a, 0x0b9c, 0x0b9e, 0x0b9f, 0x0ba3, - 0x0ba4, 0x0bd7, 0x0c55, 0x0c56, 0x0c60, 0x0c61, 0x0c82, 0x0c83, 0x0cd5, - 0x0cd6, 0x0cde, 0x0ce0, 0x0ce1, 0x0d02, 0x0d03, 0x0d57, 0x0d60, 0x0d61, - 0x0d82, 0x0d83, 0x0dbd, 0x0dca, 0x0dd6, 0x0e81, 0x0e82, 0x0e84, 0x0e87, - 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0ec6, 0x0edc, - 0x0edd, 0x0fcf, 0x1021, 0x1029, 0x102a, 0x10fb, 0x1248, 0x1258, 0x1288, - 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x274d, 0x2756, - 0x303e, 0x303f, 0xa4c6, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74 + 0x38c, 0x589, 0x58a, 0x58f, 0x85e, 0x8a0, 0x98f, 0x990, 0x9b2, + 0x9c7, 0x9c8, 0x9d7, 0x9dc, 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, + 0xa35, 0xa36, 0xa38, 0xa39, 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, + 0xab2, 0xab3, 0xad0, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, + 0xb56, 0xb57, 0xb5c, 0xb5d, 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, + 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xbd7, 0xc55, 0xc56, 0xc58, + 0xc59, 0xc82, 0xc83, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, 0xd02, + 0xd03, 0xd57, 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, + 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, + 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, + 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa9de, + 0xa9df, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd +#if TCL_UTF_MAX > 4 + ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, 0x109be, 0x109bf, + 0x10a05, 0x10a06, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, + 0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, + 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, + 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, 0x1eef0, 0x1eef1, 0x1f250, + 0x1f251, 0x1f440 +#endif }; #define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr)) /* - * Unicode: unicode print characters including space, i.e. all Letters (class - * L*), Numbers (N*), Punctuation (P*), Symbols (S*) and Spaces (Zs). - */ - -static const crange printRangeTable[] = { - {0x0020, 0x007E}, {0x00A0, 0x01F5}, {0x01FA, 0x0217}, {0x0250, 0x02A8}, - {0x02B0, 0x02DE}, {0x02E0, 0x02E9}, {0x0374, 0x0375}, {0x0384, 0x038A}, - {0x038E, 0x03A1}, {0x03A3, 0x03CE}, {0x03D0, 0x03D6}, {0x03E2, 0x03F3}, - {0x0401, 0x040C}, {0x040E, 0x044F}, {0x0451, 0x045C}, {0x045E, 0x0482}, - {0x0490, 0x04C4}, {0x04C7, 0x04C8}, {0x04CB, 0x04CC}, {0x04D0, 0x04EB}, - {0x04EE, 0x04F5}, {0x04F8, 0x04F9}, {0x0531, 0x0556}, {0x0559, 0x055F}, - {0x0561, 0x0587}, {0x05D0, 0x05EA}, {0x05F0, 0x05F4}, {0x0621, 0x063A}, - {0x0640, 0x064A}, {0x0660, 0x066D}, {0x0671, 0x06B7}, {0x06BA, 0x06BE}, - {0x06C0, 0x06CE}, {0x06D0, 0x06D5}, {0x06E5, 0x06E6}, {0x06F0, 0x06F9}, - {0x0905, 0x0939}, {0x0958, 0x0961}, {0x0964, 0x0970}, {0x0985, 0x098C}, - {0x098F, 0x0990}, {0x0993, 0x09A8}, {0x09AA, 0x09B0}, {0x09B6, 0x09B9}, - {0x09DC, 0x09DD}, {0x09DF, 0x09E1}, {0x09E6, 0x09FA}, {0x0A05, 0x0A0A}, - {0x0A0F, 0x0A10}, {0x0A13, 0x0A28}, {0x0A2A, 0x0A30}, {0x0A32, 0x0A33}, - {0x0A35, 0x0A36}, {0x0A38, 0x0A39}, {0x0A59, 0x0A5C}, {0x0A66, 0x0A6F}, - {0x0A72, 0x0A74}, {0x0A85, 0x0A8B}, {0x0A8F, 0x0A91}, {0x0A93, 0x0AA8}, - {0x0AAA, 0x0AB0}, {0x0AB2, 0x0AB3}, {0x0AB5, 0x0AB9}, {0x0AE6, 0x0AEF}, - {0x0B05, 0x0B0C}, {0x0B0F, 0x0B10}, {0x0B13, 0x0B28}, {0x0B2A, 0x0B30}, - {0x0B32, 0x0B33}, {0x0B36, 0x0B39}, {0x0B5C, 0x0B5D}, {0x0B5F, 0x0B61}, - {0x0B66, 0x0B70}, {0x0B85, 0x0B8A}, {0x0B8E, 0x0B90}, {0x0B92, 0x0B95}, - {0x0B99, 0x0B9A}, {0x0B9E, 0x0B9F}, {0x0BA3, 0x0BA4}, {0x0BA8, 0x0BAA}, - {0x0BAE, 0x0BB5}, {0x0BB7, 0x0BB9}, {0x0BE7, 0x0BF2}, {0x0C05, 0x0C0C}, - {0x0C0E, 0x0C10}, {0x0C12, 0x0C28}, {0x0C2A, 0x0C33}, {0x0C35, 0x0C39}, - {0x0C60, 0x0C61}, {0x0C66, 0x0C6F}, {0x0C85, 0x0C8C}, {0x0C8E, 0x0C90}, - {0x0C92, 0x0CA8}, {0x0CAA, 0x0CB3}, {0x0CB5, 0x0CB9}, {0x0CE0, 0x0CE1}, - {0x0CE6, 0x0CEF}, {0x0D05, 0x0D0C}, {0x0D0E, 0x0D10}, {0x0D12, 0x0D28}, - {0x0D2A, 0x0D39}, {0x0D60, 0x0D61}, {0x0D66, 0x0D6F}, {0x0E3F, 0x0E46}, - {0x0E4F, 0x0E5B}, {0x0E99, 0x0E9F}, {0x0EA1, 0x0EA3}, {0x0EAA, 0x0EAB}, - {0x0EAD, 0x0EB0}, {0x0EB2, 0x0EB3}, {0x0EC0, 0x0EC4}, {0x0ED0, 0x0ED9}, - {0x0EDC, 0x0EDD}, {0x0F00, 0x0F17}, {0x0F1A, 0x0F34}, {0x0F3A, 0x0F3D}, - {0x0F40, 0x0F47}, {0x0F49, 0x0F69}, {0x0F88, 0x0F8B}, {0x10A0, 0x10C5}, - {0x10D0, 0x10F6}, {0x1100, 0x1159}, {0x115F, 0x11A2}, {0x11A8, 0x11F9}, - {0x1E00, 0x1E9B}, {0x1EA0, 0x1EF9}, {0x1F00, 0x1F15}, {0x1F18, 0x1F1D}, - {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57}, {0x1F5F, 0x1F7D}, - {0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4}, {0x1FC6, 0x1FD3}, {0x1FD6, 0x1FDB}, - {0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFE}, {0x2000, 0x200B}, - {0x2010, 0x2027}, {0x2030, 0x2046}, {0x2074, 0x208E}, {0x20A0, 0x20AC}, - {0x2100, 0x2138}, {0x2153, 0x2182}, {0x2190, 0x21EA}, {0x2200, 0x22F1}, - {0x2302, 0x237A}, {0x2400, 0x2424}, {0x2440, 0x244A}, {0x2460, 0x24EA}, - {0x2500, 0x2595}, {0x25A0, 0x25EF}, {0x2600, 0x2613}, {0x261A, 0x266F}, - {0x2701, 0x2704}, {0x2706, 0x2709}, {0x270C, 0x2727}, {0x2729, 0x274B}, - {0x274F, 0x2752}, {0x2758, 0x275E}, {0x2761, 0x2767}, {0x2776, 0x2794}, - {0x2798, 0x27AF}, {0x27B1, 0x27BE}, {0x3000, 0x3029}, {0x3030, 0x3037}, - {0x3041, 0x3094}, {0x309B, 0x309E}, {0x30A1, 0x30FE}, {0x3105, 0x312C}, - {0x3131, 0x318E}, {0x3190, 0x319F}, {0x3200, 0x321C}, {0x3220, 0x3243}, - {0x3260, 0x327B}, {0x327F, 0x32B0}, {0x32C0, 0x32CB}, {0x32D0, 0x32FE}, - {0x3300, 0x3376}, {0x337B, 0x33DD}, {0x33E0, 0x33FE}, {0x4E00, 0x9FA5}, - {0xAC00, 0xD7A3}, {0xF900, 0xFA2D}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, - {0xFB1F, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB40, 0xFB41}, {0xFB43, 0xFB44}, - {0xFB46, 0xFBB1}, {0xFBD3, 0xFD3F}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, - {0xFDF0, 0xFDFB}, {0xFE30, 0xFE44}, {0xFE49, 0xFE52}, {0xFE54, 0xFE66}, - {0xFE68, 0xFE6B}, {0xFE70, 0xFE72}, {0xFE76, 0xFEFC}, {0xFF01, 0xFF5E}, - {0xFF61, 0xFFBE}, {0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, - {0xFFDA, 0xFFDC}, {0xFFE0, 0xFFE6}, {0xFFE8, 0xFFEE}, {0xFFFC, 0xFFFD} -}; - -#define NUM_PRINT_RANGE (sizeof(printRangeTable)/sizeof(crange)) - -static const chr printCharTable[] = { - 0x037A, 0x037E, 0x038C, 0x03DA, 0x03DC, 0x03DE, 0x03E0, 0x0589, 0x05BE, - 0x05C0, 0x05C3, 0x060C, 0x061B, 0x061F, 0x06E9, 0x093D, 0x0950, 0x09B2, - 0x0A5E, 0x0A8D, 0x0ABD, 0x0AD0, 0x0AE0, 0x0B3D, 0x0B9C, 0x0CDE, 0x0E01, - 0x0E32, 0x0E81, 0x0E84, 0x0E87, 0x0E8A, 0x0E8D, 0x0E94, 0x0EA5, 0x0EA7, - 0x0EBD, 0x0EC6, 0x0F36, 0x0F38, 0x0F85, 0x10FB, 0x1F59, 0x1F5B, 0x1F5D, - 0x2070, 0x2300, 0x274D, 0x2756, 0x303F, 0xFB3E, 0xFE74 -}; - -#define NUM_PRINT_CHAR (sizeof(printCharTable)/sizeof(chr)) - -/* * End of auto-generated Unicode character ranges declarations. */ @@ -817,15 +921,6 @@ cclass( np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); /* - * Remap lower and upper to alpha if the match is case insensitive. - */ - - if (cases && len == 5 && (strncmp("lower", np, 5) == 0 - || strncmp("upper", np, 5) == 0)) { - np = "alpha"; - } - - /* * Map the name to the corresponding enumerated value. */ @@ -843,22 +938,18 @@ cclass( } /* + * Remap lower and upper to alpha if the match is case insensitive. + */ + + if (cases && ((index == CC_LOWER) || (index == CC_UPPER))) { + index = CC_ALNUM; + } + + /* * Now compute the character class contents. */ switch((enum classes) index) { - case CC_PRINT: - cv = getcvec(v, NUM_PRINT_CHAR, NUM_PRINT_RANGE); - if (cv) { - for (i=0 ; (size_t)i<NUM_PRINT_CHAR ; i++) { - addchr(cv, printCharTable[i]); - } - for (i=0 ; (size_t)i<NUM_PRINT_RANGE ; i++) { - addrange(cv, printRangeTable[i].start, - printRangeTable[i].end); - } - } - break; case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { @@ -899,9 +990,16 @@ cclass( addchr(cv, ' '); break; case CC_CNTRL: - cv = getcvec(v, 0, 2); - addrange(cv, 0x0, 0x1f); - addrange(cv, 0x7f, 0x9f); + cv = getcvec(v, NUM_CONTROL_CHAR, NUM_CONTROL_RANGE); + if (cv) { + for (i=0 ; (size_t)i<NUM_CONTROL_RANGE ; i++) { + addrange(cv, controlRangeTable[i].start, + controlRangeTable[i].end); + } + for (i=0 ; (size_t)i<NUM_CONTROL_CHAR ; i++) { + addchr(cv, controlCharTable[i]); + } + } break; case CC_DIGIT: cv = getcvec(v, 0, NUM_DIGIT_RANGE); @@ -977,6 +1075,25 @@ cclass( } } break; + case CC_PRINT: + cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1); + if (cv) { + for (i=1 ; (size_t)i<NUM_SPACE_RANGE ; i++) { + addrange(cv, spaceRangeTable[i].start, + spaceRangeTable[i].end); + } + for (i=0 ; (size_t)i<NUM_SPACE_CHAR ; i++) { + addchr(cv, spaceCharTable[i]); + } + for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) { + addrange(cv, graphRangeTable[i].start, + graphRangeTable[i].end); + } + for (i=0 ; (size_t)i<NUM_GRAPH_CHAR ; i++) { + addchr(cv, graphCharTable[i]); + } + } + break; case CC_GRAPH: cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE); if (cv) { diff --git a/generic/regcomp.c b/generic/regcomp.c index 9753ca4..65555aa 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -79,7 +79,7 @@ static void lexnest(struct vars *, const chr *, const chr *); static void lexword(struct vars *); static int next(struct vars *); static int lexescape(struct vars *); -static chr lexdigits(struct vars *, int, int, int); +static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); static chr newline(NOPARMS); @@ -2131,7 +2131,7 @@ stdump( /* - stid - identify a subtree node for dumping - ^ static char *stid(struct subre *, char *, size_t); + ^ static const char *stid(struct subre *, char *, size_t); */ static const char * /* points to buf or constant string */ stid( diff --git a/generic/regcustom.h b/generic/regcustom.h index bc8c28c..1c970ea 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -97,7 +97,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ -#if TCL_UTF_MAX > 3 +#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 */ diff --git a/generic/tcl.decls b/generic/tcl.decls index f7c5d4f..1829249 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,8 +11,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tcl.decls,v 1.181 2010/09/15 07:33:54 nijtmans Exp $ library tcl @@ -62,7 +60,7 @@ declare 8 { } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix, -# but they are part of the old interface, so we include them here for +# but they are part of the old generic interface, so we include them here for # compatibility reasons. declare 9 unix { @@ -598,7 +596,7 @@ declare 166 { } # Tcl_GetOpenFile is only available on unix, but it is a part of the old -# interface, so we inlcude it here for compatibility reasons. +# generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, @@ -777,10 +775,10 @@ declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { - int Tcl_ScanElement(const char *str, int *flagPtr) + int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { - int Tcl_ScanCountedElement(const char *str, int length, int *flagPtr) + int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } # Obsolete declare 220 { @@ -2313,13 +2311,19 @@ declare 627 { Tcl_LoadHandle *handlePtr) } declare 628 { - void* Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, + void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol) } declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +# TIP #400 +declare 630 { + void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) +} + # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## @@ -2367,6 +2371,14 @@ export { void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { + const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, + int exact) +} +export { + const char *TclTomMathInitializeStubs(Tcl_Interp* interp, + const char* version, int epoch, int revision) +} +export { const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tcl.h b/generic/tcl.h index 76e7c86..3003abf 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tcl.h,v 1.308 2010/08/14 20:58:30 nijtmans Exp $ */ #ifndef _TCL @@ -53,17 +51,15 @@ extern "C" { * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) - * tools/tcl.wse.in (for windows installer) - * tools/tclSplash.bmp (not patchlevel) */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 -#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -#define TCL_RELEASE_SERIAL 1 +#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE +#define TCL_RELEASE_SERIAL 0 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6b1.2" +#define TCL_PATCH_LEVEL "8.6.0" /* *---------------------------------------------------------------------------- @@ -158,6 +154,28 @@ extern "C" { # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +#else +# define TCL_FORMAT_PRINTF(a,b) +#endif + +/* + * Allow a part of Tcl's API to be explicitly marked as deprecated. + * + * Used to make TIP 330/336 generate moans even if people use the + * compatibility macros. Change your code, guys! We won't support you forever. + */ + +#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) +# else +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) +# endif +#else +# define TCL_DEPRECATED_API(msg) /* nothing portable */ +#endif /* *---------------------------------------------------------------------------- @@ -370,28 +388,17 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# if defined(__WIN32__) && !defined(__CYGWIN__) -# define TCL_LL_MODIFIER "I64" -# else -# define TCL_LL_MODIFIER "ll" -# endif -typedef struct stat Tcl_StatBuf; -# elif defined(__WIN32__) +# if defined(__WIN32__) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ -typedef struct stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "L" # else /* __BORLANDC__ */ -# if _MSC_VER < 1400 || !defined(_M_IX86) -typedef struct _stati64 Tcl_StatBuf; -# else -typedef struct _stat64 Tcl_StatBuf; -# endif /* _MSC_VER < 1400 */ # define TCL_LL_MODIFIER "I64" # endif /* __BORLANDC__ */ -# else /* __WIN32__ */ +# elif defined(__GNUC__) +# define TCL_WIDE_INT_TYPE long long +# define TCL_LL_MODIFIER "ll" +# else /* ! __WIN32__ && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... @@ -417,7 +424,6 @@ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifdef TCL_WIDE_INT_IS_LONG -typedef struct stat Tcl_StatBuf; # define Tcl_WideAsLong(val) ((long)(val)) # define Tcl_LongAsWide(val) ((long)(val)) # define Tcl_WideAsDouble(val) ((double)((long)(val))) @@ -431,11 +437,6 @@ typedef struct stat Tcl_StatBuf; * or some other strange platform. */ # ifndef TCL_LL_MODIFIER -# ifdef HAVE_STRUCT_STAT64 -typedef struct stat64 Tcl_StatBuf; -# else -typedef struct stat Tcl_StatBuf; -# endif /* HAVE_STRUCT_STAT64 */ # define TCL_LL_MODIFIER "ll" # endif /* !TCL_LL_MODIFIER */ # define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) @@ -443,6 +444,39 @@ typedef struct stat Tcl_StatBuf; # define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ + +#if defined(__WIN32__) +# ifdef __BORLANDC__ + typedef struct stati64 Tcl_StatBuf; +# elif defined(_WIN64) + typedef struct __stat64 Tcl_StatBuf; +# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T) + typedef struct _stati64 Tcl_StatBuf; +# else + typedef struct _stat32i64 Tcl_StatBuf; +# endif /* _MSC_VER < 1400 */ +#elif defined(__CYGWIN__) + typedef struct _stat32i64 { + dev_t st_dev; + unsigned short st_ino; + unsigned short st_mode; + short st_nlink; + short st_uid; + short st_gid; + /* Here is a 2-byte gap */ + dev_t st_rdev; + /* Here is a 4-byte gap */ + long long st_size; + struct {long tv_sec;} st_atim; + struct {long tv_sec;} st_mtim; + struct {long tv_sec;} st_ctim; + /* Here is a 4-byte gap */ + } Tcl_StatBuf; +#elif defined(HAVE_STRUCT_STAT64) + typedef struct stat64 Tcl_StatBuf; +#else + typedef struct stat Tcl_StatBuf; +#endif /* *---------------------------------------------------------------------------- @@ -464,13 +498,17 @@ typedef struct stat Tcl_StatBuf; * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp { +typedef struct Tcl_Interp +#ifndef TCL_NO_DEPRECATED +{ /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT - char *result; /* If the last command returned a string + char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); + /* If the last command returned a string * result, this points to it. */ - void (*freeProc) (char *blockPtr); + void (*freeProc) (char *blockPtr) + TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); /* Zero means the string result is statically * allocated. TCL_DYNAMIC means it was * allocated with ckalloc and should be freed @@ -479,17 +517,20 @@ typedef struct Tcl_Interp { * Tcl_Eval must free it before executing next * command. */ #else - char *unused3; - void (*unused4) (char *); + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ #endif #ifdef USE_INTERP_ERRORLINE - int errorLine; /* When TCL_ERROR is returned, this gives the + 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 unused5; + int errorLineDontUse; /* Don't use in extensions! */ #endif -} Tcl_Interp; +} +#endif /* TCL_NO_DEPRECATED */ +Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; @@ -796,11 +837,14 @@ typedef struct Tcl_Obj { void *ptr1; void *ptr2; } twoPtrValue; - struct { /* - internal rep as a wide int, tightly - * packed fields. */ - void *ptr; /* Pointer to digits. */ - unsigned long value;/* Alloc, used, and signum packed into a - * single word. */ + struct { /* - internal rep as a pointer and a long, + * the main use of which is a bignum's + * tightly packed fields, where the alloc, + * used and signum flags are packed into a + * single word with everything else hung + * off the pointer. */ + void *ptr; + unsigned long value; } ptrAndLongRep; } internalRep; } Tcl_Obj; @@ -810,10 +854,7 @@ typedef struct Tcl_Obj { * whether an object is shared (i.e. has reference count > 1). Note: clients * should use Tcl_DecrRefCount() when they are finished using an object, and * should never call TclFreeObj() directly. TclFreeObj() is only defined and - * made public in tcl.h to support Tcl_DecrRefCount's macro definition. Note - * also that Tcl_DecrRefCount() refers to the parameter "obj" twice. This - * means that you should avoid calling it with an expression that is expensive - * to compute or has side effects. + * made public in tcl.h to support Tcl_DecrRefCount's macro definition. */ void Tcl_IncrRefCount(Tcl_Obj *objPtr); @@ -987,8 +1028,6 @@ typedef struct Tcl_DString { * is safe to leave the hash unquoted when the element is not the first * element of a list, and this flag can be used by the caller to indicate * that condition. - * (Careful! If you change these flag values be sure to change the definitions - * at the front of tclUtil.c). */ #define TCL_DONT_USE_BRACES 1 @@ -1165,7 +1204,7 @@ struct Tcl_HashEntry { int words[1]; /* Multiple integer words for key. The actual * size will be as large as necessary for this * table's keys. */ - char string[4]; /* String for key. The actual size will be as + char string[1]; /* String for key. The actual size will be as * large as needed to hold the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ }; @@ -2147,12 +2186,12 @@ 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 or 6 (or perhaps 1 - * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar - * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must - * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and - * recommended mode. UCS-4 is experimental and not recommended. It works for - * the core, but most extensions expect UCS-2. + * Unicode character in UTF-8. The valid values should be 3, 4 or 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or + * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode + * is the default and recommended mode. UCS-4 is experimental and not + * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX @@ -2164,7 +2203,7 @@ typedef struct Tcl_EncodingType { * reflected in regcustom.h. */ -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 /* * unsigned int isn't 100% accurate as it should be a strict 4-byte value * (perhaps wchar_t). 64-bit systems may have troubles. The size of this @@ -2270,12 +2309,12 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, #define TCL_ARGV_AUTO_HELP \ {TCL_ARGV_HELP, "-help", NULL, NULL, \ - "Print summary of command-line options and abort"} + "Print summary of command-line options and abort", NULL} #define TCL_ARGV_AUTO_REST \ {TCL_ARGV_REST, "--", NULL, NULL, \ - "Marks the end of the options"} + "Marks the end of the options", NULL} #define TCL_ARGV_TABLE_END \ - {TCL_ARGV_END} + {TCL_ARGV_END, NULL, NULL, NULL, NULL, NULL} /* *---------------------------------------------------------------------------- @@ -2320,6 +2359,14 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, /* *---------------------------------------------------------------------------- + * Definitions needed for the Tcl_LoadFile function. [TIP #416] + */ + +#define TCL_LOAD_GLOBAL 1 +#define TCL_LOAD_LAZY 2 + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ @@ -2367,8 +2414,10 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ -EXTERN void Tcl_Main(int argc, char **argv, - Tcl_AppInitProc *appInitProc); +#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ + (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)())) +EXTERN void Tcl_MainEx(int argc, char **argv, + Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) @@ -2399,11 +2448,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #ifdef TCL_MEM_DEBUG -# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) -# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__) -# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__) +# define ckalloc(x) \ + ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define ckfree(x) \ + Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) +# define ckrealloc(x,y) \ + ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) +# define attemptckalloc(x) \ + ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define attemptckrealloc(x,y) \ + ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) #else /* !TCL_MEM_DEBUG */ @@ -2413,11 +2467,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); * memory allocator both inside and outside of the Tcl library. */ -# define ckalloc(x) Tcl_Alloc(x) -# define ckfree(x) Tcl_Free(x) -# define ckrealloc(x,y) Tcl_Realloc(x,y) -# define attemptckalloc(x) Tcl_AttemptAlloc(x) -# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y) +# define ckalloc(x) \ + ((VOID *) Tcl_Alloc((unsigned)(x))) +# define ckfree(x) \ + Tcl_Free((char *)(x)) +# define ckrealloc(x,y) \ + ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y))) +# define attemptckalloc(x) \ + ((VOID *) Tcl_AttemptAlloc((unsigned)(x))) +# define attemptckrealloc(x,y) \ + ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory @@ -2442,7 +2501,12 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); * http://c2.com/cgi/wiki?TrivialDoWhileLoop */ # define Tcl_DecrRefCount(objPtr) \ - do { if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr); } while(0) + do { \ + Tcl_Obj *_objPtr = (objPtr); \ + if (--(_objPtr)->refCount <= 0) { \ + TclFreeObj(_objPtr); \ + } \ + } while(0) # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index ebb6898..ae61e85 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -14,8 +14,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclAlloc.c,v 1.30 2010/04/28 11:50:54 nijtmans Exp $ */ /* @@ -28,12 +26,6 @@ #if USE_TCLALLOC -#ifdef TCL_DEBUG -# define DEBUG -/* #define MSTATS */ -# define RCHECK -#endif - /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. @@ -62,7 +54,7 @@ union overhead { unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ -#ifdef RCHECK +#ifndef NDEBUG unsigned short rmagic; /* range magic number */ unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ @@ -79,7 +71,7 @@ union overhead { #define MAGIC 0xef /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ -#ifdef RCHECK +#ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else #define RSLOP 0 @@ -144,7 +136,7 @@ static int allocInit = 0; static unsigned int numMallocs[NBUCKETS+1]; #endif -#if defined(DEBUG) || defined(RCHECK) +#if !defined(NDEBUG) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else @@ -301,7 +293,7 @@ TclpAlloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -359,7 +351,7 @@ TclpAlloc( numMallocs[bucket]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -579,7 +571,7 @@ TclpRealloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and update magic number bounds. */ @@ -621,7 +613,7 @@ TclpRealloc( * Ok, we don't have to copy, it fits as-is */ -#ifdef RCHECK +#ifndef NDEBUG overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif @@ -704,7 +696,7 @@ char * TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { - return (char*) malloc(numBytes); + return (char *) malloc(numBytes); } /* @@ -752,7 +744,7 @@ TclpRealloc( char *oldPtr, /* Pointer to alloced block. */ unsigned int numBytes) /* New size of memory. */ { - return (char*) realloc(oldPtr, numBytes); + return (char *) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c new file mode 100644 index 0000000..7833105 --- /dev/null +++ b/generic/tclAssembly.c @@ -0,0 +1,4357 @@ +/* + * tclAssembly.c -- + * + * Assembler for Tcl bytecodes. + * + * This file contains the procedures that convert Tcl Assembly Language (TAL) + * to a sequence of bytecode instructions for the Tcl execution engine. + * + * Copyright (c) 2010 by Ozgur Dogan Ugurlu. + * Copyright (c) 2010 by Kevin B. Kenny. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/*- + *- THINGS TO DO: + *- More instructions: + *- done - alternate exit point (affects stack and exception range checking) + *- break and continue - if exception ranges can be sorted out. + *- foreach_start4, foreach_step4 + *- returnImm, returnStk + *- expandStart, expandStkTop, invokeExpanded + *- dictFirst, dictNext, dictDone + *- dictUpdateStart, dictUpdateEnd + *- jumpTable testing + *- syntax (?) + *- returnCodeBranch + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOOInt.h" + +/* + * Structure that represents a range of instructions in the bytecode. + */ + +typedef struct CodeRange { + int startOffset; /* Start offset in the bytecode array */ + int endOffset; /* End offset in the bytecode array */ +} CodeRange; + +/* + * State identified for a basic block's catch context. + */ + +typedef enum BasicBlockCatchState { + BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ + BBCS_NONE, /* Block is outside of any catch */ + BBCS_INCATCH, /* Block is within a catch context */ + BBCS_CAUGHT, /* Block is within a catch context and + * may be executed after an exception fires */ +} BasicBlockCatchState; + +/* + * Structure that defines a basic block - a linear sequence of bytecode + * instructions with no jumps in or out (including not changing the + * state of any exception range). + */ + +typedef struct BasicBlock { + int originalStartOffset; /* Instruction offset before JUMP1s were + * substituted with JUMP4's */ + int startOffset; /* Instruction offset of the start of the + * block */ + int startLine; /* Line number in the input script of the + * instruction at the start of the block */ + int jumpOffset; /* Bytecode offset of the 'jump' instruction + * that ends the block, or -1 if there is no + * jump. */ + int jumpLine; /* Line number in the input script of the + * 'jump' instruction that ends the block, or + * -1 if there is no jump */ + struct BasicBlock* prevPtr; /* Immediate predecessor of this block */ + struct BasicBlock* predecessor; + /* Predecessor of this block in the spanning + * tree */ + struct BasicBlock* successor1; + /* BasicBlock structure of the following + * block: NULL at the end of the bytecode + * sequence. */ + Tcl_Obj* jumpTarget; /* Jump target label if the jump target is + * unresolved */ + int initialStackDepth; /* Absolute stack depth on entry */ + int minStackDepth; /* Low-water relative stack depth */ + int maxStackDepth; /* High-water relative stack depth */ + int finalStackDepth; /* Relative stack depth on exit */ + enum BasicBlockCatchState catchState; + /* State of the block for 'catch' analysis */ + int catchDepth; /* Number of nested catches in which the basic + * block appears */ + struct BasicBlock* enclosingCatch; + /* BasicBlock structure of the last startCatch + * executed on a path to this block, or NULL + * if there is no enclosing catch */ + int foreignExceptionBase; /* Base index of foreign exceptions */ + int foreignExceptionCount; /* Count of foreign exceptions */ + ExceptionRange* foreignExceptions; + /* ExceptionRange structures for exception + * ranges belonging to embedded scripts and + * expressions in this block */ + JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ + int flags; /* Boolean flags */ +} BasicBlock; + +/* + * Flags that pertain to a basic block. + */ + +enum BasicBlockFlags { + BB_VISITED = (1 << 0), /* Block has been visited in the current + * traversal */ + BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a + * successor */ + BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump + * and may need expansion */ + BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ + BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, + * marking it as the start of a 'catch' + * sequence. The 'jumpTarget' is the exception + * exit from the catch block. */ + BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction, + * unwinding the catch from the exception + * stack. */ +}; + +/* + * Source instruction type recognized by the assembler. + */ + +typedef enum TalInstType { + ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ + ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be + * converted to appropriate exception + * ranges */ + ASSEM_BOOL, /* One Boolean operand */ + ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ + ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must + * be strictly positive, consumes N, produces + * 1 */ + ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 + * operands, produces 1, N > 0 */ + ASSEM_DICT_SET, /* specifies key count and LVT index, consumes + * N+1 operands, produces 1, N > 0 */ + ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes + * N operands, produces 1, N > 0 */ + ASSEM_END_CATCH, /* End catch. No args. Exception range popped + * from stack and stack pointer restored. */ + ASSEM_EVAL, /* 'eval' - evaluate a constant script (by + * compiling it in line with the assembly + * code! I love Tcl!) */ + ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ + ASSEM_INVOKE, /* 1- or 4-byte operand count, must be + * strictly positive, consumes N, produces + * 1. */ + ASSEM_JUMP, /* Jump instructions */ + ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ + ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ + ASSEM_LABEL, /* The assembly directive that defines a + * label */ + ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly + * positive, consumes N, produces 1 */ + ASSEM_LIST, /* 4-byte operand count, must be nonnegative, + * consumses N, produces 1 */ + ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, + * consumes N, produces 1 */ + ASSEM_LVT, /* One operand that references a local + * variable */ + ASSEM_LVT1, /* One 1-byte operand that references a local + * variable */ + ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local + * variable, one signed-integer 1-byte + * operand */ + ASSEM_LVT4, /* One 4-byte operand that references a local + * variable */ + ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, + * produces N+2 */ + ASSEM_PUSH, /* one literal operand */ + ASSEM_REGEXP, /* One Boolean operand, but weird mapping to + * call flags */ + ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, + * produces N */ + ASSEM_SINT1, /* One 1-byte signed-integer operand + * (INCR_STK_IMM) */ + ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by + * LVT entry. Fixed arity */ +} TalInstType; + +/* + * Description of an instruction recognized by the assembler. + */ + +typedef struct TalInstDesc { + const char *name; /* Name of instruction. */ + TalInstType instType; /* The type of instruction */ + int tclInstCode; /* Instruction code. For instructions having + * 1- and 4-byte variables, tclInstCode is + * ((1byte)<<8) || (4byte) */ + int operandsConsumed; /* Number of operands consumed by the + * operation, or INT_MIN if the operation is + * variadic */ + int operandsProduced; /* Number of operands produced by the + * operation. If negative, the operation has a + * net stack effect of -1-operandsProduced */ +} TalInstDesc; + +/* + * Structure that holds the state of the assembler while generating code. + */ + +typedef struct AssemblyEnv { + CompileEnv* envPtr; /* Compilation environment being used for code + * generation */ + Tcl_Parse* parsePtr; /* Parse of the current line of source */ + Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose + * values are 'label' objects storing the code + * offsets of the labels. */ + int cmdLine; /* Current line number within the assembly + * code */ + int* clNext; /* Invisible continuation line for + * [info frame] */ + BasicBlock* head_bb; /* First basic block in the code */ + BasicBlock* curr_bb; /* Current basic block */ + int maxDepth; /* Maximum stack depth encountered */ + int curCatchDepth; /* Current depth of catches */ + int maxCatchDepth; /* Maximum depth of catches encountered */ + int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ +} AssemblyEnv; + +/* + * Static functions defined in this file. + */ + +static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, + BasicBlock*); +static BasicBlock * AllocBB(AssemblyEnv*); +static int AssembleOneLine(AssemblyEnv* envPtr); +static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, + int produced); +static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx, + int count); +static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, + int opnd, int count); +static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, + int opnd, int count); +static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, + int param, int count); +static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, + int count); +static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); +static int CalculateJumpRelocations(AssemblyEnv*, int*); +static int CheckForUnclosedCatches(AssemblyEnv*); +static int CheckForThrowInWrongContext(AssemblyEnv*); +static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); +static int BytecodeMightThrow(unsigned char); +static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); +static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, + int); +static int CheckNonNegative(Tcl_Interp*, int); +static int CheckOneByte(Tcl_Interp*, int); +static int CheckSignedOneByte(Tcl_Interp*, int); +static int CheckStack(AssemblyEnv*); +static int CheckStrictlyPositive(Tcl_Interp*, int); +static ByteCode * CompileAssembleObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +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*); +static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); +static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); +static void LookForFreshCatches(BasicBlock*, BasicBlock**); +static void MoveCodeForJumps(AssemblyEnv*, int); +static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, + int); +static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); +static int ProcessCatches(AssemblyEnv*); +static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, + BasicBlock*, enum BasicBlockCatchState, int); +static void ResetVisitedBasicBlocks(AssemblyEnv*); +static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); +static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, + Tcl_Obj*); +static void RestoreEmbeddedExceptionRanges(AssemblyEnv*); +static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, + BasicBlock *, int); +static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough, + Tcl_Obj* jumpLabel); +/* static int AdvanceIp(const unsigned char *pc); */ +static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, + BasicBlock *, int); +static int StackCheckExit(AssemblyEnv*); +static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, + BasicBlock**, int*); +static void SyncStackDepth(AssemblyEnv*); +static int TclAssembleCode(CompileEnv* envPtr, const char* code, + int codeLen, int flags); +static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, + BasicBlock**, int*); + +/* + * Tcl_ObjType that describes bytecode emitted by the assembler. + */ + +static const Tcl_ObjType assembleCodeType = { + "assemblecode", + FreeAssembleCodeInternalRep, /* freeIntRepProc */ + DupAssembleCodeInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +/* + * Flags bits used by PushVarName. + */ + +#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ + +/* + * Source instructions recognized in the Tcl Assembly Language (TAL) + */ + +static const TalInstDesc TalInstructionTable[] = { + /* PUSH must be first, see the code near the end of TclAssembleCode */ + {"push", ASSEM_PUSH, (INST_PUSH1<<8 + | INST_PUSH4), 0, 1}, + + {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, + {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 + | INST_APPEND_SCALAR4),1, 1}, + {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 + | INST_APPEND_ARRAY4), 2, 1}, + {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, + {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, + {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, + {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, + {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, + {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, + {"beginCatch", ASSEM_BEGIN_CATCH, + INST_BEGIN_CATCH4, 0, 0}, + {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, + {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, + {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, + {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, + {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, + {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, + {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, + {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, + {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, + {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictIncrImm", ASSEM_SINT4_LVT4, + INST_DICT_INCR_IMM, 1, 1}, + {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, + {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, + {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, + {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, + {"dictUnset", ASSEM_DICT_UNSET, + INST_DICT_UNSET, INT_MIN,1}, + {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, + {"dup", ASSEM_1BYTE, INST_DUP, 1, 2}, + {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0}, + {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, + {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, + {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, + {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, + {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, + {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, + {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, + {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, + {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1}, + {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, + {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, + {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, + {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, + {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, + {"incrArrayImm", ASSEM_LVT1_SINT1, + INST_INCR_ARRAY1_IMM, 1, 1}, + {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, + {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, + {"incrImm", ASSEM_LVT1_SINT1, + INST_INCR_SCALAR1_IMM, 0, 1}, + {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, + {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, + 1, 1}, + {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, + {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, + {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 + | INST_INVOKE_STK4), INT_MIN,1}, + {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, + {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, + {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, + {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, + {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, + {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, + {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, + {"label", ASSEM_LABEL, 0, 0, 0}, + {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, + {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 + | INST_LAPPEND_SCALAR4), + 1, 1}, + {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 + | INST_LAPPEND_ARRAY4),2, 1}, + {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, + {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, + {"le", ASSEM_1BYTE, INST_LE, 2, 1}, + {"lindexMulti", ASSEM_LINDEX_MULTI, + INST_LIST_INDEX_MULTI, INT_MIN,1}, + {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, + {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, + {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, + {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, + {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, + {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, + {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 + | INST_LOAD_SCALAR4), 0, 1}, + {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 + | INST_LOAD_ARRAY4), 1, 1}, + {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, + {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1}, + {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, + {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, + {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, + {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, + {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, + {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, + {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, + {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, + {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, + {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, + {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, + {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, + {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, + {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, + 0, 1}, + {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, + {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, + {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, + {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, + {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, + {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 + | INST_STORE_SCALAR4), 1, 1}, + {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 + | INST_STORE_ARRAY4), 2, 1}, + {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, + {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1}, + {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, + {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, + {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, + {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, + {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, + {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, + {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, + {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, + {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, + {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, + {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, + {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, + {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, + {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, + {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, + {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0}, + {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, + {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, + {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, + {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, + {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, + {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, + {NULL, 0, 0, 0, 0} +}; + +/* + * List of instructions that cannot throw an exception under any + * circumstances. These instructions are the ones that are permissible after + * an exception is caught but before the corresponding exception range is + * popped from the stack. + * The instructions must be in ascending order by numeric operation code. + */ + +static const unsigned char NonThrowingByteCodes[] = { + INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ + INST_JUMP1, INST_JUMP4, /* 34-35 */ + INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_OVER, /* 95 */ + INST_PUSH_RETURN_OPTIONS, /* 108 */ + INST_REVERSE, /* 126 */ + INST_NOP, /* 132 */ + INST_STR_MAP, /* 143 */ + INST_STR_FIND, /* 144 */ + INST_COROUTINE_NAME, /* 149 */ + INST_NS_CURRENT, /* 151 */ + INST_INFO_LEVEL_NUM, /* 152 */ + INST_RESOLVE_COMMAND /* 154 */ +}; + +/* + * Helper macros. + */ + +#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 +#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr) +#elif defined(__GNUC__) && __GNUC__ > 2 +#define DEBUG_PRINT(...) /* nothing */ +#else +#define DEBUG_PRINT /* nothing */ +#endif + +/* + *----------------------------------------------------------------------------- + * + * BBAdjustStackDepth -- + * + * When an opcode is emitted, adjusts the stack information in the basic + * block to reflect the number of operands produced and consumed. + * + * Results: + * None. + * + * Side effects: + * Updates minimum, maximum and final stack requirements in the basic + * block. + * + *----------------------------------------------------------------------------- + */ + +static void +BBAdjustStackDepth( + BasicBlock *bbPtr, /* Structure describing the basic block */ + int consumed, /* Count of operands consumed by the + * operation */ + int produced) /* Count of operands produced by the + * operation */ +{ + int depth = bbPtr->finalStackDepth; + + depth -= consumed; + if (depth < bbPtr->minStackDepth) { + bbPtr->minStackDepth = depth; + } + depth += produced; + if (depth > bbPtr->maxStackDepth) { + bbPtr->maxStackDepth = depth; + } + bbPtr->finalStackDepth = depth; +} + +/* + *----------------------------------------------------------------------------- + * + * BBUpdateStackReqs -- + * + * Updates the stack requirements of a basic block, given the opcode + * being emitted and an operand count. + * + * Results: + * None. + * + * Side effects: + * Updates min, max and final stack requirements in the basic block. + * + * Notes: + * This function must not be called for instructions such as REVERSE and + * OVER that are variadic but do not consume all their operands. Instead, + * BBAdjustStackDepth should be called directly. + * + * count should be provided only for variadic operations. For operations + * with known arity, count should be 0. + * + *----------------------------------------------------------------------------- + */ + +static void +BBUpdateStackReqs( + BasicBlock* bbPtr, /* Structure describing the basic block */ + int tblIdx, /* Index in TalInstructionTable of the + * operation being assembled */ + int count) /* Count of operands for variadic insts */ +{ + int consumed = TalInstructionTable[tblIdx].operandsConsumed; + int produced = TalInstructionTable[tblIdx].operandsProduced; + + if (consumed == INT_MIN) { + /* + * The instruction is variadic; it consumes 'count' operands. + */ + + consumed = count; + } + if (produced < 0) { + /* + * The instruction leaves some of its variadic operands on the stack, + * with net stack effect of '-1-produced' + */ + + produced = consumed - produced - 1; + } + BBAdjustStackDepth(bbPtr, consumed, produced); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- + * + * Emit the opcode part of an instruction, or the entirety of an + * instruction with a 1- or 4-byte operand, and adjust stack + * requirements. + * + * Results: + * None. + * + * Side effects: + * Stores instruction and operand in the operand stream, and adjusts the + * stack. + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitOpcode( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Table index in TalInstructionTable of op */ + int count) /* Operand count for variadic ops */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + int op = TalInstructionTable[tblIdx].tclInstCode & 0xff; + + /* + * If this is the first instruction in a basic block, record its line + * number. + */ + + if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { + bbPtr->startLine = assemEnvPtr->cmdLine; + } + + TclEmitInt1(op, envPtr); + envPtr->atCmdStart = ((op) == INST_START_CMD); + BBUpdateStackReqs(bbPtr, tblIdx, count); +} + +static void +BBEmitInstInt1( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int opnd, /* 1-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(assemEnvPtr, tblIdx, count); + TclEmitInt1(opnd, assemEnvPtr->envPtr); +} + +static void +BBEmitInstInt4( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int opnd, /* 4-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(assemEnvPtr, tblIdx, count); + TclEmitInt4(opnd, assemEnvPtr->envPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitInst1or4 -- + * + * Emits a 1- or 4-byte operation according to the magnitude of the + * operand + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitInst1or4( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int param, /* Variable-length parameter */ + int count) /* Arity if variadic */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + int op = TalInstructionTable[tblIdx].tclInstCode; + + if (param <= 0xff) { + op >>= 8; + } else { + op &= 0xff; + } + TclEmitInt1(op, envPtr); + if (param <= 0xff) { + TclEmitInt1(param, envPtr); + } else { + TclEmitInt4(param, envPtr); + } + envPtr->atCmdStart = ((op) == INST_START_CMD); + BBUpdateStackReqs(bbPtr, tblIdx, count); +} + +/* + *----------------------------------------------------------------------------- + * + * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- + * + * Direct evaluation path for tcl::unsupported::assemble + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Assembles the code in objv[1], and executes it, so side effects + * include whatever the code does. + * + *----------------------------------------------------------------------------- + */ + +int +Tcl_AssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* + * Boilerplate - make sure that there is an NRE trampoline on the C stack + * because there needs to be one in place to execute bytecode. + */ + + return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); +} + +int +TclNRAssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + ByteCode *codePtr; /* Pointer to the bytecode to execute */ + Tcl_Obj* backtrace; /* Object where extra error information is + * constructed. */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); + return TCL_ERROR; + } + + /* + * Assemble the source to bytecode. + */ + + codePtr = CompileAssembleObj(interp, objv[1]); + + /* + * On failure, report error line. + */ + + if (codePtr == NULL) { + Tcl_AddErrorInfo(interp, "\n (\""); + Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0])); + Tcl_AddErrorInfo(interp, "\" body, line "); + backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); + Tcl_IncrRefCount(backtrace); + Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace)); + Tcl_DecrRefCount(backtrace); + Tcl_AddErrorInfo(interp, ")"); + return TCL_ERROR; + } + + /* + * Use NRE to evaluate the bytecode from the trampoline. + */ + + return TclNRExecuteByteCode(interp, codePtr); +} + +/* + *----------------------------------------------------------------------------- + * + * CompileAssembleObj -- + * + * Sets up and assembles Tcl bytecode for the direct-execution path in + * the Tcl bytecode assembler. + * + * Results: + * Returns a pointer to the assembled code. Returns NULL if the assembly + * fails for any reason, with an appropriate error message in the + * interpreter. + * + *----------------------------------------------------------------------------- + */ + +static ByteCode * +CompileAssembleObj( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Source code to assemble */ +{ + Interp *iPtr = (Interp *) interp; + /* Internals of the interpreter */ + CompileEnv compEnv; /* Compilation environment structure */ + register ByteCode *codePtr = NULL; + /* Bytecode resulting from the assembly */ + register const AuxData * auxDataPtr; + /* Pointer to an auxiliary data element + * in a compilation environment being + * destroyed. */ + Namespace* namespacePtr; /* Namespace in which variable and command + * names in the bytecode resolve */ + int status; /* Status return from Tcl_AssembleCode */ + const char* source; /* String representation of the source code */ + int sourceLen; /* Length of the source code in bytes */ + int i; + + + /* + * Get the expression ByteCode from the object. If it exists, make sure it + * is valid in the current context. + */ + + if (objPtr->typePtr == &assembleCodeType) { + namespacePtr = iPtr->varFramePtr->nsPtr; + codePtr = objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle == iPtr) + && (codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsPtr == namespacePtr) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch) + && (codePtr->localCachePtr + == iPtr->varFramePtr->localCachePtr)) { + return codePtr; + } + + /* + * Not valid, so free it and regenerate. + */ + + FreeAssembleCodeInternalRep(objPtr); + } + + /* + * Set up the compilation environment, and assemble the code. + */ + + source = TclGetStringFromObj(objPtr, &sourceLen); + TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0); + status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); + if (status != TCL_OK) { + /* + * Assembly failed. Clean up and report the error. + */ + + /* + * Free any literals that were constructed for the assembly. + */ + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr); + } + + /* + * Free any auxiliary data that was attached to the bytecode + * under construction. + */ + + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + auxDataPtr = compEnv.auxDataArrayPtr + i; + if (auxDataPtr->type->freeProc != NULL) { + (auxDataPtr->type->freeProc)(auxDataPtr->clientData); + } + } + + /* + * TIP 280. If there is extended command line information, + * we need to clean it up. + */ + + if (compEnv.extCmdMapPtr != NULL) { + if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(compEnv.extCmdMapPtr->path); + } + for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) { + ckfree(compEnv.extCmdMapPtr->loc[i].line); + } + if (compEnv.extCmdMapPtr->loc != NULL) { + ckfree(compEnv.extCmdMapPtr->loc); + } + Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo)); + } + + TclFreeCompileEnv(&compEnv); + return NULL; + } + + /* + * Add a "done" instruction as the last instruction and change the object + * into a ByteCode object. Ownership of the literal objects and aux data + * items is given to the ByteCode object. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &assembleCodeType; + TclFreeCompileEnv(&compEnv); + + /* + * Record the local variable context to which the bytecode pertains + */ + + codePtr = objPtr->internalRep.otherValuePtr; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } + + /* + * Report on what the assembler did. + */ + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + + return codePtr; +} + +/* + *----------------------------------------------------------------------------- + * + * TclCompileAssembleCmd -- + * + * Compilation procedure for the '::tcl::unsupported::assemble' command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Puts the result of assembling the code into the bytecode stream in + * 'compileEnv'. + * + * This procedure makes sure that the command has a single arg, which is + * constant. If that condition is met, the procedure calls TclAssembleCode to + * produce bytecode for the given assembly code, and returns any error + * resulting from the assembly. + * + *----------------------------------------------------------------------------- + */ + +int +TclCompileAssembleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; /* Token in the input script */ + + /* + * Make sure that the command has a single arg that is a simple word. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Compile the code and return any error from the compilation. + */ + + return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); +} + +/* + *----------------------------------------------------------------------------- + * + * TclAssembleCode -- + * + * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl + * bytecodes + * + * Results: + * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes + * TCL_EVAL_DIRECT, places an error message in the interpreter result. + * + * Side effects: + * Adds byte codes to the compile environment, and updates the + * environment's stack depth. + * + *----------------------------------------------------------------------------- + */ + +static int +TclAssembleCode( + CompileEnv *envPtr, /* Compilation environment that is to receive + * the generated bytecode */ + const char* codePtr, /* Assembly-language code to be processed */ + int codeLen, /* Length of the code */ + int flags) /* OR'ed combination of flags */ +{ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + /* + * Walk through the assembly script using the Tcl parser. Each 'command' + * will be an instruction or assembly directive. + */ + + const char* instPtr = codePtr; + /* Where to start looking for a line of code */ + int instLen; /* Length in bytes of the current line of + * code */ + const char* nextPtr; /* Pointer to the end of the line of code */ + int bytesLeft = codeLen; /* Number of bytes of source code remaining to + * be parsed */ + int status; /* Tcl status return */ + AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); + Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; + + do { + /* + * Parse out one command line from the assembly script. + */ + + status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); + instLen = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + + /* + * Report errors in the parse. + */ + + if (status != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, + instLen); + } + FreeAssemblyEnv(assemEnvPtr); + return TCL_ERROR; + } + + /* + * Advance the pointers around any leading commentary. + */ + + TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, + parsePtr->commandStart); + TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, + parsePtr->commandStart - envPtr->source); + + /* + * Process the line of code. + */ + + if (parsePtr->numWords > 0) { + /* + * If tracing, show each line assembled as it happens. + */ + +#ifdef TCL_COMPILE_DEBUG + if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { + printf(" %4ld Assembling: ", + (long)(envPtr->codeNext - envPtr->codeStart)); + TclPrintSource(stdout, parsePtr->commandStart, + TclMin(instLen, 55)); + printf("\n"); + } +#endif + if (AssembleOneLine(assemEnvPtr) != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, + parsePtr->commandStart, instLen); + } + Tcl_FreeParse(parsePtr); + FreeAssemblyEnv(assemEnvPtr); + return TCL_ERROR; + } + } + + /* + * Advance to the next line of code. + */ + + nextPtr = parsePtr->commandStart + parsePtr->commandSize; + bytesLeft -= (nextPtr - instPtr); + instPtr = nextPtr; + TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, + instPtr); + TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, + instPtr - envPtr->source); + Tcl_FreeParse(parsePtr); + } while (bytesLeft > 0); + + /* + * Done with parsing the code. + */ + + status = FinishAssembly(assemEnvPtr); + FreeAssemblyEnv(assemEnvPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * NewAssemblyEnv -- + * + * Creates an environment for the assembler to run in. + * + * Results: + * Allocates, initialises and returns an assembler environment + * + *----------------------------------------------------------------------------- + */ + +static AssemblyEnv* +NewAssemblyEnv( + CompileEnv* envPtr, /* Compilation environment being used for code + * generation*/ + int flags) /* Compilation flags (TCL_EVAL_DIRECT) */ +{ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); + /* Assembler environment under construction */ + Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Parse of one line of assembly code */ + + assemEnvPtr->envPtr = envPtr; + assemEnvPtr->parsePtr = parsePtr; + assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->clNext = envPtr->clNext; + + /* + * Make the hashtables that store symbol resolution. + */ + + Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); + + /* + * Start the first basic block. + */ + + assemEnvPtr->curr_bb = NULL; + assemEnvPtr->head_bb = AllocBB(assemEnvPtr); + assemEnvPtr->curr_bb = assemEnvPtr->head_bb; + assemEnvPtr->head_bb->startLine = 1; + + /* + * Stash compilation flags. + */ + + assemEnvPtr->flags = flags; + return assemEnvPtr; +} + +/* + *----------------------------------------------------------------------------- + * + * FreeAssemblyEnv -- + * + * Cleans up the assembler environment when assembly is complete. + * + *----------------------------------------------------------------------------- + */ + +static void +FreeAssemblyEnv( + AssemblyEnv* assemEnvPtr) /* Environment to free */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment being used for code + * generation */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* thisBB; /* Pointer to a basic block being deleted */ + BasicBlock* nextBB; /* Pointer to a deleted basic block's + * successor */ + + /* + * Free all the basic block structures. + */ + + for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { + if (thisBB->jumpTarget != NULL) { + Tcl_DecrRefCount(thisBB->jumpTarget); + } + if (thisBB->foreignExceptions != NULL) { + ckfree(thisBB->foreignExceptions); + } + nextBB = thisBB->successor1; + if (thisBB->jtPtr != NULL) { + DeleteMirrorJumpTable(thisBB->jtPtr); + thisBB->jtPtr = NULL; + } + ckfree(thisBB); + } + + /* + * Dispose what's left. + */ + + Tcl_DeleteHashTable(&assemEnvPtr->labelHash); + TclStackFree(interp, assemEnvPtr->parsePtr); + TclStackFree(interp, assemEnvPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * AssembleOneLine -- + * + * Assembles a single command from an assembly language source. + * + * Results: + * Returns TCL_ERROR with an appropriate error message if the assembly + * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly + * environment with the state of the assembly. + * + *----------------------------------------------------------------------------- + */ + +static int +AssembleOneLine( + AssemblyEnv* assemEnvPtr) /* State of the assembly */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment being used for code + * gen */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; + /* Parse of the line of code */ + Tcl_Token* tokenPtr; /* Current token within the line of code */ + Tcl_Obj* instNameObj; /* Name of the instruction */ + int tblIdx; /* Index in TalInstructionTable of the + * instruction */ + enum TalInstType instType; /* Type of the instruction */ + Tcl_Obj* operand1Obj = NULL; + /* First operand to the instruction */ + const char* operand1; /* String rep of the operand */ + int operand1Len; /* String length of the operand */ + int opnd; /* Integer representation of an operand */ + int litIndex; /* Literal pool index of a constant */ + int localVar; /* LVT index of a local variable */ + int flags; /* Flags for a basic block */ + JumptableInfo* jtPtr; /* Pointer to a jumptable */ + int infoIndex; /* Index of the jumptable in auxdata */ + int status = TCL_ERROR; /* Return value from this function */ + + /* + * Make sure that the instruction name is known at compile time. + */ + + tokenPtr = parsePtr->tokenPtr; + if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Look up the instruction name. + */ + + if (Tcl_GetIndexFromObjStruct(interp, instNameObj, + &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", + TCL_EXACT, &tblIdx) != TCL_OK) { + goto cleanup; + } + + /* + * Vector on the type of instruction being processed. + */ + + instType = TalInstructionTable[tblIdx].instType; + switch (instType) { + + case ASSEM_PUSH: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); + break; + + case ASSEM_1BYTE: + if (parsePtr->numWords != 1) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); + goto cleanup; + } + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + break; + + case ASSEM_BEGIN_CATCH: + /* + * Emit the BEGIN_CATCH instruction with the code offset of the + * exception branch target instead of the exception range index. The + * correct index will be generated and inserted later, when catches + * are being resolved. + */ + + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); + assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); + break; + + case ASSEM_BOOL: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + break; + + case ASSEM_BOOL_LVT4: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_CONCAT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckOneByte(interp, opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_DICT_GET: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + break; + + case ASSEM_DICT_SET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_DICT_UNSET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_END_CATCH: + if (parsePtr->numWords != 1) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); + goto cleanup; + } + assemEnvPtr->curr_bb->flags |= BB_ENDCATCH; + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + break; + + case ASSEM_EVAL: + /* TODO - Refactor this stuff into a subroutine that takes the inst + * code, the message ("script" or "expression") and an evaluator + * callback that calls TclCompileScript or TclCompileExpr. */ + + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, + ((TalInstructionTable[tblIdx].tclInstCode + == INST_EVAL_STK) ? "script" : "expression")); + goto cleanup; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, + TalInstructionTable+tblIdx); + } else if (GetNextOperand(assemEnvPtr, &tokenPtr, + &operand1Obj) != TCL_OK) { + goto cleanup; + } else { + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + + /* + * Assumes that PUSH is the first slot! + */ + + BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + } + break; + + case ASSEM_INVOKE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + + BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_JUMP: + case ASSEM_JUMP4: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + if (instType == ASSEM_JUMP) { + flags = BB_JUMP1; + BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); + } else { + flags = 0; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); + } + + /* + * Start a new basic block at the instruction following the jump. + */ + + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + if (TalInstructionTable[tblIdx].operandsConsumed != 0) { + flags |= BB_FALLTHRU; + } + StartBasicBlock(assemEnvPtr, flags, operand1Obj); + break; + + case ASSEM_JUMPTABLE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + + jtPtr = ckalloc(sizeof(JumptableInfo)); + + Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", + assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, + envPtr->codeNext - envPtr->codeStart); + + infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); + DEBUG_PRINT("auxdata index=%d\n", infoIndex); + + BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); + if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { + goto cleanup; + } + StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); + break; + + case ASSEM_LABEL: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + + /* + * Add the (label_name, address) pair to the hash table. + */ + + if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { + goto cleanup; + } + break; + + case ASSEM_LINDEX_MULTI: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LIST: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_INDEX: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LSET_FLAT: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + if (opnd < 2) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operand must be >=2", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); + } + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LVT: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_LVT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar)) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_LVT1_SINT1: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar) + || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckSignedOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); + TclEmitInt1(opnd, envPtr); + break; + + case ASSEM_LVT4: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_OVER: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + break; + + case ASSEM_REGEXP: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + { + int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0); + + BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0); + } + break; + + case ASSEM_REVERSE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_SINT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckSignedOneByte(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + break; + + case ASSEM_SINT4_LVT4: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + + default: + Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", + Tcl_GetString(instNameObj)); + } + + status = TCL_OK; + cleanup: + Tcl_DecrRefCount(instNameObj); + if (operand1Obj) { + Tcl_DecrRefCount(operand1Obj); + } + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * CompileEmbeddedScript -- + * + * Compile an embedded 'eval' or 'expr' that appears in assembly code. + * + * This procedure is called when the 'eval' or 'expr' assembly directive is + * encountered, and the argument to the directive is a simple word that + * requires no substitution. The appropriate compiler (TclCompileScript or + * TclCompileExpr) is invoked recursively, and emits bytecode. + * + * Before the compiler is invoked, the compilation environment's stack + * consumption is reset to zero. Upon return from the compilation, the net + * stack effect of the compilation is in the compiler env, and this stack + * effect is posted to the assembler environment. The compile environment's + * stack consumption is then restored to what it was before (which is actually + * the state of the stack on entry to the block of assembly code). + * + * Any exception ranges pushed by the compilation are copied to the basic + * block and removed from the compiler environment. They will be rebuilt at + * the end of assembly, when the exception stack depth is actually known. + * + *----------------------------------------------------------------------------- + */ + +static void +CompileEmbeddedScript( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ + const TalInstDesc* instPtr) /* Instruction that determines whether + * the script is 'expr' or 'eval' */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + /* + * The expression or script is not only known at compile time, but + * actually a "simple word". It can be compiled inline by invoking the + * compiler recursively. + * + * Save away the stack depth and reset it before compiling the script. + * We'll record the stack usage of the script in the BasicBlock, and + * accumulate it together with the stack usage of the enclosing assembly + * code. + */ + + int savedStackDepth = envPtr->currStackDepth; + int savedMaxStackDepth = envPtr->maxStackDepth; + int savedCodeIndex = envPtr->codeNext - envPtr->codeStart; + int savedExceptArrayNext = envPtr->exceptArrayNext; + + envPtr->currStackDepth = 0; + envPtr->maxStackDepth = 0; + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + switch(instPtr->tclInstCode) { + case INST_EVAL_STK: + TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); + break; + case INST_EXPR_STK: + TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1); + break; + default: + Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", + instPtr->name, instPtr->tclInstCode); + } + + /* + * Roll up the stack usage of the embedded block into the assembler + * environment. + */ + + SyncStackDepth(assemEnvPtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->maxStackDepth = savedMaxStackDepth; + + /* + * Save any exception ranges that were pushed by the compiler; they will + * need to be fixed up once the stack depth is known. + */ + + MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, + savedExceptArrayNext); + + /* + * Flush the current basic block. + */ + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); +} + +/* + *----------------------------------------------------------------------------- + * + * SyncStackDepth -- + * + * Copies the stack depth from the compile environment to a basic block. + * + * Side effects: + * Current and max stack depth in the current basic block are adjusted. + * + * This procedure is called on return from invoking the compiler for the + * 'eval' and 'expr' operations. It adjusts the stack depth of the current + * basic block to reflect the stack required by the just-compiled code. + * + *----------------------------------------------------------------------------- + */ + +static void +SyncStackDepth( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Current basic block */ + int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; + /* Max stack depth in the basic block */ + + if (maxStackDepth > curr_bb->maxStackDepth) { + curr_bb->maxStackDepth = maxStackDepth; + } + curr_bb->finalStackDepth += envPtr->currStackDepth; +} + +/* + *----------------------------------------------------------------------------- + * + * MoveExceptionRangesToBasicBlock -- + * + * Removes exception ranges that were created by compiling an embedded + * script from the CompileEnv, and stores them in the BasicBlock. They + * will be reinstalled, at the correct stack depth, after control flow + * analysis is complete on the assembly code. + * + *----------------------------------------------------------------------------- + */ + +static void +MoveExceptionRangesToBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int savedCodeIndex, /* Start of the embedded code */ + int savedExceptArrayNext) /* Saved index of the end of the exception + * range array */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Current basic block */ + int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; + /* Number of ranges that must be moved */ + int i; + + if (exceptionCount == 0) { + /* Nothing to do */ + return; + } + + /* + * Save the exception ranges in the basic block. They will be re-added at + * the conclusion of assembly; at this time, the INST_BEGIN_CATCH + * instructions in the block will be adjusted from whatever range indices + * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the + * indices that the exceptions acquire. The saved exception ranges are + * converted to a relative nesting depth. The depth will be recomputed + * once flow analysis has determined the actual stack depth of the block. + */ + + DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", + curr_bb, exceptionCount, savedExceptArrayNext); + curr_bb->foreignExceptionBase = savedExceptArrayNext; + curr_bb->foreignExceptionCount = exceptionCount; + curr_bb->foreignExceptions = + ckalloc(exceptionCount * sizeof(ExceptionRange)); + memcpy(curr_bb->foreignExceptions, + envPtr->exceptArrayPtr + savedExceptArrayNext, + exceptionCount * sizeof(ExceptionRange)); + for (i = 0; i < exceptionCount; ++i) { + curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; + } + envPtr->exceptArrayNext = savedExceptArrayNext; +} + +/* + *----------------------------------------------------------------------------- + * + * CreateMirrorJumpTable -- + * + * Makes a jump table with comparison values and assembly code labels. + * + * Results: + * Returns a standard Tcl status, with an error message in the + * interpreter on error. + * + * Side effects: + * Initializes the jump table pointer in the current basic block to a + * JumptableInfo. The keys in the JumptableInfo are the comparison + * strings. The values, instead of being jump displacements, are + * Tcl_Obj's with the code labels. + */ + +static int +CreateMirrorJumpTable( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Obj* jumps) /* List of alternating keywords and labels */ +{ + int objc; /* Number of elements in the 'jumps' list */ + Tcl_Obj** objv; /* Pointers to the elements in the list */ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + JumptableInfo* jtPtr; + Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ + Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ + int isNew; /* Flag==1 if the key is not yet in the + * table. */ + int i; + + if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + if (objc % 2 != 0) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "jump table must have an even number of list elements", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); + } + return TCL_ERROR; + } + + /* + * Allocate the jumptable. + */ + + jtPtr = ckalloc(sizeof(JumptableInfo)); + jtHashPtr = &jtPtr->hashTable; + Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); + + /* + * Fill the keys and labels into the table. + */ + + 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]), + &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]))); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); + DeleteMirrorJumpTable(jtPtr); + return TCL_ERROR; + } + } + Tcl_SetHashValue(hashEntry, objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); + } + DEBUG_PRINT("}\n"); + + /* + * Put the mirror jumptable in the basic block struct. + */ + + bbPtr->jtPtr = jtPtr; + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * DeleteMirrorJumpTable -- + * + * Cleans up a jump table when the basic block is deleted. + * + *----------------------------------------------------------------------------- + */ + +static void +DeleteMirrorJumpTable( + JumptableInfo* jtPtr) +{ + Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; + /* Hash table pointer */ + Tcl_HashSearch search; /* Hash search control */ + Tcl_HashEntry* entry; /* Hash table entry containing a jump label */ + Tcl_Obj* label; /* Jump label from the hash table */ + + for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + label = Tcl_GetHashValue(entry); + Tcl_DecrRefCount(label); + Tcl_SetHashValue(entry, NULL); + } + Tcl_DeleteHashTable(jtHashPtr); + ckfree(jtPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * GetNextOperand -- + * + * Retrieves the next operand in sequence from an assembly instruction, + * and makes sure that its value is known at compile time. + * + * Results: + * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand + * text in *operandObjPtr. In case of failure, returns TCL_ERROR and + * leaves *operandObjPtr untouched. + * + * Side effects: + * Advances *tokenPtrPtr around the token just processed. + * + *----------------------------------------------------------------------------- + */ + +static int +GetNextOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding + * the operand */ + Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text + * with \-substitutions done. */ +{ + Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; + Tcl_Obj* operandObj = Tcl_NewObj(); + + if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { + Tcl_DecrRefCount(operandObj); + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "assembly code may not contain substitutions", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); + } + return TCL_ERROR; + } + *tokenPtrPtr = TokenAfter(*tokenPtrPtr); + Tcl_IncrRefCount(operandObj); + *operandObjPtr = operandObj; + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * GetBooleanOperand -- + * + * Retrieves a Boolean operand from the input stream and advances + * the token pointer. + * + * Results: + * Returns a standard Tcl result (with an error message in the + * interpreter on failure). + * + * Side effects: + * Stores the Boolean value in (*result) and advances (*tokenPtrPtr) + * to the next token. + * + *----------------------------------------------------------------------------- + */ + +static int +GetBooleanOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + 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. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = Tcl_GetBooleanFromObj(interp, intObj, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * GetIntegerOperand -- + * + * Retrieves an integer operand from the input stream and advances the + * token pointer. + * + * Results: + * Returns a standard Tcl result (with an error message in the + * interpreter on failure). + * + * Side effects: + * Stores the integer value in (*result) and advances (*tokenPtrPtr) to + * the next token. + * + *----------------------------------------------------------------------------- + */ + +static int +GetIntegerOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + 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. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = Tcl_GetIntFromObj(interp, intObj, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * GetListIndexOperand -- + * + * Gets the value of an operand intended to serve as a list index. + * + * Results: + * Returns a standard Tcl result: TCL_OK if the parse is successful and + * TCL_ERROR (with an appropriate error message) if the parse fails. + * + * Side effects: + * Stores the list index at '*index'. Values between -1 and 0x7fffffff + * have their natural meaning; values between -2 and -0x80000000 + * represent 'end-2-N'. + * + *----------------------------------------------------------------------------- + */ + +static int +GetListIndexOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + 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. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = TclGetIntForIndex(interp, intObj, -2, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * FindLocalVar -- + * + * Gets the name of a local variable from the input stream and advances + * the token pointer. + * + * Results: + * Returns the LVT index of the local variable. Returns -1 if the + * variable is non-local, not known at compile time, or cannot be + * installed in the LVT (leaving an error message in the interpreter + * result if necessary). + * + * Side effects: + * Advances the token pointer. May define a new LVT slot if the variable + * has not yet been seen and the execution context allows for it. + * + *----------------------------------------------------------------------------- + */ + +static int +FindLocalVar( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr) +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Token* tokenPtr = *tokenPtrPtr; + /* INOUT: Pointer to the next token in the + * source code. */ + Tcl_Obj* varNameObj; /* Name of the variable */ + const char* varNameStr; + int varNameLen; + int localVar; /* Index of the variable in the LVT */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { + return -1; + } + varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { + Tcl_DecrRefCount(varNameObj); + return -1; + } + localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); + Tcl_DecrRefCount(varNameObj); + if (localVar == -1) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use this instruction to create a variable" + " in a non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + } + return -1; + } + *tokenPtrPtr = TokenAfter(tokenPtr); + return localVar; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNamespaceQualifiers -- + * + * Verify that a variable name has no namespace qualifiers before + * attempting to install it in the LVT. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNamespaceQualifiers( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + const char* name, /* Variable name to check */ + int nameLen) /* Length of the variable */ +{ + const char* p; + + for (p = name; p+2 < name+nameLen; p++) { + if ((*p == ':') && (p[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable \"%s\" is not local", name)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckOneByte -- + * + * Verify that a constant fits in a single byte in the instruction + * stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckOneByte( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value < 0 || value > 0xff) { + result = Tcl_NewStringObj("operand does not fit in one byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckSignedOneByte -- + * + * Verify that a constant fits in a single signed byte in the instruction + * stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckSignedOneByte( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value > 0x7f || value < -0x80) { + result = Tcl_NewStringObj("operand does not fit in one byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNonNegative -- + * + * Verify that a constant is nonnegative + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_INVOKE + * are consuming a positive number of operands + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNonNegative( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value < 0) { + result = Tcl_NewStringObj("operand must be nonnegative", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckStrictlyPositive -- + * + * Verify that a constant is positive + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_INVOKE + * are consuming a positive number of operands + * + *----------------------------------------------------------------------------- + */ + +static int +CheckStrictlyPositive( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value <= 0) { + result = Tcl_NewStringObj("operand must be positive", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * DefineLabel -- + * + * Defines a label appearing in the assembly sequence. + * + * Results: + * Returns a standard Tcl result. Returns TCL_OK and an empty result if + * the definition succeeds; returns TCL_ERROR and an appropriate message + * if a duplicate definition is found. + * + *----------------------------------------------------------------------------- + */ + +static int +DefineLabel( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + const char* labelName) /* Label being defined */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_HashEntry* entry; /* Label's entry in the symbol table */ + int isNew; /* Flag == 1 iff the label was previously + * undefined */ + + /* TODO - This can now be simplified! */ + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + + /* + * Look up the newly-defined label in the symbol table. + */ + + entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); + if (!isNew) { + /* + * This is a duplicate label. + */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate definition of label \"%s\"", labelName)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, + NULL); + } + return TCL_ERROR; + } + + /* + * This is the first appearance of the label in the code. + */ + + Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * StartBasicBlock -- + * + * Starts a new basic block when a label or jump is encountered. + * + * Results: + * Returns a pointer to the BasicBlock structure of the new + * basic block. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock* +StartBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int flags, /* Flags to apply to the basic block being + * closed, if there is one. */ + Tcl_Obj* jumpLabel) /* Label of the location that the block jumps + * to, or NULL if the block does not jump */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* newBB; /* BasicBlock structure for the new block */ + BasicBlock* currBB = assemEnvPtr->curr_bb; + + /* + * Coalesce zero-length blocks. + */ + + if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { + currBB->startLine = assemEnvPtr->cmdLine; + return currBB; + } + + /* + * Make the new basic block. + */ + + newBB = AllocBB(assemEnvPtr); + + /* + * Record the jump target if there is one. + */ + + currBB->jumpTarget = jumpLabel; + if (jumpLabel != NULL) { + Tcl_IncrRefCount(currBB->jumpTarget); + } + + /* + * Record the fallthrough if there is one. + */ + + currBB->flags |= flags; + + /* + * Record the successor block. + */ + + currBB->successor1 = newBB; + assemEnvPtr->curr_bb = newBB; + return newBB; +} + +/* + *----------------------------------------------------------------------------- + * + * AllocBB -- + * + * Allocates a new basic block + * + * Results: + * Returns a pointer to the newly allocated block, which is initialized + * to contain no code and begin at the current instruction pointer. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock * +AllocBB( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + BasicBlock *bb = ckalloc(sizeof(BasicBlock)); + + bb->originalStartOffset = + bb->startOffset = envPtr->codeNext - envPtr->codeStart; + bb->startLine = assemEnvPtr->cmdLine + 1; + bb->jumpOffset = -1; + bb->jumpLine = -1; + bb->prevPtr = assemEnvPtr->curr_bb; + bb->predecessor = NULL; + bb->successor1 = NULL; + bb->jumpTarget = NULL; + bb->initialStackDepth = 0; + bb->minStackDepth = 0; + bb->maxStackDepth = 0; + bb->finalStackDepth = 0; + bb->enclosingCatch = NULL; + bb->foreignExceptionBase = -1; + bb->foreignExceptionCount = 0; + bb->foreignExceptions = NULL; + bb->jtPtr = NULL; + bb->flags = 0; + + return bb; +} + +/* + *----------------------------------------------------------------------------- + * + * FinishAssembly -- + * + * Postprocessing after all bytecode has been generated for a block of + * assembly code. + * + * Results: + * Returns a standard Tcl result, with an error message left in the + * interpreter if appropriate. + * + * Side effects: + * The program is checked to see if any undefined labels remain. The + * initial stack depth of all the basic blocks in the flow graph is + * calculated and saved. The stack balance on exit is computed, checked + * and saved. + * + *----------------------------------------------------------------------------- + */ + +static int +FinishAssembly( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + int mustMove; /* Amount by which the code needs to be grown + * because of expanding jumps */ + + /* + * Resolve the targets of all jumps and determine whether code needs to be + * moved around. + */ + + if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { + return TCL_ERROR; + } + + /* + * Move the code if necessary. + */ + + if (mustMove) { + MoveCodeForJumps(assemEnvPtr, mustMove); + } + + /* + * Resolve jump target labels to bytecode offsets. + */ + + FillInJumpOffsets(assemEnvPtr); + + /* + * Label each basic block with its catch context. Quit on inconsistency. + */ + + if (ProcessCatches(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure that no block accessible from a catch's error exit that hasn't + * popped the exception stack can throw an exception. + */ + + if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Compute stack balance throughout the program. + */ + + if (CheckStack(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * TODO - Check for unreachable code. Or maybe not; unreachable code is + * Mostly Harmless. + */ + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CalculateJumpRelocations -- + * + * Calculate any movement that has to be done in the assembly code to + * expand JUMP1 instructions to JUMP4 (because they jump more than a + * 1-byte range). + * + * Results: + * Returns a standard Tcl result, with an appropriate error message if + * anything fails. + * + * Side effects: + * Sets the 'startOffset' pointer in every basic block to the new origin + * of the block, and turns off JUMP1 flags on instructions that must be + * expanded (and adjusts them to the corresponding JUMP4's). Does *not* + * store the jump offsets at this point. + * + * Sets *mustMove to 1 if and only if at least one instruction changed + * size so the code must be moved. + * + * As a side effect, also checks for undefined labels and reports them. + * + *----------------------------------------------------------------------------- + */ + +static int +CalculateJumpRelocations( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int* mustMove) /* OUTPUT: Number of bytes that have been + * added to the code */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ + BasicBlock* jumpTarget; /* Basic block where the jump goes */ + int motion; /* Amount by which the code has expanded */ + int offset; /* Offset in the bytecode from a jump + * instruction to its target */ + unsigned opcode; /* Opcode in the bytecode being adjusted */ + + /* + * Iterate through basic blocks as long as a change results in code + * expansion. + */ + + *mustMove = 0; + do { + motion = 0; + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + /* + * Advance the basic block start offset by however many bytes we + * have inserted in the code up to this point + */ + + bbPtr->startOffset += motion; + + /* + * If the basic block references a label (and hence performs a + * jump), find the location of the label. Report an error if the + * label is missing. + */ + + if (bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + if (entry == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, + bbPtr->jumpTarget); + return TCL_ERROR; + } + + /* + * If the instruction is a JUMP1, turn it into a JUMP4 if its + * target is out of range. + */ + + jumpTarget = Tcl_GetHashValue(entry); + if (bbPtr->flags & BB_JUMP1) { + offset = jumpTarget->startOffset + - (bbPtr->jumpOffset + motion); + if (offset < -0x80 || offset > 0x7f) { + opcode = TclGetUInt1AtPtr(envPtr->codeStart + + bbPtr->jumpOffset); + ++opcode; + TclStoreInt1AtPtr(opcode, + envPtr->codeStart + bbPtr->jumpOffset); + motion += 3; + bbPtr->flags &= ~BB_JUMP1; + } + } + } + + /* + * If the basic block references a jump table, that doesn't affect + * the code locations, but resolve the labels now, and store basic + * block pointers in the jumptable hash. + */ + + if (bbPtr->flags & BB_JUMPTABLE) { + if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + *mustMove += motion; + } while (motion != 0); + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckJumpTableLabels -- + * + * Make sure that all the labels in a jump table are defined. + * + * Results: + * Returns TCL_OK if they are, TCL_ERROR if they aren't. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckJumpTableLabels( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block that ends in a jump table */ +{ + Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; + /* Hash table with the symbols */ + Tcl_HashSearch search; /* Hash table iterator */ + Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ + Tcl_Obj* symbolObj; /* Jump target */ + Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ + + /* + * Look up every jump target in the jump hash. + */ + + DEBUG_PRINT("check jump table labels %p {\n", bbPtr); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = Tcl_GetHashValue(symEntryPtr); + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(symbolObj)); + DEBUG_PRINT(" %s -> %s (%d)\n", + (char*) Tcl_GetHashKey(symHash, symEntryPtr), + Tcl_GetString(symbolObj), (valEntryPtr != NULL)); + if (valEntryPtr == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); + return TCL_ERROR; + } + } + DEBUG_PRINT("}\n"); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ReportUndefinedLabel -- + * + * Report that a basic block refers to an undefined jump label + * + * Side effects: + * Stores an error message, error code, and line number information in + * the assembler's Tcl interpreter. + * + *----------------------------------------------------------------------------- + */ + +static void +ReportUndefinedLabel( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block that contains the undefined + * label */ + Tcl_Obj* jumpTarget) /* Label of a jump target */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "undefined label \"%s\"", Tcl_GetString(jumpTarget))); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", + Tcl_GetString(jumpTarget), NULL); + Tcl_SetErrorLine(interp, bbPtr->jumpLine); + } +} + +/* + *----------------------------------------------------------------------------- + * + * MoveCodeForJumps -- + * + * Move bytecodes in memory to accommodate JUMP1 instructions that have + * expanded to become JUMP4's. + * + *----------------------------------------------------------------------------- + */ + +static void +MoveCodeForJumps( + AssemblyEnv* assemEnvPtr, /* Assembler environment */ + int mustMove) /* Number of bytes of added code */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + int topOffset; /* Bytecode offset of the following basic + * block before code motion */ + + /* + * Make sure that there is enough space in the bytecode array to + * accommodate the expanded code. + */ + + while (envPtr->codeEnd < envPtr->codeNext + mustMove) { + TclExpandCodeArray(envPtr); + } + + /* + * Iterate through the bytecodes in reverse order, and move them upward to + * their new homes. + */ + + topOffset = envPtr->codeNext - envPtr->codeStart; + for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { + DEBUG_PRINT("move code from %d to %d\n", + bbPtr->originalStartOffset, bbPtr->startOffset); + memmove(envPtr->codeStart + bbPtr->startOffset, + envPtr->codeStart + bbPtr->originalStartOffset, + topOffset - bbPtr->originalStartOffset); + topOffset = bbPtr->originalStartOffset; + bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); + } + envPtr->codeNext += mustMove; +} + +/* + *----------------------------------------------------------------------------- + * + * FillInJumpOffsets -- + * + * Fill in the final offsets of all jump instructions once bytecode + * locations have been completely determined. + * + *----------------------------------------------------------------------------- + */ + +static void +FillInJumpOffsets( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + int fromOffset; /* Bytecode location of a jump instruction */ + int targetOffset; /* Bytecode location of a jump instruction's + * target */ + + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + if (bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + fromOffset = bbPtr->jumpOffset; + targetOffset = jumpTarget->startOffset; + if (bbPtr->flags & BB_JUMP1) { + TclStoreInt1AtPtr(targetOffset - fromOffset, + envPtr->codeStart + fromOffset + 1); + } else { + TclStoreInt4AtPtr(targetOffset - fromOffset, + envPtr->codeStart + fromOffset + 1); + } + } + if (bbPtr->flags & BB_JUMPTABLE) { + ResolveJumpTableTargets(assemEnvPtr, bbPtr); + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * ResolveJumpTableTargets -- + * + * Puts bytecode addresses for the targets of a jumptable into the + * table + * + * Results: + * Returns TCL_OK if they are, TCL_ERROR if they aren't. + * + *----------------------------------------------------------------------------- + */ + +static void +ResolveJumpTableTargets( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block that ends in a jump table */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; + /* Hash table with the symbols */ + Tcl_HashSearch search; /* Hash table iterator */ + Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ + Tcl_Obj* symbolObj; /* Jump target */ + Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ + int auxDataIndex; /* Index of the auxdata */ + JumptableInfo* realJumpTablePtr; + /* Jump table in the actual code */ + Tcl_HashTable* realJumpHashPtr; + /* Jump table hash in the actual code */ + Tcl_HashEntry* realJumpEntryPtr; + /* Entry in the jump table hash in + * the actual code */ + BasicBlock* jumpTargetBBPtr; + /* Basic block that the jump proceeds to */ + int junk; + + auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); + DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", + bbPtr, bbPtr->jumpOffset, auxDataIndex); + realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpHashPtr = &realJumpTablePtr->hashTable; + + /* + * Look up every jump target in the jump hash. + */ + + DEBUG_PRINT("resolve jump table {\n"); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = Tcl_GetHashValue(symEntryPtr); + DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); + + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(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, + jumpTargetBBPtr->startOffset, realJumpEntryPtr); + + Tcl_SetHashValue(realJumpEntryPtr, + INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); + } + DEBUG_PRINT("}\n"); +} + +/* + *----------------------------------------------------------------------------- + * + * CheckForThrowInWrongContext -- + * + * Verify that no beginCatch/endCatch sequence can throw an exception + * after an original exception is caught and before its exception context + * is removed from the stack. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Stores an appropriate error message in the interpreter as needed. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckForThrowInWrongContext( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* blockPtr; /* Current basic block */ + + /* + * Walk through the basic blocks in turn, checking all the ones that have + * caught an exception and not disposed of it properly. + */ + + for (blockPtr = assemEnvPtr->head_bb; + blockPtr != NULL; + blockPtr = blockPtr->successor1) { + if (blockPtr->catchState == BBCS_CAUGHT) { + /* + * Walk through the instructions in the basic block. + */ + + if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNonThrowingBlock -- + * + * Check that a basic block cannot throw an exception. + * + * Results: + * Returns TCL_ERROR if the block cannot be proven to be nonthrowing. + * + * Side effects: + * Stashes an error message in the interpreter result. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNonThrowingBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* blockPtr) /* Basic block where exceptions are not + * allowed */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ + int offset; /* Bytecode offset of the current + * instruction */ + int bound; /* Bytecode offset following the last + * instruction of the block. */ + unsigned char opcode; /* Current bytecode instruction */ + + /* + * Determine where in the code array the basic block ends. + */ + + nextPtr = blockPtr->successor1; + if (nextPtr == NULL) { + bound = envPtr->codeNext - envPtr->codeStart; + } else { + bound = nextPtr->startOffset; + } + + /* + * Walk through the instructions of the block. + */ + + offset = blockPtr->startOffset; + while (offset < bound) { + /* + * Determine whether an instruction is nonthrowing. + */ + + opcode = (envPtr->codeStart)[offset]; + if (BytecodeMightThrow(opcode)) { + /* + * Report an error for a throw in the wrong context. + */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" instruction may not appear in " + "a context where an exception has been " + "caught and not disposed of.", + tclInstructionTable[opcode].name)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + } + return TCL_ERROR; + } + offset += tclInstructionTable[opcode].numBytes; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * BytecodeMightThrow -- + * + * Tests if a given bytecode instruction might throw an exception. + * + * Results: + * Returns 1 if the bytecode might throw an exception, 0 if the + * instruction is known never to throw. + * + *----------------------------------------------------------------------------- + */ + +static int +BytecodeMightThrow( + unsigned char opcode) +{ + /* + * Binary search on the non-throwing bytecode list. + */ + + int min = 0; + int max = sizeof(NonThrowingByteCodes) - 1; + int mid; + unsigned char c; + + while (max >= min) { + mid = (min + max) / 2; + c = NonThrowingByteCodes[mid]; + if (opcode < c) { + max = mid-1; + } else if (opcode > c) { + min = mid+1; + } else { + /* + * Opcode is nonthrowing. + */ + + return 0; + } + } + + return 1; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckStack -- + * + * Audit stack usage in a block of assembly code. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Updates stack depth on entry for all basic blocks in the flowgraph. + * Calculates the max stack depth used in the program, and updates the + * compilation environment to reflect it. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckStack( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + int maxDepth; /* Maximum stack depth overall */ + + /* + * Checking the head block will check all the other blocks recursively. + */ + + assemEnvPtr->maxDepth = 0; + if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL, + 0) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Post the max stack depth back to the compilation environment. + */ + + maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; + if (maxDepth > envPtr->maxStackDepth) { + envPtr->maxStackDepth = maxDepth; + } + + /* + * If the exit is reachable, make sure that the program exits with 1 + * operand on the stack. + */ + + if (StackCheckExit(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Reset the visited state on all basic blocks. + */ + + ResetVisitedBasicBlocks(assemEnvPtr); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * StackCheckBasicBlock -- + * + * Checks stack consumption for a basic block (and recursively for its + * successors). + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Updates initial stack depth for the basic block and its successors. + * (Final and maximum stack depth are relative to initial, and are not + * touched). + * + * This procedure eventually checks, for the entire flow graph, whether stack + * balance is consistent. It is an error for a given basic block to be + * reachable along multiple flow paths with different stack depths. + * + *----------------------------------------------------------------------------- + */ + +static int +StackCheckBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* blockPtr, /* Pointer to the basic block being checked */ + BasicBlock* predecessor, /* Pointer to the block that passed control to + * this one. */ + int initialStackDepth) /* Stack depth on entry to the block */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + int stackDepth; /* Current stack depth */ + int maxDepth; /* Maximum stack depth so far */ + int result; /* Tcl status return */ + Tcl_HashSearch jtSearch; /* Search structure for the jump table */ + Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */ + Tcl_Obj* targetLabel; /* Target label from the jump table */ + Tcl_HashEntry* entry; /* Hash entry in the label table */ + + if (blockPtr->flags & BB_VISITED) { + /* + * If the block is already visited, check stack depth for consistency + * among the paths that reach it. + */ + + if (blockPtr->initialStackDepth == initialStackDepth) { + return TCL_OK; + } + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "inconsistent stack depths on two execution paths", -1)); + + /* + * TODO - add execution trace of both paths + */ + + Tcl_SetErrorLine(interp, blockPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + } + return TCL_ERROR; + } + + /* + * If the block is not already visited, set the 'predecessor' link to + * indicate how control got to it. Set the initial stack depth to the + * current stack depth in the flow of control. + */ + + blockPtr->flags |= BB_VISITED; + blockPtr->predecessor = predecessor; + blockPtr->initialStackDepth = initialStackDepth; + + /* + * Calculate minimum stack depth, and flag an error if the block + * underflows the stack. + */ + + if (initialStackDepth + blockPtr->minStackDepth < 0) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + Tcl_SetErrorLine(interp, blockPtr->startLine); + } + return TCL_ERROR; + } + + /* + * Make sure that the block doesn't try to pop below the stack level of an + * enclosing catch. + */ + + if (blockPtr->enclosingCatch != 0 && + initialStackDepth + blockPtr->minStackDepth + < (blockPtr->enclosingCatch->initialStackDepth + + blockPtr->enclosingCatch->finalStackDepth)) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "code pops stack below level of enclosing catch", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + Tcl_SetErrorLine(interp, blockPtr->startLine); + } + return TCL_ERROR; + } + + /* + * Update maximum stgack depth. + */ + + maxDepth = initialStackDepth + blockPtr->maxStackDepth; + if (maxDepth > assemEnvPtr->maxDepth) { + assemEnvPtr->maxDepth = maxDepth; + } + + /* + * Calculate stack depth on exit from the block, and invoke this procedure + * recursively to check successor blocks. + */ + + stackDepth = initialStackDepth + blockPtr->finalStackDepth; + result = TCL_OK; + if (blockPtr->flags & BB_FALLTHRU) { + result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1, + blockPtr, stackDepth); + } + + if (result == TCL_OK && blockPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(blockPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, + stackDepth); + } + + /* + * All blocks referenced in a jump table are successors. + */ + + if (blockPtr->flags & BB_JUMPTABLE) { + for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable, + &jtSearch); + result == TCL_OK && jtEntry != NULL; + jtEntry = Tcl_NextHashEntry(&jtSearch)) { + targetLabel = Tcl_GetHashValue(jtEntry); + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(targetLabel)); + jumpTarget = Tcl_GetHashValue(entry); + result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, + blockPtr, stackDepth); + } + } + + return result; +} + +/* + *----------------------------------------------------------------------------- + * + * StackCheckExit -- + * + * Makes sure that the net stack effect of an entire assembly language + * script is to push 1 result. + * + * Results: + * Returns a standard Tcl result, with an error message in the + * interpreter result if the stack is wrong. + * + * Side effects: + * If the assembly code had a net stack effect of zero, emits code to the + * concluding block to push a null result. In any case, updates the stack + * depth in the compile environment to reflect the net effect of the + * assembly code. + * + *----------------------------------------------------------------------------- + */ + +static int +StackCheckExit( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + int depth; /* Net stack effect */ + int litIndex; /* Index in the literal pool of the empty + * string */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Final basic block in the assembly */ + + /* + * Don't perform these checks if execution doesn't reach the exit (either + * because of an infinite loop or because the only return is from the + * middle. + */ + + if (curr_bb->flags & BB_VISITED) { + /* + * Exit with no operands; push an empty one. + */ + + depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; + if (depth == 0) { + /* + * Emit a 'push' of the empty literal. + */ + + litIndex = TclRegisterNewLiteral(envPtr, "", 0); + + /* + * Assumes that 'push' is at slot 0 in TalInstructionTable. + */ + + BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + ++depth; + } + + /* + * Exit with unbalanced stack. + */ + + if (depth != 1) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "stack is unbalanced on exit from the code (depth=%d)", + depth)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + } + return TCL_ERROR; + } + + /* + * Record stack usage. + */ + + envPtr->currStackDepth += depth; + } + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ProcessCatches -- + * + * First pass of 'catch' processing. + * + * Results: + * Returns a standard Tcl result, with an appropriate error message if + * the result is TCL_ERROR. + * + * Side effects: + * Labels all basic blocks with their enclosing catches. + * + *----------------------------------------------------------------------------- + */ + +static int +ProcessCatches( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* blockPtr; /* Pointer to a basic block */ + + /* + * Clear the catch state of all basic blocks. + */ + + for (blockPtr = assemEnvPtr->head_bb; + blockPtr != NULL; + blockPtr = blockPtr->successor1) { + blockPtr->catchState = BBCS_UNKNOWN; + blockPtr->enclosingCatch = NULL; + } + + /* + * Start the check recursively from the first basic block, which is + * outside any exception context + */ + + if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, + NULL, BBCS_NONE, 0) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Check for unclosed catch on exit. + */ + + if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Now there's enough information to build the exception ranges. + */ + + if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Finally, restore any exception ranges from embedded scripts. + */ + + RestoreEmbeddedExceptionRanges(assemEnvPtr); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ProcessCatchesInBasicBlock -- + * + * First-pass catch processing for one basic block. + * + * Results: + * Returns a standard Tcl result, with error message in the interpreter + * result if an error occurs. + * + * This procedure checks consistency of the exception context through the + * assembler program, and records the enclosing 'catch' for every basic block. + * + *----------------------------------------------------------------------------- + */ + +static int +ProcessCatchesInBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + BasicBlock* enclosing, /* Start basic block of the enclosing catch */ + enum BasicBlockCatchState state, + /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */ + int catchDepth) /* Depth of nesting of catches */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + int result; /* Return value from this procedure */ + BasicBlock* fallThruEnclosing; + /* Enclosing catch if execution falls thru */ + enum BasicBlockCatchState fallThruState; + /* Catch state of the successor block */ + BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump + * target */ + enum BasicBlockCatchState jumpState; + /* Catch state of the jump target */ + int changed = 0; /* Flag == 1 iff successor blocks need to be + * checked because the state of this block has + * changed. */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */ + Tcl_HashEntry* jtEntry; /* Entry in a jumptable */ + Tcl_Obj* targetLabel; /* Target label from a jumptable */ + Tcl_HashEntry* entry; /* Entry from the label table */ + + /* + * Update the state of the current block, checking for consistency. Set + * 'changed' to 1 if the state changes and successor blocks need to be + * rechecked. + */ + + if (bbPtr->catchState == BBCS_UNKNOWN) { + bbPtr->enclosingCatch = enclosing; + } else if (bbPtr->enclosingCatch != enclosing) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "execution reaches an instruction in inconsistent " + "exception contexts", -1)); + Tcl_SetErrorLine(interp, bbPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); + } + return TCL_ERROR; + } + if (state > bbPtr->catchState) { + bbPtr->catchState = state; + changed = 1; + } + + /* + * If this block has been visited before, and its state hasn't changed, + * we're done with it for now. + */ + + if (!changed) { + return TCL_OK; + } + bbPtr->catchDepth = catchDepth; + + /* + * Determine enclosing catch and 'caught' state for the fallthrough and + * the jump target. Default for both is the state of the current block. + */ + + fallThruEnclosing = enclosing; + fallThruState = state; + jumpEnclosing = enclosing; + jumpState = state; + + /* + * TODO: Make sure that the test cases include validating that a natural + * loop can't include 'beginCatch' or 'endCatch' + */ + + if (bbPtr->flags & BB_BEGINCATCH) { + /* + * If the block begins a catch, the state for the successor is 'in + * catch'. The jump target is the exception exit, and the state of the + * jump target is 'caught.' + */ + + fallThruEnclosing = bbPtr; + fallThruState = BBCS_INCATCH; + jumpEnclosing = bbPtr; + jumpState = BBCS_CAUGHT; + ++catchDepth; + } + + if (bbPtr->flags & BB_ENDCATCH) { + /* + * If the block ends a catch, the state for the successor is whatever + * the state was on entry to the catch. + */ + + if (enclosing == NULL) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "endCatch without a corresponding beginCatch", -1)); + Tcl_SetErrorLine(interp, bbPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); + } + return TCL_ERROR; + } + fallThruEnclosing = enclosing->enclosingCatch; + fallThruState = enclosing->catchState; + --catchDepth; + } + + /* + * Visit any successor blocks with the appropriate exception context + */ + + result = TCL_OK; + if (bbPtr->flags & BB_FALLTHRU) { + result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1, + fallThruEnclosing, fallThruState, catchDepth); + } + if (result == TCL_OK && bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, + jumpEnclosing, jumpState, catchDepth); + } + + /* + * All blocks referenced in a jump table are successors. + */ + + if (bbPtr->flags & BB_JUMPTABLE) { + for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); + result == TCL_OK && jtEntry != NULL; + jtEntry = Tcl_NextHashEntry(&jtSearch)) { + targetLabel = Tcl_GetHashValue(jtEntry); + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(targetLabel)); + jumpTarget = Tcl_GetHashValue(entry); + result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, + jumpEnclosing, jumpState, catchDepth); + } + } + + return result; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckForUnclosedCatches -- + * + * Checks that a sequence of assembly code has no unclosed catches on + * exit. + * + * Results: + * Returns a standard Tcl result, with an error message for unclosed + * catches. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckForUnclosedCatches( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "catch still active on exit from assembly code", -1)); + Tcl_SetErrorLine(interp, + assemEnvPtr->curr_bb->enclosingCatch->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * BuildExceptionRanges -- + * + * Walks through the assembly code and builds exception ranges for the + * catches embedded therein. + * + * Results: + * Returns a standard Tcl result with an error message in the interpreter + * if anything is unsuccessful. + * + * Side effects: + * Each contiguous block of code with a given catch exit is assigned an + * exception range at the appropriate level. + * Exception ranges in embedded blocks have their levels corrected and + * collated into the table. + * Blocks that end with 'beginCatch' are associated with the innermost + * exception range of the following block. + * + *----------------------------------------------------------------------------- + */ + +static int +BuildExceptionRanges( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Current basic block */ + BasicBlock* prevPtr = NULL; /* Previous basic block */ + int catchDepth = 0; /* Current catch depth */ + int maxCatchDepth = 0; /* Maximum catch depth in the program */ + BasicBlock** catches; /* Stack of catches in progress */ + int* catchIndices; /* Indices of the exception ranges of catches + * in progress */ + int i; + + /* + * Determine the max catch depth for the entire assembly script + * (excluding embedded eval's and expr's, which will be handled later). + */ + + for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { + if (bbPtr->catchDepth > maxCatchDepth) { + maxCatchDepth = bbPtr->catchDepth; + } + } + + /* + * Allocate memory for a stack of active catches. + */ + + catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); + catchIndices = ckalloc(maxCatchDepth * sizeof(int)); + for (i = 0; i < maxCatchDepth; ++i) { + catches[i] = NULL; + catchIndices[i] = -1; + } + + /* + * Walk through the basic blocks and manage exception ranges. + */ + + for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { + UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches, + catchIndices); + LookForFreshCatches(bbPtr, catches); + StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches, + catchIndices); + + /* + * If the last block was a 'begin catch', fill in the exception range. + */ + + catchDepth = bbPtr->catchDepth; + if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { + TclStoreInt4AtPtr(catchIndices[catchDepth-1], + envPtr->codeStart + bbPtr->startOffset - 4); + } + + prevPtr = bbPtr; + } + + /* Make sure that all catches are closed */ + + if (catchDepth != 0) { + Tcl_Panic("unclosed catch at end of code in " + "tclAssembly.c:BuildExceptionRanges, can't happen"); + } + + /* Free temp storage */ + + ckfree(catchIndices); + ckfree(catches); + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * UnstackExpiredCatches -- + * + * Unstacks and closes the exception ranges for any catch contexts that + * were active in the previous basic block but are inactive in the + * current one. + * + *----------------------------------------------------------------------------- + */ + +static void +UnstackExpiredCatches( + CompileEnv* envPtr, /* Compilation environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + int catchDepth, /* Depth of nesting of catches prior to entry + * to this block */ + BasicBlock** catches, /* Array of catch contexts */ + int* catchIndices) /* Indices of the exception ranges + * corresponding to the catch contexts */ +{ + ExceptionRange* range; /* Exception range for a specific catch */ + BasicBlock* catch; /* Catch block being examined */ + BasicBlockCatchState catchState; + /* State of the code relative to the catch + * block being examined ("in catch" or + * "caught"). */ + + /* + * Unstack any catches that are deeper than the nesting level of the basic + * block being entered. + */ + + while (catchDepth > bbPtr->catchDepth) { + --catchDepth; + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } + + /* + * Unstack any catches that don't match the basic block being entered, + * either because they are no longer part of the context, or because the + * context has changed from INCATCH to CAUGHT. + */ + + catchState = bbPtr->catchState; + catch = bbPtr->enclosingCatch; + while (catchDepth > 0) { + --catchDepth; + if (catches[catchDepth] != NULL) { + if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) { + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } + catchState = catch->catchState; + catch = catch->enclosingCatch; + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * LookForFreshCatches -- + * + * Determines whether a basic block being entered needs any exception + * ranges that are not already stacked. + * + * Does not create the ranges: this procedure iterates from the innermost + * catch outward, but exception ranges must be created from the outermost + * catch inward. + * + *----------------------------------------------------------------------------- + */ + +static void +LookForFreshCatches( + BasicBlock* bbPtr, /* Basic block being entered */ + BasicBlock** catches) /* Array of catch contexts that are already + * entered */ +{ + BasicBlockCatchState catchState; + /* State ("in catch" or "caught") of the + * current catch. */ + BasicBlock* catch; /* Current enclosing catch */ + int catchDepth; /* Nesting depth of the current catch */ + + catchState = bbPtr->catchState; + catch = bbPtr->enclosingCatch; + catchDepth = bbPtr->catchDepth; + while (catchDepth > 0) { + --catchDepth; + if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) { + catches[catchDepth] = catch; + } + catchState = catch->catchState; + catch = catch->enclosingCatch; + } +} + +/* + *----------------------------------------------------------------------------- + * + * StackFreshCatches -- + * + * Make ExceptionRange records for any catches that are in the basic + * block being entered and were not in the previous basic block. + * + *----------------------------------------------------------------------------- + */ + +static void +StackFreshCatches( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + int catchDepth, /* Depth of nesting of catches prior to entry + * to this block */ + BasicBlock** catches, /* Array of catch contexts */ + int* catchIndices) /* Indices of the exception ranges + * corresponding to the catch contexts */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + ExceptionRange* range; /* Exception range for a specific catch */ + BasicBlock* catch; /* Catch block being examined */ + BasicBlock* errorExit; /* Error exit from the catch block */ + Tcl_HashEntry* entryPtr; + + catchDepth = 0; + + /* + * Iterate through the enclosing catch blocks from the outside in, + * looking for ones that don't have exception ranges (and are uncaught) + */ + + for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) { + if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) { + /* + * Create an exception range for a block that needs one. + */ + + catch = catches[catchDepth]; + catchIndices[catchDepth] = + TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->nestingLevel = envPtr->exceptDepth + catchDepth; + envPtr->maxExceptDepth = + TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); + range->codeOffset = bbPtr->startOffset; + + entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(catch->jumpTarget)); + if (entryPtr == NULL) { + Tcl_Panic("undefined label in tclAssembly.c:" + "BuildExceptionRanges, can't happen"); + } + + errorExit = Tcl_GetHashValue(entryPtr); + range->catchOffset = errorExit->startOffset; + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * RestoreEmbeddedExceptionRanges -- + * + * Processes an assembly script, replacing any exception ranges that + * were present in embedded code. + * + *----------------------------------------------------------------------------- + */ + +static void +RestoreEmbeddedExceptionRanges( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Current basic block */ + int rangeBase; /* Base of the foreign exception ranges when + * they are reinstalled */ + int rangeIndex; /* Index of the current foreign exception + * range as reinstalled */ + ExceptionRange* range; /* Current foreign exception range */ + unsigned char opcode; /* Current instruction's opcode */ + int catchIndex; /* Index of the exception range to which the + * current instruction refers */ + int i; + + /* + * Walk the basic blocks looking for exceptions in embedded scripts. + */ + + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + if (bbPtr->foreignExceptionCount != 0) { + /* + * Reinstall the embedded exceptions and track their nesting level + */ + + rangeBase = envPtr->exceptArrayNext; + for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { + range = bbPtr->foreignExceptions + i; + rangeIndex = TclCreateExceptRange(range->type, envPtr); + range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; + memcpy(envPtr->exceptArrayPtr + rangeIndex, range, + sizeof(ExceptionRange)); + if (range->nestingLevel >= envPtr->maxExceptDepth) { + envPtr->maxExceptDepth = range->nestingLevel + 1; + } + } + + /* + * Walk through the bytecode of the basic block, and relocate + * INST_BEGIN_CATCH4 instructions to the new locations + */ + + i = bbPtr->startOffset; + while (i < bbPtr->successor1->startOffset) { + opcode = envPtr->codeStart[i]; + if (opcode == INST_BEGIN_CATCH4) { + catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); + if (catchIndex >= bbPtr->foreignExceptionBase + && catchIndex < (bbPtr->foreignExceptionBase + + bbPtr->foreignExceptionCount)) { + catchIndex -= bbPtr->foreignExceptionBase; + catchIndex += rangeBase; + TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1); + } + } + i += tclInstructionTable[opcode].numBytes; + } + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * ResetVisitedBasicBlocks -- + * + * Turns off the 'visited' flag in all basic blocks at the conclusion + * of a pass. + * + *----------------------------------------------------------------------------- + */ + +static void +ResetVisitedBasicBlocks( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* block; + + for (block = assemEnvPtr->head_bb; block != NULL; + block = block->successor1) { + block->flags &= ~BB_VISITED; + } +} + +/* + *----------------------------------------------------------------------------- + * + * AddBasicBlockRangeToErrorInfo -- + * + * Updates the error info of the Tcl interpreter to show a given basic + * block in the code. + * + * This procedure is used to label the callstack with source location + * information when reporting an error in stack checking. + * + *----------------------------------------------------------------------------- + */ + +static void +AddBasicBlockRangeToErrorInfo( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block in which the error is found */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Obj* lineNo; /* Line number in the source */ + + Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); + lineNo = Tcl_NewIntObj(bbPtr->startLine); + Tcl_IncrRefCount(lineNo); + Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + Tcl_AddErrorInfo(interp, " and "); + if (bbPtr->successor1 != NULL) { + Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); + Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + } else { + Tcl_AddErrorInfo(interp, "end of assembly code"); + } + Tcl_DecrRefCount(lineNo); +} + +/* + *----------------------------------------------------------------------------- + * + * DupAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl assembly language + * bytecode. We do not copy the bytecode intrep. Instead, we return + * without setting copyPtr->typePtr, so the copy is a plain string copy + * of the assembly source, and if it is to be used as a compiled + * expression, it will need to be reprocessed. + * + * This makes sense, because with Tcl's copy-on-write practices, the + * usual (only?) time Tcl_DuplicateObj() will be called is when the copy + * is about to be modified, which would invalidate any copied bytecode + * anyway. The only reason it might make sense to copy the bytecode is if + * we had some modifying routines that operated directly on the intrep, + * as we do for lists and dicts. + * + * Results: + * None. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static void +DupAssembleCodeInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + return; +} + +/* + *----------------------------------------------------------------------------- + * + * FreeAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl expression + * bytecode. Frees the storage allocated to hold the internal rep, unless + * ref counts indicate bytecode execution is still in progress. + * + * Results: + * None. + * + * Side effects: + * May free allocated memory. Leaves objPtr untyped. + * + *----------------------------------------------------------------------------- + */ + +static void +FreeAssembleCodeInternalRep( + Tcl_Obj *objPtr) +{ + ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclAsync.c b/generic/tclAsync.c index faf012f..14804e4 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclAsync.c,v 1.19 2009/11/18 21:59:51 nijtmans Exp $ */ #include "tclInt.h" @@ -120,7 +118,7 @@ Tcl_AsyncCreate( AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); + asyncPtr = ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; @@ -312,7 +310,7 @@ Tcl_AsyncDelete( } } Tcl_MutexUnlock(&tsdPtr->asyncMutex); - ckfree((char *) asyncPtr); + ckfree(asyncPtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e426178..562cca6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -15,8 +15,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclBasic.c,v 1.466 2010/09/27 19:42:37 msofer Exp $ */ #include "tclInt.h" @@ -83,8 +81,6 @@ TCL_DECLARE_MUTEX(cancelLock) * are used to save the evaluation state between NR calls to each coro. */ -static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL}; - #define SAVE_CONTEXT(context) \ (context).framePtr = iPtr->framePtr; \ (context).varFramePtr = iPtr->varFramePtr; \ @@ -135,11 +131,11 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineActivateCallback; static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; +static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); + static Tcl_NRPostProc NRRunObjProc; -static Tcl_NRPostProc NRTailcallEval; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -167,7 +163,8 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc YieldToCallback; static void ClearTailcall(Tcl_Interp *interp, - struct TEOV_callback *tailcallPtr); + struct NRE_callback *tailcallPtr); +static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -216,11 +213,11 @@ static const CmdInfo builtInCmds[] = { {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, @@ -231,18 +228,18 @@ static const CmdInfo builtInCmds[] = { {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1}, {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, @@ -250,7 +247,7 @@ static const CmdInfo builtInCmds[] = { {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, @@ -259,7 +256,8 @@ static const CmdInfo builtInCmds[] = { {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, + {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. @@ -275,7 +273,6 @@ static const CmdInfo builtInCmds[] = { {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, NULL, 0}, {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, @@ -502,7 +499,7 @@ Tcl_CreateInterp(void) * object type table and other object management code. */ - iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; iPtr->result = iPtr->resultSpace; @@ -526,10 +523,10 @@ Tcl_CreateInterp(void) */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); @@ -549,6 +546,10 @@ Tcl_CreateInterp(void) Tcl_IncrRefCount(iPtr->upLiteral); TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); Tcl_IncrRefCount(iPtr->callLiteral); + TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); + Tcl_IncrRefCount(iPtr->innerLiteral); + iPtr->innerContext = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); @@ -592,6 +593,15 @@ Tcl_CreateInterp(void) iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be @@ -614,7 +624,7 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = (CallFrame *) ckalloc(sizeof(CallFrame)); + framePtr = ckalloc(sizeof(CallFrame)); result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { @@ -647,7 +657,7 @@ Tcl_CreateInterp(void) iPtr->asyncCancelMsg = Tcl_NewObj(); - cancelInfo = (CancelInfo *) ckalloc(sizeof(CancelInfo)); + cancelInfo = ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); @@ -748,7 +758,7 @@ Tcl_CreateInterp(void) hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; @@ -769,16 +779,19 @@ Tcl_CreateInterp(void) } /* - * Create the "array", "binary", "chan", "dict", "info" and "string" - * ensembles. Note that all these commands (and their subcommands that are - * not present in the global namespace) are wholly safe. + * Create the "array", "binary", "chan", "dict", "file", "info", + * "namespace" and "string" ensembles. Note that all these commands (and + * their subcommands that are not present in the global namespace) are + * wholly safe *except* for "file". */ TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitFileCmd(interp); TclInitInfoCmd(interp); + TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); @@ -811,10 +824,14 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); - Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, - TclNRYieldToObjCmd, NULL, NULL); - Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL, - TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); + /* Adding the bytecode assembler command */ + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, + "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, + TclNRAssembleObjCmd, NULL, NULL); + cmdPtr->compileProc = &TclCompileAssembleCmd; + + Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, + NRCoroInjectObjCmd, NULL, NULL); #ifdef USE_DTRACE /* @@ -832,8 +849,8 @@ Tcl_CreateInterp(void) if (mathfuncNSPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } - strcpy(mathFuncName, "::tcl::mathfunc::"); #define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */ + memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN); for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); @@ -847,15 +864,14 @@ Tcl_CreateInterp(void) */ mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); -#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ if (mathopNSPtr == NULL) { Tcl_Panic("can't create math operator namespace"); } Tcl_Export(interp, mathopNSPtr, "*", 1); - strcpy(mathFuncName, "::tcl::mathop::"); +#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ + memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *) - ckalloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -930,11 +946,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* @@ -944,7 +960,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -958,7 +974,7 @@ DeleteOpCmdClientData( { TclOpCmdClientData *occdPtr = clientData; - ckfree((char *) occdPtr); + ckfree(occdPtr); } /* @@ -991,6 +1007,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -1028,14 +1045,14 @@ Tcl_CallWhenDeleted( Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + AssocData *dPtr = ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1084,7 +1101,7 @@ Tcl_DontCallWhenDeleted( hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1124,14 +1141,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + dPtr = ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1176,7 +1193,7 @@ Tcl_DeleteAssocData( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1334,10 +1351,11 @@ DeleteInterpProc( int i; /* - * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, + * unless we are exiting. */ - if (iPtr->numLevels > 0) { + if ((iPtr->numLevels > 0) && !TclInExit()) { Tcl_Panic("DeleteInterpProc called with active evals"); } @@ -1371,9 +1389,9 @@ DeleteInterpProc( if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { - ckfree((char *) cancelInfo->result); + ckfree(cancelInfo->result); } - ckfree((char *) cancelInfo); + ckfree(cancelInfo); } Tcl_DeleteHashEntry(hPtr); @@ -1407,7 +1425,6 @@ DeleteInterpProc( * table, as it will be freed later in this function without further use. */ - TclCleanupLiteralTable(interp, &iPtr->literalTable); TclHandleFree(iPtr->handle); TclTeardownNamespace(iPtr->globalNsPtr); @@ -1429,7 +1446,7 @@ DeleteInterpProc( Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1450,10 +1467,10 @@ DeleteInterpProc( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree((char *) dPtr); + ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + ckfree(hTablePtr); } /* @@ -1461,11 +1478,11 @@ DeleteInterpProc( * namespace. The order is important [Bug 1658572]. */ - if (iPtr->framePtr != iPtr->rootFramePtr) { + if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - ckfree((char *) iPtr->rootFramePtr); + ckfree(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -1492,6 +1509,8 @@ DeleteInterpProc( iPtr->errorStack = NULL; Tcl_DecrRefCount(iPtr->upLiteral); Tcl_DecrRefCount(iPtr->callLiteral); + Tcl_DecrRefCount(iPtr->innerLiteral); + Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } @@ -1506,6 +1525,10 @@ DeleteInterpProc( if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); } + if (iPtr->scriptFile) { + Tcl_DecrRefCount(iPtr->scriptFile); + iPtr->scriptFile = NULL; + } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; @@ -1513,7 +1536,7 @@ DeleteInterpProc( while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree((char *) resPtr); + ckfree(resPtr); resPtr = nextResPtr; } @@ -1533,16 +1556,20 @@ DeleteInterpProc( hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); + procPtr->iPtr = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + } + ckfree(cfPtr->line); + ckfree(cfPtr); } - ckfree((char *) cfPtr->line); - ckfree((char *) cfPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->linePBodyPtr); - ckfree((char *) iPtr->linePBodyPtr); + ckfree(iPtr->linePBodyPtr); iPtr->linePBodyPtr = NULL; /* @@ -1558,20 +1585,20 @@ DeleteInterpProc( 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); } Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree((char *) eclPtr); + ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree((char *) iPtr->lineBCPtr); + ckfree(iPtr->lineBCPtr); iPtr->lineBCPtr = NULL; /* @@ -1580,7 +1607,7 @@ DeleteInterpProc( * know which arguments will be used as scripts and which will not. */ - if (iPtr->lineLAPtr->numEntries) { + if (iPtr->lineLAPtr->numEntries && !TclInExit()) { /* * When the interp goes away we have nothing on the stack, so there * are no arguments, so this table has to be empty. @@ -1593,7 +1620,7 @@ DeleteInterpProc( ckfree((char *) iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; - if (iPtr->lineLABCPtr->numEntries) { + if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { /* * When the interp goes away we have nothing on the stack, so there * are no arguments, so this table has to be empty. @@ -1603,7 +1630,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLABCPtr); - ckfree((char *) iPtr->lineLABCPtr); + ckfree(iPtr->lineLABCPtr); iPtr->lineLABCPtr = NULL; /* @@ -1614,7 +1641,7 @@ DeleteInterpProc( Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - ckfree((char *) iPtr); + ckfree(iPtr); } /* @@ -1680,9 +1707,9 @@ Tcl_HideCommand( */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", NULL); + " token (rename)", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); return TCL_ERROR; } @@ -1705,8 +1732,9 @@ Tcl_HideCommand( */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_AppendResult(interp, "can only hide global namespace commands" - " (use rename then hide)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only hide global namespace commands (use rename then hide)", + -1)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1717,8 +1745,7 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *) - ckalloc((unsigned) sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -1731,8 +1758,9 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "hidden command named \"%s\" already exists", + hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); return TCL_ERROR; } @@ -1834,8 +1862,9 @@ Tcl_ExposeCommand( */ if (strstr(cmdName, "::") != NULL) { - Tcl_AppendResult(interp, "cannot expose to a namespace " - "(use expose to toplevel, then rename)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot expose to a namespace (use expose to toplevel, then rename)", + -1)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); return TCL_ERROR; } @@ -1850,8 +1879,8 @@ Tcl_ExposeCommand( hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown hidden command \"%s\"", hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", hiddenCmdToken, NULL); return TCL_ERROR; @@ -1870,9 +1899,9 @@ Tcl_ExposeCommand( * than 'nicely' erroring out ? */ - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "trying to expose a non-global command namespace command", - NULL); + -1)); return TCL_ERROR; } @@ -1889,13 +1918,24 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "exposed command \"%s\" already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); return TCL_ERROR; } /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. @@ -2043,6 +2083,18 @@ Tcl_CreateCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2051,7 +2103,7 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2216,6 +2268,18 @@ Tcl_CreateObjCommand( } } else { /* + * Command resolvers (per-interp, per-namespace) might have resolved + * to a command for the given namespace scope with this command not + * being registered with the namespace's command table. During BC + * compilation, the so-resolved command turns into a CmdName literal. + * Without invalidating a possible CmdName literal here explicitly, + * such literals keep being reused while pointing to overhauled + * commands. + */ + + TclInvalidateCmdLiteral(interp, tail, nsPtr); + + /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2223,7 +2287,7 @@ Tcl_CreateObjCommand( TclInvalidateNsCmdLookup(nsPtr); } - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2435,9 +2499,10 @@ TclRenameCommand( cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "can't ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", NULL); + oldName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } @@ -2467,16 +2532,17 @@ TclRenameCommand( TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": bad command name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": bad command name", newName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", newName, - "\": command already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "RENAME", "TARGET_EXISTS", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't rename to \"%s\": command already exists", newName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", + "TARGET_EXISTS", NULL); result = TCL_ERROR; goto done; } @@ -2524,6 +2590,17 @@ TclRenameCommand( TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* + * Command resolvers (per-interp, per-namespace) might have resolved to a + * command for the given namespace scope with this command not being + * registered with the namespace's command table. During BC compilation, + * the so-resolved command turns into a CmdName literal. Without + * invalidating a possible CmdName literal here explicitly, such literals + * keep being reused while pointing to overhauled commands. + */ + + TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr); + + /* * Script for rename traces can delete the command "oldName". Therefore * increment the reference count for cmdPtr so that it's Command structure * is freed only towards the end of this function by calling @@ -2538,7 +2615,7 @@ TclRenameCommand( Tcl_DStringInit(&newFullName); Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&newFullName, "::", 2); + TclDStringAppendLiteral(&newFullName, "::"); } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; @@ -2966,8 +3043,9 @@ Tcl_DeleteCommandFromToken( tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; + if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } tracePtr = nextPtr; } @@ -3053,8 +3131,8 @@ Tcl_DeleteCommandFromToken( * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached - * CmdName Command reference is found to be invalid and TclNRExecuteByteCode - * looks up the command in the command hashtable). + * CmdName Command reference is found to be invalid and + * TclNRExecuteByteCode looks up the command in the command hashtable). */ TclCleanupCommandMacro(cmdPtr); @@ -3152,7 +3230,7 @@ CallCommandTraces( oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } } @@ -3215,28 +3293,29 @@ CancelEvalProc( if (iPtr != NULL) { /* - * Setting this flag will cause the script in progress to be - * canceled as soon as possible. The core honors this flag at all - * the necessary places to ensure script cancellation is + * Setting the CANCELED flag will cause the script in progress to + * be canceled as soon as possible. The core honors this flag at + * all the necessary places to ensure script cancellation is * responsive. Extensions can check for this flag by calling * Tcl_Canceled and checking if TCL_ERROR is returned or they can * choose to ignore the script cancellation flag and the - * associated functionality altogether. + * associated functionality altogether. Currently, the only other + * flag we care about here is the TCL_CANCEL_UNWIND flag (from + * Tcl_CancelEval). We do not want to simply combine all the flags + * from original Tcl_CancelEval call with the interp flags here + * just in case the caller passed flags that might cause behaviour + * unrelated to script cancellation. */ - iPtr->flags |= CANCELED; + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Currently, we only care about the TCL_CANCEL_UNWIND flag from - * Tcl_CancelEval. We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. */ - if (cancelInfo->flags & TCL_CANCEL_UNWIND) { - iPtr->flags |= TCL_CANCEL_UNWIND; - } + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid @@ -3344,7 +3423,7 @@ TclCleanupCommand( { cmdPtr->refCount--; if (cmdPtr->refCount <= 0) { - ckfree((char *) cmdPtr); + ckfree(cmdPtr); } } @@ -3385,18 +3464,16 @@ Tcl_CreateMathFunc( * function. */ { Tcl_DString bigName; - OldMathFuncData *data = (OldMathFuncData *) - ckalloc(sizeof(OldMathFuncData)); + OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); data->proc = proc; data->numArgs = numArgs; - data->argTypes = (Tcl_ValueType *) - ckalloc(numArgs * sizeof(Tcl_ValueType)); + data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); data->clientData = clientData; Tcl_DStringInit(&bigName); - Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); + TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); Tcl_DStringAppend(&bigName, name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), @@ -3448,7 +3525,7 @@ OldMathFuncProc( * Convert arguments from Tcl_Obj's to Tcl_Value's. */ - args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { /* TODO: Convert to TclGetNumberFromObj? */ valuePtr = objv[j]; @@ -3464,11 +3541,11 @@ OldMathFuncProc( * We have a non-numeric argument. */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", - TCL_STATIC); + -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } @@ -3500,7 +3577,7 @@ OldMathFuncProc( break; case TCL_INT: if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3509,7 +3586,7 @@ OldMathFuncProc( break; case TCL_WIDE_INT: if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree((char *) args); + ckfree(args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3525,7 +3602,7 @@ OldMathFuncProc( errno = 0; result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); - ckfree((char *) args); + ckfree(args); if (result != TCL_OK) { return result; } @@ -3568,8 +3645,8 @@ OldMathFuncDeleteProc( { OldMathFuncData *dataPtr = clientData; - ckfree((char *) dataPtr->argTypes); - ckfree((char *) dataPtr); + ckfree(dataPtr->argTypes); + ckfree(dataPtr); } /* @@ -3623,12 +3700,8 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr == NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "unknown math function \""); - Tcl_AppendToObj(message, name, -1); - Tcl_AppendToObj(message, "\"", 1); - Tcl_SetObjResult(interp, message); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); *numArgsPtr = -1; *argTypesPtr = NULL; @@ -3683,41 +3756,28 @@ Tcl_ListMathFuncs( Tcl_Interp *interp, const char *pattern) { - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *nsPtr; - Namespace *dummy1NsPtr; - Namespace *dummy2NsPtr; - const char *dummyNamePtr; - Tcl_Obj *result = Tcl_NewObj(); - - TclGetNamespaceForQualName(interp, "::tcl::mathfunc", - globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); - if (nsPtr == NULL) { - return result; + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ } - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(pattern, -1)); - } + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - Tcl_HashSearch cmdHashSearch; - Tcl_HashEntry *cmdHashEntry = - Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); - - for (; cmdHashEntry != NULL; - cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { - const char *cmdNamePtr = - Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); - - if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(cmdNamePtr, -1)); - } - } + result = Tcl_NewObj(); } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + return result; } @@ -3757,15 +3817,22 @@ TclInterpReady( */ if (iPtr->flags & DELETED) { - /* JJM - Superfluous Tcl_ResetResult call removed. */ - Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind || + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + /* + * Make sure the script being evaluated (if any) has not been canceled. + */ + + if (TclCanceled(iPtr) && (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -3779,8 +3846,8 @@ TclInterpReady( return TCL_OK; } - Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "too many nested evaluations (infinite loop?)", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); return TCL_ERROR; } @@ -3815,7 +3882,7 @@ TclResetCancellation( } if (force || (iPtr->numLevels == 0)) { - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } return TCL_OK; } @@ -3853,105 +3920,78 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Traverse up the to the top-level interp, checking for the CANCELED flag - * along the way. If any of the intervening interps have the CANCELED flag - * set, the current script in progress is considered to be canceled and we - * stop checking. Otherwise, if any interp has the DELETED flag set we - * stop checking. + * Has the current script in progress for this interpreter been canceled + * or is the stack being unwound due to the previous script cancellation? */ - for (; iPtr!=NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *) iPtr)) { - /* - * Has the current script in progress for this interpreter been - * canceled or is the stack being unwound due to the previous script - * cancellation? - */ - - if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) { - /* - * The CANCELED flag is a one-shot flag that is reset immediately - * upon being detected; however, if the TCL_CANCEL_UNWIND flag is - * set we will continue to report that the script in progress has - * been canceled thereby allowing the evaluation stack for the - * interp to be fully unwound. - */ + if (!TclCanceled(iPtr)) { + return TCL_OK; + } - iPtr->flags &= ~CANCELED; + /* + * The CANCELED flag is a one-shot flag that is reset immediately upon + * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will + * continue to report that the script in progress has been canceled + * thereby allowing the evaluation stack for the interp to be fully + * unwound. + */ - /* - * The CANCELED flag was detected and reset; however, if the - * caller specified the TCL_CANCEL_UNWIND flag, we only return - * TCL_ERROR (indicating that the script in progress has been - * canceled) if the evaluation stack for the interp is being fully - * unwound. - */ + iPtr->flags &= ~CANCELED; - if (!(flags & TCL_CANCEL_UNWIND) - || (iPtr->flags & TCL_CANCEL_UNWIND)) { - /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error - * in the interp's result; otherwise, we leave it alone. - */ + /* + * The CANCELED flag was detected and reset; however, if the caller + * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR + * (indicating that the script in progress has been canceled) if the + * evaluation stack for the interp is being fully unwound. + */ - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - int length; + if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { + return TCL_OK; + } - /* - * Setup errorCode variables so that we can differentiate - * between being canceled and unwound. - */ + /* + * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the + * interp's result; otherwise, we leave it alone. + */ - if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, - &length); - } else { - length = 0; - } + if (flags & TCL_LEAVE_ERR_MSG) { + const char *id, *message = NULL; + int length; - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); - Tcl_SetErrorCode(interp, "TCL", id, message, NULL); - } + /* + * Setup errorCode variables so that we can differentiate between + * being canceled and unwound. + */ - /* - * Return TCL_ERROR to the caller (not necessarily just the - * Tcl core itself) that indicates further processing of the - * script or command in progress should halt gracefully and as - * soon as possible. - */ + if (iPtr->asyncCancelMsg != NULL) { + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + } else { + length = 0; + } - return TCL_ERROR; - } - } else { - /* - * FIXME: If this interpreter is being deleted we cannot continue - * to traverse up the interp chain due to an issue with - * Tcl_GetMaster (really the slave interp bookkeeping) that causes - * us to run off into a freed interp struct. Ideally, this check - * would not be necessary because Tcl_GetMaster would return NULL - * instead of a pointer to invalid (freed) memory. - */ + if (iPtr->flags & TCL_CANCEL_UNWIND) { + id = "IUNWIND"; + if (length == 0) { + message = "eval unwound"; + } + } else { + id = "ICANCEL"; + if (length == 0) { + message = "eval canceled"; + } + } - if (iPtr->flags & DELETED) { - break; - } - } + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); } - return TCL_OK; + /* + * Return TCL_ERROR to the caller (not necessarily just the Tcl core + * itself) that indicates further processing of the script or command in + * progress should halt gracefully and as soon as possible. + */ + + return TCL_ERROR; } /* @@ -4096,7 +4136,7 @@ Tcl_EvalObjv( * TCL_EVAL_NOERR are currently supported. */ { int result; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjv(interp, objc, objv, flags, NULL); return TclNRRunCallbacks(interp, result, rootPtr); @@ -4120,8 +4160,6 @@ TclNREvalObjv( Interp *iPtr = (Interp *) interp; int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Tcl_ObjCmdProc *objProc; - ClientData objClientData; Command **cmdPtrPtr; iPtr->lookupNsPtr = NULL; @@ -4137,10 +4175,10 @@ TclNREvalObjv( */ if (iPtr->evalFlags & TCL_EVAL_REDIRECT) { - TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), NULL, NULL); + TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv); iPtr->evalFlags &= ~TCL_EVAL_REDIRECT; } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv); } cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]); @@ -4221,6 +4259,8 @@ TclNREvalObjv( } } + +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4246,7 +4286,7 @@ TclNREvalObjv( TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } - +#endif /* USE_DTRACE */ /* * Fix the original callback to point to the now known cmdPtr. Insure that * the Command struct lives until the command returns. @@ -4260,15 +4300,13 @@ TclNREvalObjv( * a callback to do the actual running. */ - objProc = cmdPtr->nreProc; - if (!objProc) { - objProc = cmdPtr->objProc; + if (cmdPtr->nreProc) { + TclNRAddCallback(interp, NRRunObjProc, cmdPtr, + INT2PTR(objc), (ClientData) objv, NULL); + return TCL_OK; + } else { + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } - objClientData = cmdPtr->objClientData; - - TclNRAddCallback(interp, NRRunObjProc, objProc, objClientData, - INT2PTR(objc), (ClientData) objv); - return TCL_OK; } void @@ -4283,12 +4321,12 @@ int TclNRRunCallbacks( Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr) + struct NRE_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ { Interp *iPtr = (Interp *) interp; - TEOV_callback *callbackPtr; + NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; /* @@ -4315,7 +4353,7 @@ TclNRRunCallbacks( return result; } -int +static int NRCommand( ClientData data[], Tcl_Interp *interp, @@ -4338,7 +4376,7 @@ NRCommand( if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } - if (result == TCL_OK) { + if ((result == TCL_OK) && TclCanceled(iPtr)) { result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { @@ -4356,15 +4394,11 @@ NRRunObjProc( { /* OPT: do not call? */ - Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; - ClientData objClientData = data[1]; - int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; + Command* cmdPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj **objv = data[2]; - if (result == TCL_OK) { - return objProc(objClientData, interp, objc, objv); - } - return result; + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4467,7 +4501,7 @@ TEOV_Exception( * here directly. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); return result; } @@ -4570,8 +4604,8 @@ TEOV_NotFound( cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[0]), NULL); @@ -4886,7 +4920,7 @@ TclEvalEx( int line, /* The line the script starts on. */ int *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set only in - * EvalTokensStandard(), to properly handle + * TclSubstTokens(), to properly handle * [...]-nested commands. The 'outerScript' * refers to the most-outer script containing * the embedded command, which is refered to @@ -5066,10 +5100,9 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = (int *) ckalloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **) - ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (int *) ckalloc(numWords * sizeof(int)); + expand = ckalloc(numWords * sizeof(int)); + objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = ckalloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; @@ -5154,10 +5187,9 @@ TclEvalEx( int objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = (Tcl_Obj **) + objv = objvSpace = ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (int *) - ckalloc(objectsNeeded * sizeof(int)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -5184,10 +5216,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - ckfree((char *) copy); + ckfree(copy); } if (lcopy != linesStack) { - ckfree((char *) lcopy); + ckfree(lcopy); } } @@ -5227,9 +5259,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - ckfree((char *) objvSpace); + ckfree(objvSpace); objvSpace = stackObjArray; - ckfree((char *) lineSpace); + ckfree(lineSpace); lineSpace = linesStack; } @@ -5239,7 +5271,7 @@ TclEvalEx( */ if (expand != expandStack) { - ckfree((char *) expand); + ckfree(expand); expand = expandStack; } } @@ -5304,11 +5336,11 @@ TclEvalEx( Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - ckfree((char *) objvSpace); - ckfree((char *) lineSpace); + ckfree(objvSpace); + ckfree(lineSpace); } if (expand != expandStack) { - ckfree((char *) expand); + ckfree(expand); } iPtr->varFramePtr = savedVarFramePtr; @@ -5392,7 +5424,7 @@ TclAdvanceContinuations( /* * Track the invisible continuation lines embedded in a script, if any. * Here they are just spaces (already). They were removed by - * EvalTokensStandard via Tcl_UtfBackslash. + * TclSubstTokens via TclParseBackslash. * * *clNextPtrPtr <=> We have continuation lines to track. * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. @@ -5472,7 +5504,7 @@ TclArgumentEnter( * and initialize references. */ - cfwPtr = (CFWord *) ckalloc(sizeof(CFWord)); + cfwPtr = ckalloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; @@ -5533,7 +5565,7 @@ TclArgumentRelease( continue; } - ckfree((char *) cfwPtr); + ckfree(cfwPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -5593,13 +5625,16 @@ TclArgumentBCEnter( * have to save them at compile time. */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = (CFWordBC *) ckalloc(sizeof(CFWordBC)); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; cfwPtr->obj = objv[word]; @@ -5678,7 +5713,7 @@ TclArgumentBCRelease( Tcl_DeleteHashEntry(hPtr); } - ckfree((char *) cfwPtr); + ckfree(cfwPtr); cfwPtr = nextPtr; } @@ -5721,8 +5756,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if ((!obj->bytes) || ((obj->typePtr == &tclListType) && - ((List *) obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } @@ -5881,7 +5915,7 @@ TclEvalObjEx( int word) /* Index of the word which is in objPtr. */ { int result = TCL_OK; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); return TclNRRunCallbacks(interp, result, rootPtr); @@ -5901,17 +5935,14 @@ TclNREvalObjEx( { Interp *iPtr = (Interp *) interp; int result; - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * This function consists of three independent blocks for: direct - * evaluation of canonical lists, compileation and bytecode execution and + * evaluation of canonical lists, compilation and bytecode execution and * finally direct evaluation. Precisely one of these blocks will be run. */ - if ((objPtr->typePtr == &tclListType) && /* is a list */ - ((objPtr->bytes == NULL || /* no string rep */ - listRepPtr->canonicalFlag))) { /* or is canonical */ + if (TclListObjIsCanonical(objPtr)) { Tcl_Obj *listPtr = objPtr; CmdFrame *eoFramePtr = NULL; int objc; @@ -6002,6 +6033,9 @@ TclNREvalObjEx( * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } if (flags & TCL_EVAL_GLOBAL) { savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; @@ -6170,7 +6204,7 @@ TEOEx_ByteCodeCallback( * Let us just unset the flags inline. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } iPtr->evalFlags = 0; @@ -6239,11 +6273,11 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_AppendResult(interp, - "invoked \"break\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"break\" outside of a loop", -1)); } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendResult(interp, - "invoked \"continue\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", -1)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6578,7 +6612,8 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal argument vector", -1)); return TCL_ERROR; } @@ -6596,8 +6631,8 @@ TclObjInvoke( hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); } if (hPtr == NULL) { - Tcl_AppendResult(interp, "invalid hidden command name \"", - cmdName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid hidden command name \"%s\"", cmdName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, NULL); return TCL_ERROR; @@ -7223,7 +7258,8 @@ ExprIsqrtFunc( return TCL_OK; negarg: - Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); return TCL_ERROR; @@ -7402,21 +7438,16 @@ ExprAbsFunc( goto unChanged; } else if (l == (long)0) { const char *string = objv[1]->bytes; - - if (!string) { - /* - * There is no string representation, so internal one is - * correct. - */ - - goto unChanged; - } - while (isspace(UCHAR(*string))) { - string++; - } - if (*string != '-') { - goto unChanged; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } } + goto unChanged; } else if (l == LONG_MIN) { TclBNInitBignumFromLong(&big, l); goto tooLarge; @@ -7684,7 +7715,7 @@ ExprRandFunc( * to insure different seeds in different threads (bug #416643) */ - iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -8086,8 +8117,9 @@ Tcl_NRCallObjProc( Tcl_Obj *const objv[]) { int result = TCL_OK; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -8114,6 +8146,7 @@ Tcl_NRCallObjProc( TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } +#endif /* USE_DTRACE */ result = objProc(clientData, interp, objc, objv); return TclNRRunCallbacks(interp, result, rootPtr); } @@ -8238,7 +8271,7 @@ Tcl_NRCmdSwap( void TclSpliceTailcall( Tcl_Interp *interp, - TEOV_callback *tailcallPtr) + NRE_callback *tailcallPtr) { /* * Find the splicing spot: right before the NRCommand of the thing @@ -8246,7 +8279,7 @@ TclSpliceTailcall( * (used by command redirectors). */ - TEOV_callback *runPtr; + NRE_callback *runPtr; for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { @@ -8275,10 +8308,9 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ - Tcl_SetResult(interp, - "tailcall can only be called from a proc or lambda", - TCL_STATIC); + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); return TCL_ERROR; } @@ -8304,8 +8336,8 @@ TclNRTailcallObjCmd( Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; Tcl_Namespace *ns1Ptr; - TEOV_callback *tailcallPtr; - + NRE_callback *tailcallPtr; + listPtr = Tcl_NewListObj(objc-1, objv+1); Tcl_IncrRefCount(listPtr); @@ -8316,7 +8348,8 @@ TclNRTailcallObjCmd( } Tcl_IncrRefCount(nsObjPtr); - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); tailcallPtr = TOP_CB(interp); TOP_CB(interp) = tailcallPtr->nextPtr; iPtr->varFramePtr->tailcallPtr = tailcallPtr; @@ -8325,7 +8358,7 @@ TclNRTailcallObjCmd( } int -NRTailcallEval( +TclNRTailcallEval( ClientData data[], Tcl_Interp *interp, int result) @@ -8346,7 +8379,7 @@ NRTailcallEval( * Tailcall execution was preempted, eg by an intervening catch or by * a now-gone namespace: cleanup and return. */ - + TailcallCleanup(data, interp, result); return result; } @@ -8375,7 +8408,7 @@ TailcallCleanup( static void ClearTailcall( Tcl_Interp *interp, - TEOV_callback *tailcallPtr) + NRE_callback *tailcallPtr) { TailcallCleanup(tailcallPtr->data, interp, TCL_OK); TCLNR_FREE(interp, tailcallPtr); @@ -8429,14 +8462,15 @@ TclNRYieldObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); return TCL_ERROR; } if (!corPtr) { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8446,7 +8480,7 @@ TclNRYieldObjCmd( } NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, clientData, NULL, NULL); return TCL_OK; } @@ -8469,8 +8503,8 @@ TclNRYieldToObjCmd( } if (!corPtr) { - Tcl_SetResult(interp, "yieldTo can only be called in a coroutine", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } @@ -8487,7 +8521,7 @@ TclNRYieldToObjCmd( nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldTo failed to find the proper namespace"); + Tcl_Panic("yieldto failed to find the proper namespace"); } Tcl_IncrRefCount(nsObjPtr); @@ -8500,7 +8534,7 @@ TclNRYieldToObjCmd( NULL); iPtr->execEnvPtr = corPtr->eePtr; - return TclNRYieldObjCmd(clientData, interp, 1, objv); + return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); } static int @@ -8512,13 +8546,13 @@ YieldToCallback( /* CoroutineData *corPtr = data[0];*/ Tcl_Obj *listPtr = data[1]; ClientData nsPtr = data[2]; - TEOV_callback *cbPtr; + NRE_callback *cbPtr; /* * yieldTo: invoke the command using tailcall tech. */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL); cbPtr = TOP_CB(interp); TOP_CB(interp) = cbPtr->nextPtr; @@ -8550,7 +8584,7 @@ RewindCoroutine( corPtr->eePtr->rewind = 1; TclNRAddCallback(interp, RewindCoroutineCallback, state, NULL, NULL, NULL); - return NRInterpCoroutine(corPtr, interp, 0, NULL); + return TclNRInterpCoroutine(corPtr, interp, 0, NULL); } static void @@ -8559,7 +8593,7 @@ DeleteCoroutine( { CoroutineData *corPtr = clientData; Tcl_Interp *interp = corPtr->eePtr->interp; - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); if (COR_IS_SUSPENDED(corPtr)) { TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); @@ -8591,14 +8625,14 @@ NRCoroutineCallerCallback( NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - ckfree((char *) corPtr); + ckfree(corPtr); return result; } NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the @@ -8650,7 +8684,7 @@ NRCoroutineExitCallback( */ Tcl_DeleteHashTable(corPtr->lineLABCPtr); - ckfree((char *) corPtr->lineLABCPtr); + ckfree(corPtr->lineLABCPtr); corPtr->lineLABCPtr = NULL; RESTORE_CONTEXT(corPtr->caller); @@ -8660,20 +8694,25 @@ NRCoroutineExitCallback( return result; } - /* - * NRCoroutineActivateCallback -- + *---------------------------------------------------------------------- + * + * TclNRCoroutineActivateCallback -- + * + * This is the workhorse for coroutines: it implements both yield and + * resume. * - * This is the workhorse for coroutines: it implements both yield and resume. + * It is important that both be implemented in the same callback: the + * detection of the impossibility to suspend due to a busy C-stack relies + * on the precise position of a local variable in the stack. We do not + * want the compiler to play tricks on us, either by moving things around + * or inlining. * - * It is important that both be implemented in the same callback: the - * detection of the impossibility to suspend due to a busy C-stack relies on - * the precise position of a local variable in the stack. We do not want the - * compiler to play tricks on us, either by moving things around or inlining. + *---------------------------------------------------------------------- */ -static int -NRCoroutineActivateCallback( +int +TclNRCoroutineActivateCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -8686,18 +8725,18 @@ NRCoroutineActivateCallback( if (!corPtr->stackLevel) { /* * -- Coroutine is suspended -- - * Push the callback to restore the caller's context on yield or return + * Push the callback to restore the caller's context on yield or + * return. */ - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, + NULL, NULL, NULL); /* * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this - * coroutine. + * the interp's environment to make it suitable to run this coroutine. */ - + corPtr->stackLevel = stackLevel; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -8707,29 +8746,27 @@ NRCoroutineActivateCallback( RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; iPtr->numLevels += numLevels; - - return TCL_OK; } else { /* * Coroutine is active: yield */ if (corPtr->stackLevel != stackLevel) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); return TCL_ERROR; } - - if (type == CORO_ACTIVATE_YIELD) { + + if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; } else { Tcl_Panic("Yield received an option which is not implemented"); } - + corPtr->stackLevel = NULL; numLevels = iPtr->numLevels; @@ -8737,12 +8774,73 @@ NRCoroutineActivateCallback( corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; iPtr->execEnvPtr = corPtr->callerEEPtr; - return TCL_OK; } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NRCoroInjectObjCmd -- + * + * Implementation of [::tcl::unsupported::inject] command. + * + *---------------------------------------------------------------------- + */ + +static int +NRCoroInjectObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + + /* + * Usage more or less like tailcall: + * inject coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + corPtr = cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); + iPtr->execEnvPtr = savedEEPtr; + + return TCL_OK; } int -NRInterpCoroutine( +TclNRInterpCoroutine( ClientData clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -8751,9 +8849,9 @@ NRInterpCoroutine( CoroutineData *corPtr = clientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), - "\" is already running", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "coroutine \"%s\" is already running", + Tcl_GetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } @@ -8789,11 +8887,22 @@ NRInterpCoroutine( break; } - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineObjCmd -- + * + * Implementation of [coroutine] command; see documentation for + * description of what this does. + * + *---------------------------------------------------------------------- + */ + int TclNRCoroutineObjCmd( ClientData dummy, /* Not used. */ @@ -8806,7 +8915,8 @@ TclNRCoroutineObjCmd( const char *fullName, *procName; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_DString ds; - + Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; + if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); return TCL_ERROR; @@ -8822,22 +8932,24 @@ TclNRCoroutineObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", 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_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -8847,17 +8959,17 @@ TclNRCoroutineObjCmd( * struct and create the corresponding command. */ - corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData)); + corPtr = ckalloc(sizeof(CoroutineData)); Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, procName, -1); cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, NRInterpCoroutine, corPtr, DeleteCoroutine); + /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); Tcl_DStringFree(&ds); corPtr->cmdPtr = cmdPtr; @@ -8876,8 +8988,7 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->lineLABCPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); @@ -8893,7 +9004,7 @@ TclNRCoroutineObjCmd( } /* - * Save the base context. + * Create the base context. */ corPtr->running.framePtr = iPtr->rootFramePtr; @@ -8902,32 +9013,38 @@ TclNRCoroutineObjCmd( corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; corPtr->stackLevel = NULL; corPtr->auxNumLevels = 0; - iPtr->numLevels--; - + /* * Create the coro's execEnv, switch to it to push the exit and coro - * command callbacks, then switch back. + * command callbacks, then switch back. */ corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); corPtr->callerEEPtr = iPtr->execEnvPtr; corPtr->eePtr->corPtr = corPtr; - + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - iPtr->lookupNsPtr = iPtr->varFramePtr->nsPtr; + /* insure 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--; + + SAVE_CONTEXT(corPtr->running); + RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; - + /* - * Now just resume the coroutine. Take care to insure that the command is - * looked up in the correct namespace. + * Now just resume the coroutine. */ - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index de2d319..5c33308 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclBinary.c,v 1.66 2010/09/15 22:12:00 dkf Exp $ */ #include "tclInt.h" @@ -174,13 +172,13 @@ typedef struct ByteArray { * array. */ int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[4]; /* The array of bytes. The actual size of this + unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ - ((unsigned) (sizeof(ByteArray) - 4 + (len))) + ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.otherValuePtr) #define SET_BYTEARRAY(objPtr, baPtr) \ @@ -305,15 +303,16 @@ Tcl_SetByteArrayObj( TclFreeIntRep(objPtr); Tcl_InvalidateStringRep(objPtr); - length = (length < 0) ? 0 : length; - byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); - memset(byteArrayPtr, 0, BYTEARRAY_SIZE(length)); + if (length < 0) { + length = 0; + } + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (bytes && length) { + + if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -393,8 +392,7 @@ Tcl_SetByteArrayLength( byteArrayPtr = GET_BYTEARRAY(objPtr); if (length > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *) - ckrealloc((char *) byteArrayPtr, BYTEARRAY_SIZE(length)); + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); byteArrayPtr->allocated = length; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -434,7 +432,7 @@ SetByteArrayFromAny( src = TclGetStringFromObj(objPtr, &length); srcEnd = src + length; - byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += Tcl_UtfToUniChar(src, &ch); *dst++ = UCHAR(ch); @@ -471,7 +469,7 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree((char *) GET_BYTEARRAY(objPtr)); + ckfree(GET_BYTEARRAY(objPtr)); objPtr->typePtr = NULL; } @@ -503,7 +501,7 @@ DupByteArrayInternalRep( srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; - copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); @@ -562,7 +560,7 @@ UpdateStringOfByteArray( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = (char *) ckalloc((unsigned) (size + 1)); + dst = ckalloc(size + 1); objPtr->bytes = dst; objPtr->length = size; @@ -643,9 +641,8 @@ TclAppendBytesToByteArray( } if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) { - tmpByteArrayPtr = (ByteArray *) - attemptckrealloc((char *) byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + tmpByteArrayPtr = attemptckrealloc(byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (tmpByteArrayPtr == NULL) { @@ -653,7 +650,7 @@ TclAppendBytesToByteArray( if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) { Tcl_Panic("attempt to allocate a bigger buffer than we can handle"); } - tmpByteArrayPtr = (ByteArray *) ckrealloc((char *) byteArrayPtr, + tmpByteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } @@ -691,29 +688,30 @@ TclAppendBytesToByteArray( *---------------------------------------------------------------------- */ +static const EnsembleImplMap binaryMap[] = { +{ "format", BinaryFormatCmd, NULL, NULL, NULL, 0 }, +{ "scan", BinaryScanCmd, NULL, NULL, NULL, 0 }, +{ "encode", NULL, NULL, NULL, NULL, 0 }, +{ "decode", NULL, NULL, NULL, NULL, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap encodeMap[] = { +{ "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, 0 }, +{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, +{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap decodeMap[] = { +{ "hex", BinaryDecodeHex, NULL, NULL, NULL, 0 }, +{ "uuencode", BinaryDecodeUu, NULL, NULL, NULL, 0 }, +{ "base64", BinaryDecode64, NULL, NULL, NULL, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; + Tcl_Command TclInitBinaryCmd( Tcl_Interp *interp) { - const EnsembleImplMap binaryMap[] = { - { "format", BinaryFormatCmd, NULL, NULL ,NULL }, - { "scan", BinaryScanCmd, NULL,NULL ,NULL }, - { "encode", NULL, NULL, NULL, NULL }, - { "decode", NULL, NULL, NULL, NULL }, - { NULL, NULL, NULL, NULL, NULL } - }; - const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits }, - { NULL, NULL, NULL, NULL, NULL } - }; - const EnsembleImplMap decodeMap[] = { - { "hex", BinaryDecodeHex, NULL, NULL, NULL }, - { "uuencode", BinaryDecodeUu, NULL, NULL, NULL }, - { "base64", BinaryDecode64, NULL, NULL, NULL }, - { NULL, NULL, NULL, NULL, NULL } - }; Tcl_Command binaryEnsemble; binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap); @@ -873,9 +871,9 @@ BinaryFormatCmd( if (count == BINARY_ALL) { count = listc; } else if (count > listc) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", - NULL); + -1)); return TCL_ERROR; } } @@ -884,9 +882,8 @@ BinaryFormatCmd( case 'x': if (count == BINARY_ALL) { - Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use \"*\" in format string with \"x\"", -1)); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; @@ -1198,8 +1195,9 @@ BinaryFormatCmd( badValue: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected ", errorString, - " string but got \"", errorValue, "\" instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected %s string but got \"%s\" instead", + errorString, errorValue)); return TCL_ERROR; badCount: @@ -1217,12 +1215,13 @@ BinaryFormatCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -1586,12 +1585,13 @@ BinaryScanCmd( Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); return TCL_ERROR; } error: - Tcl_AppendResult(interp, errorString, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -2454,7 +2454,7 @@ BinaryDecodeHex( } \ } \ if (cursor > limit) { \ - Tcl_Panic("limit hit\n"); \ + Tcl_Panic("limit hit"); \ } \ } while (0) @@ -2658,12 +2658,12 @@ BinaryDecode64( Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; - unsigned char *data, *datastart, *dataend, c; + unsigned char *data, *datastart, *dataend, c = '\0'; unsigned char *begin = NULL; unsigned char *cursor = NULL; int strict = 0; int i, index, size, cut = 0, count = 0; - enum {OPT_STRICT }; + enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { @@ -2691,43 +2691,85 @@ BinaryDecode64( while (data < dataend) { unsigned long value = 0; - for (i=0 ; i<4 ; i++) { + /* + * Decode the current block. Each base64 block consists of four input + * characters A-Z, a-z, 0-9, +, or /. Each character supplies six bits + * of output data, so each block's output is 24 bits (three bytes) in + * length. The final block can be shorter by one or two bytes, denoted + * by the input ending with one or two ='s, respectively. + */ + + for (i = 0; i < 4; i++) { + /* + * Get the next input character. At end of input, pad with at most + * two ='s. If more than two ='s would be needed, instead discard + * the block read thus far. + */ + if (data < dataend) { c = *data++; + } else if (i > 1) { + c = '='; + } else { + cut += 3; + break; + } - if (c >= 'A' && c <= 'Z') { - value = (value << 6) | ((c - 'A') & 0x3f); - } else if (c >= 'a' && c <= 'z') { - value = (value << 6) | ((c - 'a' + 26) & 0x3f); - } else if (c >= '0' && c <= '9') { - value = (value << 6) | ((c - '0' + 52) & 0x3f); - } else if (c == '+') { - value = (value << 6) | 0x3e; - } else if (c == '/') { - value = (value << 6) | 0x3f; - } else if (c == '=') { - value <<= 6; - if (cut < 2) { - cut++; - } + /* + * Load the character into the block value. Handle ='s specially + * because they're only valid as the last character or two of the + * final block of input. Unless strict mode is enabled, skip any + * input whitespace characters. + */ + + if (cut) { + if (c == '=' && i > 1) { + value <<= 6; + cut++; + } else if (!strict && isspace(c)) { + i--; } else { - if (strict || !isspace(c)) { - goto bad64; - } - i--; - continue; + goto bad64; } - } else { + } else if (c >= 'A' && c <= 'Z') { + value = (value << 6) | ((c - 'A') & 0x3f); + } else if (c >= 'a' && c <= 'z') { + value = (value << 6) | ((c - 'a' + 26) & 0x3f); + } else if (c >= '0' && c <= '9') { + value = (value << 6) | ((c - '0' + 52) & 0x3f); + } else if (c == '+') { + value = (value << 6) | 0x3e; + } else if (c == '/') { + value = (value << 6) | 0x3f; + } else if (c == '=') { value <<= 6; cut++; + } else if (strict || !isspace(c)) { + goto bad64; + } else { + i--; } } *cursor++ = UCHAR((value >> 16) & 0xff); *cursor++ = UCHAR((value >> 8) & 0xff); *cursor++ = UCHAR(value & 0xff); - } - if (cut > size) { - cut = size; + + /* + * Since = is only valid within the final block, if it was encountered + * but there are still more input characters, confirm that strict mode + * is off and all subsequent characters are whitespace. + */ + + if (cut && data < dataend) { + if (strict) { + goto bad64; + } + for (; data < dataend; data++) { + if (!isspace(*data)) { + goto bad64; + } + } + } } Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); Tcl_SetObjResult(interp, resultObj); diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 70aead9..ab977cb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -13,8 +13,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans - * - * RCS: @(#) $Id: tclCkalloc.c,v 1.38 2010/02/25 22:20:10 nijtmans Exp $ */ #include "tclInt.h" @@ -22,6 +20,12 @@ #define FALSE 0 #define TRUE 1 +#undef Tcl_Alloc +#undef Tcl_Free +#undef Tcl_Realloc +#undef Tcl_AttemptAlloc +#undef Tcl_AttemptRealloc + #ifdef TCL_MEM_DEBUG /* @@ -32,12 +36,12 @@ typedef struct MemTag { int refCount; /* Number of mem_headers referencing this * tag. */ - char string[4]; /* Actual size of string will be as large as + 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) sizeof(MemTag) + bytesInString - 3) +#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -83,7 +87,7 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ */ #define BODY_OFFSET \ - ((unsigned long) (&((struct mem_header *) 0)->body)) + ((size_t) (&((struct mem_header *) 0)->body)) static int total_mallocs = 0; static int total_frees = 0; @@ -165,22 +169,36 @@ TclInitDbCkalloc(void) *---------------------------------------------------------------------- */ -void +int TclDumpMemoryInfo( - FILE *outFile) + ClientData clientData, + int flags) { - fprintf(outFile,"total mallocs %10d\n", - total_mallocs); - fprintf(outFile,"total frees %10d\n", - total_frees); - fprintf(outFile,"current packets allocated %10d\n", - current_malloc_packets); - fprintf(outFile,"current bytes allocated %10lu\n", - current_bytes_malloced); - fprintf(outFile,"maximum packets allocated %10d\n", - maximum_malloc_packets); - fprintf(outFile,"maximum bytes allocated %10lu\n", - maximum_bytes_malloced); + char buf[1024]; + + if (clientData == NULL) { + 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, + total_frees, + current_malloc_packets, + (unsigned long)current_bytes_malloced, + maximum_malloc_packets, + (unsigned long)maximum_bytes_malloced); + if (flags == 0) { + fprintf((FILE *)clientData, "%s", buf); + } else { + /* Assume objPtr to append to */ + Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); + } + return 1; } /* @@ -228,7 +246,7 @@ ValidateMemory( } } if (guard_failed) { - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "low guard failed at %lx, %s %d\n", (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -250,7 +268,7 @@ ValidateMemory( } if (guard_failed) { - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "high guard failed at %lx, %s %d\n", (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -389,7 +407,7 @@ Tcl_DbCkalloc( } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } @@ -443,11 +461,7 @@ Tcl_DbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); - (void) fflush(stderr); - abort(); + Tcl_Panic("reached malloc break limit (%d)", total_mallocs); } current_malloc_packets++; @@ -483,7 +497,7 @@ Tcl_AttemptDbCkalloc( } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); return NULL; } @@ -536,11 +550,7 @@ Tcl_AttemptDbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); - (void) fflush(stderr); - abort(); + Tcl_Panic("reached malloc break limit (%d)", total_mallocs); } current_malloc_packets++; @@ -595,7 +605,7 @@ Tcl_DbCkfree( * words on these machines). */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", @@ -672,7 +682,7 @@ Tcl_DbCkrealloc( * See comment from Tcl_DbCkfree before you change the following line. */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { @@ -703,7 +713,7 @@ Tcl_AttemptDbCkrealloc( * See comment from Tcl_DbCkfree before you change the following line. */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { @@ -736,12 +746,6 @@ Tcl_AttemptDbCkrealloc( *---------------------------------------------------------------------- */ -#undef Tcl_Alloc -#undef Tcl_Free -#undef Tcl_Realloc -#undef Tcl_AttemptAlloc -#undef Tcl_AttemptRealloc - char * Tcl_Alloc( unsigned int size) @@ -812,17 +816,19 @@ MemoryCmd( FILE *fileP; Tcl_DString buffer; int result; + size_t len; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option [args..]\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s option [args..]\"", argv[0])); return TCL_ERROR; } - if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { + if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s file\"", + argv[0], argv[1])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -832,7 +838,8 @@ MemoryCmd( result = Tcl_DumpActiveMemory(fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s", + argv[2], Tcl_PosixError(interp))); return TCL_ERROR; } return TCL_OK; @@ -851,22 +858,22 @@ MemoryCmd( "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, - "current bytes allocated", current_bytes_malloced, + "current bytes allocated", (unsigned long)current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", maximum_bytes_malloced)); + "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); return TCL_OK; } - if (strcmp(argv[1],"init") == 0) { + if (strcmp(argv[1], "init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } - if (strcmp(argv[1],"objs") == 0) { + if (strcmp(argv[1], "objs") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " objs file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s objs file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -875,7 +882,9 @@ MemoryCmd( } fileP = fopen(fileName, "w"); if (fileP == NULL) { - Tcl_AppendResult(interp, "cannot open output file", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot open output file: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } TclDbDumpActiveObjects(fileP); @@ -885,8 +894,8 @@ MemoryCmd( } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " onexit file\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s onexit file\"", argv[0])); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -900,16 +909,17 @@ MemoryCmd( } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " tag string\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s tag string\"", argv[0])); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { TclpFree((char *) curTagPtr); } - curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); + len = strlen(argv[2]); + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len)); curTagPtr->refCount = 0; - strcpy(curTagPtr->string, argv[2]); + memcpy(curTagPtr->string, argv[2], len + 1); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { @@ -937,19 +947,20 @@ MemoryCmd( return TCL_OK; } - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, onexit, " - "tag, trace, trace_on_at_malloc, or validate", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": should be active, break_on_malloc, info, " + "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate", + argv[1])); return TCL_ERROR; argError: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " count\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s count\"", argv[0], argv[1])); return TCL_ERROR; bad_suboption: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " on|off\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1])); return TCL_ERROR; } @@ -979,8 +990,8 @@ CheckmemCmd( const char *argv[]) /* String values of arguments. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s fileName\"", argv[0])); return TCL_ERROR; } tclMemDumpFileName = dumpFile; @@ -1247,10 +1258,12 @@ Tcl_ValidateAllMemory( { } -void +int TclDumpMemoryInfo( - FILE *outFile) + ClientData clientData, + int flags) { + return 1; } #endif /* TCL_MEM_DEBUG */ @@ -1305,5 +1318,7 @@ TclFinalizeMemorySubsystem(void) * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclClock.c b/generic/tclClock.c index 7519da8..6d2976d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclClock.c,v 1.75 2010/03/05 14:34:03 dkf Exp $ */ #include "tclInt.h" @@ -268,9 +266,9 @@ TclClockInit( * Create the client data, which is a refcounted literal pool. */ - data = (ClockClientData *) ckalloc(sizeof(ClockClientData)); + data = ckalloc(sizeof(ClockClientData)); data->refCount = 0; - data->literals = (Tcl_Obj **) ckalloc(LIT__END * sizeof(Tcl_Obj*)); + data->literals = ckalloc(LIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < LIT__END; ++i) { data->literals[i] = Tcl_NewStringObj(literals[i], -1); Tcl_IncrRefCount(data->literals[i]); @@ -280,8 +278,8 @@ TclClockInit( * Install the commands. */ - strcpy(cmdName, "::tcl::clock::"); #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ + memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN); for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) { strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name); data->refCount++; @@ -880,8 +878,8 @@ ConvertLocalToUTCUsingC( if (localErrno != 0 || (fields->seconds == -1 && timeVal.tm_yday == -1)) { - Tcl_SetResult(interp, "time value too large/small to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time value too large/small to represent", -1)); return TCL_ERROR; } return TCL_OK; @@ -1020,17 +1018,17 @@ ConvertUTCToLocalUsingC( tock = (time_t) fields->seconds; if ((Tcl_WideInt) tock != fields->seconds) { - Tcl_AppendResult(interp, - "number too large to represent as a Posix time", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "number too large to represent as a Posix time", -1)); Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime(&tock); if (timeVal == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "localtime failed (clock value may be too " - "large/small to represent)", NULL); + "large/small to represent)", -1)); Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); return TCL_ERROR; } @@ -2026,8 +2024,8 @@ ClockDeleteCmdProc( for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } - ckfree((char *) data->literals); - ckfree((char *) data); + ckfree(data->literals); + ckfree(data); } } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index eac0cea..133a61b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -9,13 +9,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCmdAH.c,v 1.127 2010/09/23 18:08:35 dgp Exp $ */ #include "tclInt.h" #include <locale.h> -#include "tclFileSystem.h" /* * The state structure used by [foreach]. Note that the actual structure has @@ -35,6 +32,9 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ + Tcl_Obj *resultList; /* List of result values from the loop body, + * or NULL if we're not collecting them + * ([lmap] vs [foreach]). */ }; /* @@ -46,8 +46,6 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int FileTempfileCmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -57,6 +55,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static inline int EachloopCmd(Tcl_Interp *interp, int collect, + int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -65,6 +65,33 @@ static Tcl_NRPostProc ForNextCallback; 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; +static Tcl_ObjCmdProc FileAttrIsExistingCmd; +static Tcl_ObjCmdProc FileAttrIsFileCmd; +static Tcl_ObjCmdProc FileAttrIsOwnedCmd; +static Tcl_ObjCmdProc FileAttrIsReadableCmd; +static Tcl_ObjCmdProc FileAttrIsWritableCmd; +static Tcl_ObjCmdProc FileAttrLinkStatCmd; +static Tcl_ObjCmdProc FileAttrModifyTimeCmd; +static Tcl_ObjCmdProc FileAttrSizeCmd; +static Tcl_ObjCmdProc FileAttrStatCmd; +static Tcl_ObjCmdProc FileAttrTypeCmd; +static Tcl_ObjCmdProc FilesystemSeparatorCmd; +static Tcl_ObjCmdProc FilesystemVolumesCmd; +static Tcl_ObjCmdProc PathDirNameCmd; +static Tcl_ObjCmdProc PathExtensionCmd; +static Tcl_ObjCmdProc PathFilesystemCmd; +static Tcl_ObjCmdProc PathJoinCmd; +static Tcl_ObjCmdProc PathNativeNameCmd; +static Tcl_ObjCmdProc PathNormalizeCmd; +static Tcl_ObjCmdProc PathRootNameCmd; +static Tcl_ObjCmdProc PathSplitCmd; +static Tcl_ObjCmdProc PathTailCmd; +static Tcl_ObjCmdProc PathTypeCmd; /* *---------------------------------------------------------------------- @@ -172,7 +199,8 @@ Tcl_CaseObjCmd( if (i == caseObjc-1) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra case pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra case pattern with no body", -1)); return TCL_ERROR; } @@ -213,7 +241,7 @@ Tcl_CaseObjCmd( break; } } - ckfree((char *) patObjv); + ckfree(patObjv); if (j < patObjc) { break; } @@ -324,10 +352,7 @@ CatchObjCmdCallback( if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), 0)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -335,11 +360,9 @@ CatchObjCmdCallback( Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, - options, 0)) { - Tcl_DecrRefCount(options); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); + options, TCL_LEAVE_ERR_MSG)) { + /* Do not decrRefCount 'options', it was already done by + * Tcl_ObjSetVar2 */ return TCL_ERROR; } } @@ -393,8 +416,9 @@ Tcl_CdObjCmd( } else { result = Tcl_FSChdir(dir); if (result != TCL_OK) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't change working directory to \"%s\": %s", + TclGetString(dir), Tcl_PosixError(interp))); result = TCL_ERROR; } } @@ -548,9 +572,7 @@ Tcl_EncodingObjCmd( * truncate the string at the first null byte. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); + Tcl_SetObjResult(interp, TclDStringToObj(&ds)); } else { /* * Store the result as binary data. @@ -568,7 +590,7 @@ Tcl_EncodingObjCmd( break; } case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1); + return EncodingDirsObjCmd(dummy, interp, objc, objv); case ENC_NAMES: if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -615,20 +637,27 @@ EncodingDirsObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); + Tcl_Obj *dirListObj; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?dirList?"); return TCL_ERROR; } - if (objc == 1) { + if (objc == 2) { Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); return TCL_OK; } - if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected directory list but got \"", - TclGetString(objv[1]), "\"", NULL); + + dirListObj = objv[2]; + if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected directory list but got \"%s\"", + TclGetString(dirListObj))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH", + NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, objv[1]); + Tcl_SetObjResult(interp, dirListObj); return TCL_OK; } @@ -720,6 +749,16 @@ Tcl_EvalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); +} + +int +TclNREvalObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ register Tcl_Obj *objPtr; Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; @@ -882,13 +921,14 @@ ExprCallback( /* *---------------------------------------------------------------------- * - * Tcl_FileObjCmd -- + * TclInitFileCmd -- * - * This procedure is invoked to process the "file" Tcl command. See the - * user documentation for details on what it does. PLEASE NOTE THAT THIS - * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the - * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any - * case this assertion should be tested. + * This function builds the "file" Tcl command ensemble. See the user + * documentation for details on what that ensemble does. + * + * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH EMBEDDED + * NULLS. With the object-based Tcl_FS APIs, the above NOTE may no longer + * be true. In any case this assertion should be tested. * * Results: * A standard Tcl result. @@ -899,570 +939,1210 @@ ExprCallback( *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_FileObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_Command +TclInitFileCmd( + Tcl_Interp *interp) { - int index, value; - Tcl_StatBuf buf; - struct utimbuf tval; - /* - * This list of constants should match the fileOption string array below. + * Note that most subcommands are unsafe because either they manipulate + * the native filesystem or because they reveal information about the + * native filesystem. */ - static const char *const fileOptions[] = { - "atime", "attributes", "channels", "copy", - "delete", - "dirname", "executable", "exists", "extension", - "isdirectory", "isfile", "join", "link", - "lstat", "mtime", "mkdir", "nativename", - "normalize", "owned", - "pathtype", "readable", "readlink", "rename", - "rootname", "separator", "size", "split", - "stat", "system", "tail", "tempfile", - "type", "volumes", "writable", - NULL + static const EnsembleImplMap initMap[] = { + {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0}, + {"extension", PathExtensionCmd, NULL, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0}, + {"join", PathJoinCmd, NULL, NULL, NULL, 0}, + {"link", TclFileLinkCmd, NULL, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0}, + {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0}, + {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0}, + {"split", PathSplitCmd, NULL, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0}, + {"system", PathFilesystemCmd, NULL, NULL, NULL, 0}, + {"tail", PathTailCmd, NULL, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; - enum options { - FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, - FCMD_DELETE, - FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, - FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, - FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, - FCMD_NORMALIZE, FCMD_OWNED, - FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, - FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TEMPFILE, - FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE + return TclMakeEnsemble(interp, "file", initMap); +} + +/* + *---------------------------------------------------------------------- + * + * 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); - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + /* + * 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 + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the access time on the file, if requested by the user. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrAccessTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, - &index) != TCL_OK) { + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - switch ((enum options) index) { + long newTime; - case FCMD_ATIME: - case FCMD_MTIME: - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + + tval.actime = newTime; + tval.modtime = buf.st_mtime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set access time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } - if (objc == 4) { - /* - * Need separate variable for reading longs from an object on - * 64-bit platforms. [Bug #698146] - */ - long newTime; + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, fs's + * like FAT don't even know what atime is. + */ - if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + } - if (index == FCMD_ATIME) { - tval.actime = newTime; - tval.modtime = buf.st_mtime; - } else { /* index == FCMD_MTIME */ - tval.actime = buf.st_atime; - tval.modtime = newTime; - } + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrModifyTimeCmd -- + * + * This function is invoked to process the "file mtime" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the modification time on the file, if requested by the + * user. + * + *---------------------------------------------------------------------- + */ - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, "could not set ", - (index == FCMD_ATIME ? "access" : "modification"), - " time for file \"", TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } +static int +FileAttrModifyTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; - /* - * Do another stat to ensure that the we return the new recognized - * atime - hopefully the same as the one we sent in. However, fs's - * like FAT don't even know what atime is. - */ + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } + long newTime; - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) - (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); - return TCL_OK; - case FCMD_ATTRIBUTES: - return TclFileAttrsCmd(interp, objc, objv); - case FCMD_CHANNELS: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - return Tcl_GetChannelNamesEx(interp, - ((objc == 2) ? NULL : TclGetString(objv[2]))); - case FCMD_COPY: - return TclFileCopyCmd(interp, objc, objv); - case FCMD_DELETE: - return TclFileDeleteCmd(interp, objc, objv); - case FCMD_DIRNAME: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { + + tval.actime = buf.st_atime; + tval.modtime = newTime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set modification time for file \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_EXECUTABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], X_OK); - case FCMD_EXISTS: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], F_OK); - case FCMD_EXTENSION: { - Tcl_Obj *ext; - if (objc != 3) { - goto only3Args; - } - ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); - if (ext == NULL) { + /* + * Do another stat to ensure that the we return the new recognized + * mtime - hopefully the same as the one we sent in. + */ + + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, ext); - Tcl_DecrRefCount(ext); - return TCL_OK; } - case FCMD_ISDIRECTORY: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_ISFILE: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_OWNED: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids associated with a file, so - * we always return 1. - * - * TODO: use GetSecurityInfo to get the real owner of the file and - * test for equivalence to the current user. - */ -#if defined(__WIN32__) - value = 1; -#else - value = (geteuid() == buf.st_uid); -#endif - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_JOIN: { - Tcl_Obj *resObj; + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrLinkStatCmd -- + * + * This function is invoked to process the "file lstat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); - Tcl_SetObjResult(interp, resObj); - return TCL_OK; +static int +FileAttrLinkStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - case FCMD_LINK: { - Tcl_Obj *contents; + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrStatCmd -- + * + * This function is invoked to process the "file stat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); - return TCL_ERROR; - } +static int +FileAttrStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrTypeCmd -- + * + * This function is invoked to process the "file type" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrSizeCmd -- + * + * This function is invoked to process the "file size" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrSizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsDirectoryCmd -- + * + * This function is invoked to process the "file isdirectory" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsDirectoryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExecutableCmd -- + * + * This function is invoked to process the "file executable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExecutableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], X_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExistingCmd -- + * + * This function is invoked to process the "file exists" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExistingCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], F_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsFileCmd -- + * + * This function is invoked to process the "file isfile" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsFileCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsOwnedCmd -- + * + * This function is invoked to process the "file owned" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsOwnedCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { /* - * Index of the 'source' argument. + * For Windows, there are no user ids associated with a file, so we + * always return 1. + * + * TODO: use GetSecurityInfo to get the real owner of the file and + * test for equivalence to the current user. */ - if (objc == 5) { - index = 3; - } else { - index = 2; - } +#if defined(__WIN32__) || defined(__CYGWIN__) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsReadableCmd -- + * + * This function is invoked to process the "file readable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc > 3) { - int linkAction; - if (objc == 5) { - /* - * We have a '-linktype' argument. - */ - - static const char *const linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", - 0, &linkAction) != TCL_OK) { - return TCL_ERROR; - } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +FileAttrIsReadableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], R_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsWritableCmd -- + * + * This function is invoked to process the "file writable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Create link from source to target. - */ +static int +FileAttrIsWritableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], W_OK); +} + +/* + *---------------------------------------------------------------------- + * + * PathDirNameCmd -- + * + * This function is invoked to process the "file dirname" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and for all - * other errors, we use the standard posix error message. - */ - - if (errno == EEXIST) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", NULL); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target doesn't - * exist, or the directory of the src doesn't exist. - */ - - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", NULL); - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\": target \"", - TclGetString(objv[index+1]), - "\" doesn't exist", NULL); - } - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +PathDirNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - /* - * Read link - */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathExtensionCmd -- + * + * This function is invoked to process the "file extension" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, contents); - if (objc == 3) { - /* - * If we are reading a link, we need to free this result refCount. - * If we are creating a link, this will just be objv[index+1], and - * so we don't own it. - */ +static int +PathExtensionCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - Tcl_DecrRefCount(contents); - } - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_STAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_SIZE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; - case FCMD_TYPE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); - return TCL_OK; - case FCMD_MKDIR: - return TclFileMakeDirsCmd(interp, objc, objv); - case FCMD_NATIVENAME: { - const char *fileName; - Tcl_DString ds; - - if (objc != 3) { - goto only3Args; - } - fileName = TclGetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - return TCL_OK; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_EXTENSION); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_NORMALIZE: { - Tcl_Obj *fileName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathRootNameCmd -- + * + * This function is invoked to process the "file root" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } +static int +PathRootNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_ROOT); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_PATHTYPE: { - Tcl_Obj *typeName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTailCmd -- + * + * This function is invoked to process the "file tail" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathTailCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - switch (Tcl_FSGetPathType(objv[2])) { - case TCL_PATH_ABSOLUTE: - TclNewLiteralStringObj(typeName, "absolute"); - break; - case TCL_PATH_RELATIVE: - TclNewLiteralStringObj(typeName, "relative"); - break; - case TCL_PATH_VOLUME_RELATIVE: - TclNewLiteralStringObj(typeName, "volumerelative"); - break; - default: - return TCL_OK; - } - Tcl_SetObjResult(interp, typeName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_READABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], R_OK); - case FCMD_READLINK: { - Tcl_Obj *contents; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathFilesystemCmd -- + * + * This function is invoked to process the "file system" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathFilesystemCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fsInfo; - if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + fsInfo = Tcl_FSFileSystemInfo(objv[1]); + if (fsInfo == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", + Tcl_GetString(objv[1]), NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathJoinCmd -- + * + * This function is invoked to process the "file join" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[2], NULL, 0); +static int +PathJoinCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNativeNameCmd -- + * + * This function is invoked to process the "file nativename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); - return TCL_OK; +static int +PathNativeNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_DString ds; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_RENAME: - return TclFileRenameCmd(interp, objc, objv); - case FCMD_ROOTNAME: { - Tcl_Obj *root; + if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDStringToObj(&ds)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNormalizeCmd -- + * + * This function is invoked to process the "file normalize" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); - if (root == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, root); - Tcl_DecrRefCount(root); - return TCL_OK; +static int +PathNormalizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fileName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_SEPARATOR: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - const char *separator = NULL; /* lint */ + fileName = Tcl_FSGetNormalizedPath(interp, objv[1]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathSplitCmd -- + * + * This function is invoked to process the "file split" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); - } else { - Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); +static int +PathSplitCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *res; - if (separatorObj == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, separatorObj); - } - return TCL_OK; - case FCMD_SPLIT: { - Tcl_Obj *res; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + res = Tcl_FSSplitPath(objv[1], NULL); + if (res == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTypeCmd -- + * + * This function is invoked to process the "file pathtype" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - res = Tcl_FSSplitPath(objv[2], NULL); - if (res == NULL) { - /* How can the interp be NULL here?! DKF */ - if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(objv[2]), - "\": no such file or directory", NULL); - } - return TCL_ERROR; - } - Tcl_SetObjResult(interp, res); +static int +PathTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *typeName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + switch (Tcl_FSGetPathType(objv[1])) { + case TCL_PATH_ABSOLUTE: + TclNewLiteralStringObj(typeName, "absolute"); + break; + case TCL_PATH_RELATIVE: + TclNewLiteralStringObj(typeName, "relative"); + break; + case TCL_PATH_VOLUME_RELATIVE: + TclNewLiteralStringObj(typeName, "volumerelative"); + break; + default: + /* Should be unreachable */ return TCL_OK; } - case FCMD_SYSTEM: { - Tcl_Obj *fsInfo; + Tcl_SetObjResult(interp, typeName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemSeparatorCmd -- + * + * This function is invoked to process the "file separator" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - fsInfo = Tcl_FSFileSystemInfo(objv[2]); - if (fsInfo == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; +static int +FilesystemSeparatorCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + return TCL_ERROR; } - case FCMD_TAIL: { - Tcl_Obj *dirPtr; + if (objc == 1) { + const char *separator = NULL; /* lint */ - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_TEMPFILE: - return FileTempfileCmd(interp, objc, objv); - case FCMD_VOLUMES: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]); + + if (separatorObj == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unrecognised path", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", + Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); - return TCL_OK; - case FCMD_WRITABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], W_OK); + Tcl_SetObjResult(interp, separatorObj); } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemVolumesCmd -- + * + * This function is invoked to process the "file volumes" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - only3Args: - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; +static int +FilesystemVolumesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; } /* @@ -1542,9 +2222,9 @@ GetStatBuf( if (status < 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1590,13 +2270,13 @@ StoreStatData( */ #define STORE_ARY(fieldName, object) \ - TclNewLiteralStringObj(field, fieldName); \ - Tcl_IncrRefCount(field); \ - value = (object); \ + TclNewLiteralStringObj(field, fieldName); \ + Tcl_IncrRefCount(field); \ + value = (object); \ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ - TclDecrRefCount(field); \ - return TCL_ERROR; \ - } \ + TclDecrRefCount(field); \ + return TCL_ERROR; \ + } \ TclDecrRefCount(field); /* @@ -1670,165 +2350,6 @@ GetTypeFromMode( } /* - *--------------------------------------------------------------------------- - * - * FileTempfileCmd - * - * This function implements the "tempfile" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Creates a temporary file. Opens a channel to that file and puts the - * name of that channel in the result. *Might* register suitable exit - * handlers to ensure that the temporary file gets deleted. Might write - * to a variable, so reentrancy is a potential issue. - * - *--------------------------------------------------------------------------- - */ - -static int -FileTempfileCmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary - * file in. */ - Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ - Tcl_Channel chan; /* The channel opened (RDWR) on the temporary - * file, or NULL if there's an error. */ - Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "?nameVar? ?template?"); - return TCL_ERROR; - } - - if (objc > 2) { - nameVarObj = objv[2]; - TclNewObj(nameObj); - } - if (objc > 3) { - int length; - const char *string = TclGetStringFromObj(objv[3], &length); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it. - */ - - if (strchr(string, '/') != NULL - || (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(string, '\\') != NULL)) { - tempDirObj = TclPathPart(interp, objv[3], TCL_PATH_DIRNAME); - - /* - * Only allow creation of temporary files in the native filesystem - * since they are frequently used for integration with external - * tools or system libraries. [Bug 2388866] - */ - - if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - } - - /* - * The template only gives the filename if the last character isn't a - * directory separator. - */ - - if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS - || string[length-1] != '\\')) { - Tcl_Obj *tailObj = TclPathPart(interp, objv[3], TCL_PATH_TAIL); - - if (tailObj != NULL) { - tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); - tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); - TclDecrRefCount(tailObj); - } - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (tempDirObj && !TclGetString(tempDirObj)[0]) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { - TclDecrRefCount(tempBaseObj); - tempBaseObj = NULL; - } - if (tempExtObj && !TclGetString(tempExtObj)[0]) { - TclDecrRefCount(tempExtObj); - tempExtObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (tempDirObj) { - TclDecrRefCount(tempDirObj); - } - if (tempBaseObj) { - TclDecrRefCount(tempBaseObj); - } - if (tempExtObj) { - TclDecrRefCount(tempExtObj); - } - - /* - * Deal with results. - */ - - if (chan == NULL) { - if (nameVarObj) { - TclDecrRefCount(nameObj); - } - Tcl_AppendResult(interp, "can't create temporary file: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - if (nameVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_UnregisterChannel(interp, chan); - return TCL_ERROR; - } - } - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); - return TCL_OK; -} - -/* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- @@ -2050,7 +2571,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2082,6 +2603,38 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { + return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); +} + +int +Tcl_LmapObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); +} + +int +TclNRLmapCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); +} + +static inline int +EachloopCmd( + Tcl_Interp *interp, /* Our context for variables and script + * evaluation. */ + int collect, /* Select collecting or accumulating mode + * (TCL_EACH_*) */ + int objc, /* The arguments being passed in... */ + Tcl_Obj *const objv[]) +{ int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2125,6 +2678,12 @@ TclNRForeachCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; + if (collect == TCL_EACH_COLLECT) { + statePtr->resultList = Tcl_NewListObj(0, NULL); + } else { + statePtr->resultList = NULL; + } + /* * Break up the value lists and variable lists into elements. */ @@ -2138,7 +2697,12 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { - Tcl_AppendResult(interp, "foreach varlist is empty", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), + "NEEDVARS", NULL); result = TCL_ERROR; goto done; } @@ -2207,14 +2771,21 @@ ForeachLoopStep( switch (result) { case TCL_CONTINUE: result = TCL_OK; + break; case TCL_OK: + if (statePtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, + Tcl_GetObjResult(interp)); + } break; case TCL_BREAK: result = TCL_OK; - goto done; + goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"%s\" body line %d)", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + Tcl_GetErrorLine(interp))); default: goto done; } @@ -2239,7 +2810,14 @@ ForeachLoopStep( * We're done. Tidy up our work space and finish off. */ - Tcl_ResetResult(interp); + finish: + if (statePtr->resultList == NULL) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } + done: ForeachCleanup(interp, statePtr); return result; @@ -2272,7 +2850,8 @@ ForeachAssignments( if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting foreach loop variable \"%s\")", + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } @@ -2301,6 +2880,9 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } + if (statePtr->resultList != NULL) { + TclDecrRefCount(statePtr->resultList); + } TclStackFree(interp, statePtr); } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 5ff71a5..155e8e4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,8 +15,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCmdIL.c,v 1.185 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" @@ -29,13 +27,16 @@ */ typedef struct SortElement { - union { + union { /* The value that we sorting by. */ const char *strValuePtr; long intValue; double doubleValue; Tcl_Obj *objValuePtr; - } index; - Tcl_Obj *objPtr; /* Object being sorted, or its index. */ + } collationKey; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; + } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -160,31 +161,31 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, */ static const EnsembleImplMap defaultInfoMap[] = { - {"args", InfoArgsCmd, NULL, NULL, NULL}, - {"body", InfoBodyCmd, NULL, NULL, NULL}, - {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL}, - {"commands", InfoCommandsCmd, NULL, NULL, NULL}, - {"complete", InfoCompleteCmd, NULL, NULL, NULL}, - {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL}, - {"default", InfoDefaultCmd, NULL, NULL, NULL}, - {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL}, - {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL}, - {"frame", InfoFrameCmd, NULL, NULL, NULL}, - {"functions", InfoFunctionsCmd, NULL, NULL, NULL}, - {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL}, - {"hostname", InfoHostnameCmd, NULL, NULL, NULL}, - {"level", InfoLevelCmd, NULL, NULL, NULL}, - {"library", InfoLibraryCmd, NULL, NULL, NULL}, - {"loaded", InfoLoadedCmd, NULL, NULL, NULL}, - {"locals", TclInfoLocalsCmd, NULL, NULL, NULL}, - {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL}, - {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL}, - {"procs", InfoProcsCmd, NULL, NULL, NULL}, - {"script", InfoScriptCmd, NULL, NULL, NULL}, - {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL}, - {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL}, - {"vars", TclInfoVarsCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, + {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, + {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, + {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, + {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, + {"frame", InfoFrameCmd, NULL, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, + {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, + {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0}, + {"procs", InfoProcsCmd, NULL, NULL, NULL, 0}, + {"script", InfoScriptCmd, NULL, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -228,8 +229,9 @@ TclNRIfObjCmd( Tcl_Obj *boolObj; if (objc <= 1) { - Tcl_AppendResult(interp, "wrong # args: no expression after \"", - TclGetString(objv[0]), "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -318,8 +320,9 @@ IfConditionCallback( */ if (i >= objc) { - Tcl_AppendResult(interp, "wrong # args: ", - "no expression after \"", clause, "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + clause)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -344,8 +347,9 @@ IfConditionCallback( } } if (i < objc - 1) { - Tcl_AppendResult(interp, "wrong # args: ", - "extra words after \"else\" clause in \"if\" command", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args: extra words after \"else\" clause in \"if\" command", + -1)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -360,9 +364,9 @@ IfConditionCallback( return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); missingScript: - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no script following \"", clause, - "\" argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no script following \"%s\" argument", + TclGetString(objv[i-1]))); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TCL_ERROR; } @@ -490,7 +494,8 @@ InfoArgsCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -551,7 +556,8 @@ InfoBodyCmd( name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); return TCL_ERROR; } @@ -965,7 +971,7 @@ InfoDefaultCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName, *varName; + const char *procName, *argName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; @@ -980,7 +986,8 @@ InfoDefaultCmd( procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, NULL); return TCL_ERROR; @@ -992,18 +999,18 @@ InfoDefaultCmd( && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, 0); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -1011,16 +1018,11 @@ InfoDefaultCmd( } } - Tcl_AppendResult(interp, "procedure \"", procName, - "\" doesn't have an argument \"", argName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\" doesn't have an argument \"%s\"", + procName, argName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; - - defStoreError: - varName = TclGetString(objv[3]); - Tcl_AppendResult(interp, "couldn't store default value in variable \"", - varName, "\"", NULL); - return TCL_ERROR; } /* @@ -1057,18 +1059,18 @@ InfoErrorStackCmd( Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - + target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); - if (target == NULL) { - return TCL_ERROR; - } + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } } iPtr = (Interp *) target; Tcl_SetObjResult(interp, iPtr->errorStack); - + return TCL_OK; } @@ -1145,32 +1147,41 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel; - CmdFrame *framePtr; + int level, topLevel, code = TCL_OK; + CmdFrame *runPtr, *framePtr; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + } topLevel = ((iPtr->cmdFramePtr == NULL) ? 0 : iPtr->cmdFramePtr->level); - - if (iPtr->execEnvPtr->corPtr) { + if (corPtr) { /* * A coroutine: must fix the level computations AND the cmdFrame chain, * which is interrupted at the base. */ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - CmdFrame *runPtr = iPtr->cmdFramePtr; - CmdFrame *lastPtr = NULL; - - topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr && !runPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } + CmdFrame *lastPtr = NULL; + + runPtr = iPtr->cmdFramePtr; + + /* TODO - deal with overflow */ + topLevel += corPtr->caller.cmdFramePtr->level; + while (runPtr) { + runPtr->level += corPtr->caller.cmdFramePtr->level; + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr) { + lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + } else { + iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + } } if (objc == 1) { @@ -1179,10 +1190,7 @@ InfoFrameCmd( */ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); - return TCL_OK; - } else if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; + goto done; } /* @@ -1190,16 +1198,18 @@ InfoFrameCmd( */ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } if ((level > topLevel) || (level <= - topLevel)) { levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", TclGetString(objv[1]), NULL); - return TCL_ERROR; + code = TCL_ERROR; + goto done; } /* @@ -1219,7 +1229,24 @@ InfoFrameCmd( } Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); - return TCL_OK; + + done: + if (corPtr) { + + if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { + iPtr->cmdFramePtr = NULL; + } else { + runPtr = iPtr->cmdFramePtr; + while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { + runPtr->level -= corPtr->caller.cmdFramePtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + + } + return code; } /* @@ -1382,15 +1409,15 @@ TclInfoFrame( Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; if (namePtr) { - Tcl_Obj *procNameObj; + Tcl_Obj *procNameObj; /* * This is a regular command. */ - TclNewObj(procNameObj); - Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, - procNameObj); + TclNewObj(procNameObj); + Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, + procNameObj); ADD_PAIR("proc", procNameObj); } else if (procPtr->cmdPtr->clientData) { ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; @@ -1465,19 +1492,42 @@ InfoFunctionsCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *pattern; + Tcl_Obj *script; + int code; - if (objc == 1) { - pattern = NULL; - } else if (objc == 2) { - pattern = TclGetString(objv[1]); - } else { + if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_ListMathFuncs(interp, pattern)); - return TCL_OK; + script = Tcl_NewStringObj( +" ::apply [::list {{pattern *}} {\n" +" ::set cmds {}\n" +" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n" +" ::lappend cmds [::namespace tail $cmd]\n" +" }\n" +" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n" +" ::set cmd [::namespace tail $cmd]\n" +" ::if {$cmd ni $cmds} {\n" +" ::lappend cmds $cmd\n" +" }\n" +" }\n" +" ::return $cmds\n" +" } [::namespace current]] ", -1); + + if (objc == 2) { + Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1])); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); + } + + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + + Tcl_DecrRefCount(script); + + return code; } /* @@ -1519,7 +1569,10 @@ InfoHostnameCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; } - Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to determine name of host", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); return TCL_ERROR; } @@ -1589,8 +1642,8 @@ InfoLevelCmd( return TCL_ERROR; levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1636,7 +1689,10 @@ InfoLibraryCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } - Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no library has been specified for Tcl", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); return TCL_ERROR; } @@ -1669,7 +1725,6 @@ InfoLoadedCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *interpName; - int result; if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); @@ -1681,8 +1736,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - result = TclGetLoadedPackages(interp, interpName); - return result; + return TclGetLoadedPackages(interp, interpName); } /* @@ -2266,11 +2320,11 @@ Tcl_LindexObjCmd( if (elemPtr == NULL) { return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - return TCL_OK; } + + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + return TCL_OK; } /* @@ -2384,7 +2438,7 @@ Tcl_ListObjCmd( */ if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); } return TCL_OK; } @@ -2505,9 +2559,9 @@ Tcl_LrangeObjCmd( } if (Tcl_IsShared(objv[1]) || - (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1)) { + ((ListRepPtr(objv[1])->refCount > 1))) { Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, - &(elemPtrs[first]))); + &elemPtrs[first])); } else { /* * In-place is possible. @@ -2571,8 +2625,10 @@ Tcl_LrepeatObjCmd( return TCL_ERROR; } if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_Format(NULL, - "bad count \"%d\": must be integer >= 0", 1, objv+1)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%d\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + NULL); return TCL_ERROR; } @@ -2583,22 +2639,15 @@ Tcl_LrepeatObjCmd( objc -= 2; objv += 2; - /* - * Final sanity check. Total number of elements must fit in a signed - * integer. We also limit the number of elements to 512M-1 so allocations - * on 32-bit machines are guaranteed to be less than 2GB! [Bug 2130992] - */ + /* Final sanity check. Do not exceed limits on max list length. */ - totalElems = objc * elementCount; - if (totalElems != 0 && (totalElems/objc != elementCount - || totalElems/elementCount != objc)) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); - return TCL_ERROR; - } - if (totalElems >= 0x20000000) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } + totalElems = objc * elementCount; /* * Get an empty list object that is allocated large enough to hold each @@ -2607,7 +2656,7 @@ Tcl_LrepeatObjCmd( listPtr = Tcl_NewListObj(totalElems, NULL); if (totalElems) { - List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount*objc; dataArray = &listRepPtr->elements; @@ -2710,8 +2759,10 @@ Tcl_LreplaceObjCmd( */ if ((first >= listLen) && (listLen > 0)) { - Tcl_AppendResult(interp, "list doesn't contain element ", - TclGetString(objv[2]), NULL); + 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 (last >= listLen) { @@ -2795,15 +2846,15 @@ Tcl_LreverseObjCmd( return TCL_OK; } - if (Tcl_IsShared(objv[1])) { + if (Tcl_IsShared(objv[1]) + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - List *listPtr; + List *listRepPtr; - makeNewReversedList: resultObj = Tcl_NewListObj(elemc, NULL); - listPtr = resultObj->internalRep.twoPtrValue.ptr1; - listPtr->elemCount = elemc; - dataArray = &listPtr->elements; + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { dataArray[j] = elemv[i]; @@ -2812,15 +2863,6 @@ Tcl_LreverseObjCmd( Tcl_SetObjResult(interp, resultObj); } else { - /* - * It is theoretically possible for a list object to have a shared - * internal representation, but be an unshared object. Check for this - * and use the "shared" code if we have that problem. [Bug 1675044] - */ - - if (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1) { - goto makeNewReversedList; - } /* * Not shared, so swap "in place". This relies on Tcl_LOGE above @@ -2991,7 +3033,9 @@ Tcl_LsearchObjCmd( Tcl_DecrRefCount(startPtr); } if (i > objc-4) { - Tcl_AppendResult(interp, "missing starting index", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing starting index", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } @@ -3021,9 +3065,10 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } @@ -3081,14 +3126,18 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } - Tcl_AppendResult(interp, - "-subindices cannot be used without -index option", NULL); + 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; } if (bisect && (allMatches || negatedMatch)) { - Tcl_AppendResult(interp, - "-bisect is not compatible with -all or -not", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-bisect is not compatible with -all or -not", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); return TCL_ERROR; } @@ -3520,7 +3569,7 @@ Tcl_LsetObjCmd( if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + "listVar ?index? ?index ...? value"); return TCL_ERROR; } @@ -3640,6 +3689,7 @@ Tcl_LsortObjCmd( group = 0; groupSize = 1; groupOffset = 0; + indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { @@ -3652,9 +3702,10 @@ Tcl_LsortObjCmd( break; case LSORT_COMMAND: if (i == objc-2) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-command\" option must be followed " - "by comparison command", NULL); + "by comparison command", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3672,65 +3723,41 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { + int indexc, dummy; Tcl_Obj **indexv; - /* === START SPECIAL CASE === - * - * When reviewing code flow in this function, note that from here - * to the line a bit below (END SPECIAL CASE) the contents of the - * indexc and indexv fields of the sortInfo structure may not be - * matched, so jumping to the done2 label to exit is wrong. - */ - - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } if (i == objc-2) { - Tcl_AppendResult(interp, "\"-index\" option must be " - "followed by list index", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; } - - /* - * Take copy to prevent shimmering problems. - */ - - if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { - return TCL_ERROR; - } - /* === END SPECIAL CASE === */ - - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - default: - sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as - * it might be decreased by 1 - * later. */ + sortInfo.resultCode = TCL_ERROR; + goto done2; } /* - * Fill the array by parsing each index. We don't know whether - * their scale is sensible yet, but we at least perform the - * syntactic check here. + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. */ - for (j=0 ; j<sortInfo.indexc ; j++) { + for (j=0 ; j<indexc ; j++) { if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + &dummy) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; goto done2; } } + indexPtr = objv[i+1]; i++; break; } @@ -3751,8 +3778,10 @@ Tcl_LsortObjCmd( break; case LSORT_STRIDE: if (i == objc-2) { - Tcl_AppendResult(interp, "\"-stride\" option must be ", - "followed by stride length", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3761,8 +3790,10 @@ Tcl_LsortObjCmd( goto done2; } if (groupSize < 2) { - Tcl_AppendResult(interp, "stride length must be at least 2", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 2", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); sortInfo.resultCode = TCL_ERROR; goto done2; } @@ -3775,6 +3806,35 @@ Tcl_LsortObjCmd( sortInfo.sortMode = SORTMODE_ASCII_NC; } + /* + * Now extract the -index list for real, if present. No failures are + * expected here; the values are all of the right type or convertible to + * it. + */ + + if (indexPtr) { + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &sortInfo.indexv[j]); + } + } + listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -3827,8 +3887,10 @@ Tcl_LsortObjCmd( if (group) { if (length % groupSize) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", NULL); sortInfo.resultCode = TCL_ERROR; goto done; @@ -3845,9 +3907,11 @@ Tcl_LsortObjCmd( groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; } if (groupOffset < 0 || groupOffset >= groupSize) { - Tcl_AppendResult(interp, "when used with \"-stride\", the " - "leading \"-index\" value must be within the group", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADINDEX", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -3918,7 +3982,7 @@ Tcl_LsortObjCmd( */ if (sortMode == SORTMODE_ASCII) { - elementArray[i].index.strValuePtr = TclGetString(indexPtr); + elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { long a; @@ -3926,7 +3990,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.intValue = a; + elementArray[i].collationKey.intValue = a; } else if (sortInfo.sortMode == SORTMODE_REAL) { double a; @@ -3935,9 +3999,9 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.doubleValue = a; + elementArray[i].collationKey.doubleValue = a; } else { - elementArray[i].index.objValuePtr = indexPtr; + elementArray[i].collationKey.objValuePtr = indexPtr; } /* @@ -3946,9 +4010,9 @@ Tcl_LsortObjCmd( */ if (indices || group) { - elementArray[i].objPtr = INT2PTR(idx); + elementArray[i].payload.index = idx; } else { - elementArray[i].objPtr = listObjPtrs[idx]; + elementArray[i].payload.objPtr = listObjPtrs[idx]; } /* @@ -3986,11 +4050,11 @@ Tcl_LsortObjCmd( Tcl_Obj **newArray, *objPtr; resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL); - listRepPtr = resultPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(resultPtr); newArray = &listRepPtr->elements; if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { - idx = PTR2INT(elementPtr->objPtr); + idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { objPtr = Tcl_NewIntObj(idx + j - groupOffset); @@ -4005,13 +4069,13 @@ Tcl_LsortObjCmd( } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); + objPtr = Tcl_NewIntObj(elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = elementPtr->objPtr; + objPtr = elementPtr->payload.objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } @@ -4166,25 +4230,25 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcasecmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - a = elemPtr1->index.intValue; - b = elemPtr2->index.intValue; + a = elemPtr1->collationKey.intValue; + b = elemPtr2->collationKey.intValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->index.doubleValue; - b = elemPtr2->index.doubleValue; + a = elemPtr1->collationKey.doubleValue; + b = elemPtr2->collationKey.doubleValue; order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; @@ -4201,8 +4265,8 @@ SortCompare( } - objPtr1 = elemPtr1->index.objValuePtr; - objPtr2 = elemPtr2->index.objValuePtr; + objPtr1 = elemPtr1->collationKey.objValuePtr; + objPtr2 = elemPtr2->collationKey.objValuePtr; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; @@ -4231,9 +4295,10 @@ SortCompare( if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_ResetResult(infoPtr->interp); - Tcl_AppendResult(infoPtr->interp, - "-compare command returned non-integer result", NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( + "-compare command returned non-integer result", -1)); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "COMPARISONFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return 0; } @@ -4444,12 +4509,11 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - char buffer[TCL_INTEGER_SPACE]; - - TclFormatInt(buffer, index); - Tcl_AppendResult(infoPtr->interp, "element ", buffer, - " missing from sublist \"", TclGetString(objPtr), "\"", - NULL); + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4464,6 +4528,5 @@ SelectObjFromSublist( * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7690649..fc957c4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,8 +14,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.214 2010/08/30 14:02:09 msofer Exp $ */ #include "tclInt.h" @@ -36,12 +34,35 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing space, tab, newline, carriage return, - * ethiopic wordspace (U+1361), ogham space mark (U+1680), and ideographic - * space (U+3000). [TIP #318] + * UTF-8 literal string containing all Unicode space characters [TIP #413] */ -#define DEFAULT_TRIM_SET " \t\n\r\xe1\x8d\xa1\xe1\x9a\x80\xe3\x80\x80" +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ /* *---------------------------------------------------------------------- @@ -206,8 +227,8 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_AppendResult(interp, "regexp match variables not allowed" - " when using -inline", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "regexp match variables not allowed when using -inline", -1)); goto optionError; } @@ -284,8 +305,11 @@ Tcl_RegexpObjCmd( * start of the string unless the previous character is a newline. */ - if ((offset == 0) || ((offset > 0) && - (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar) '\n'))) { + if (offset == 0) { + eflags = 0; + } else if (offset > stringLength) { + eflags = TCL_REG_NOTBOL; + } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -385,12 +409,8 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - Tcl_Obj *valuePtr; - - valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); - if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -818,9 +838,8 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* @@ -1440,18 +1459,19 @@ StringIsCmd( static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "false", - "graph", "integer", "list", "lower", - "print", "punct", "space", "true", - "upper", "wideinteger", "wordchar", "xdigit", - NULL + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL }; enum isClasses { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, - STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, - STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, - STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT }; static const char *const isOptions[] = { "-strict", "-failindex", NULL @@ -1567,7 +1587,6 @@ StringIsCmd( if (stop < end) { result = 0; TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } } break; @@ -1580,6 +1599,51 @@ StringIsCmd( break; } goto failedIntParse; + case STR_IS_ENTIER: + if ((objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { + break; + } + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { + /* + * Entire string parses as an integer. + */ + + break; + } else { + /* + * Some prefix parsed as an integer, but not the whole string, + * so return failure index as the point where parsing stopped. + * Clear out the internal rep, since keeping it would leave + * *objPtr in an inconsistent state. + */ + + result = 0; + failat = stop - string1; + TclFreeIntRep(objPtr); + } + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ + + result = 0; + failat = 0; + } + break; case STR_IS_WIDE: if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; @@ -1624,7 +1688,6 @@ StringIsCmd( failat = stop - string1; TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } } else { /* @@ -1652,7 +1715,7 @@ StringIsCmd( */ const char *elemStart, *nextElem; - int lenRemain, elemSize, hasBrace; + int lenRemain, elemSize; register const char *p; string1 = TclGetStringFromObj(objPtr, &length1); @@ -1661,7 +1724,7 @@ StringIsCmd( for (p=string1, lenRemain=length1; lenRemain > 0; p=nextElem, lenRemain=end-nextElem) { if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace)) { + &elemStart, &nextElem, &elemSize, NULL)) { Tcl_Obj *tmpStr; /* @@ -1674,7 +1737,7 @@ StringIsCmd( * if it is the first "element" that has the failure. */ - while (isspace(UCHAR(*p))) { /* INTL: ? */ + while (TclIsSpaceProc(*p)) { p++; } TclNewStringObj(tmpStr, string1, p-string1); @@ -1799,8 +1862,10 @@ StringMapCmd( strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -1863,6 +1928,8 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } } @@ -2062,8 +2129,10 @@ StringMatchCmd( strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -2196,6 +2265,7 @@ StringReptCmd( 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; } length2 = length1 * count; @@ -2216,6 +2286,7 @@ StringReptCmd( 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++) { @@ -2519,8 +2590,11 @@ StringEqualCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -2666,8 +2740,11 @@ StringCmpCmd( return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -3105,10 +3182,8 @@ StringTrimCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3120,58 +3195,12 @@ StringTrimCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ - - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); return TCL_OK; } @@ -3201,10 +3230,8 @@ StringTrimLCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3216,34 +3243,10 @@ StringTrimLCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } + trim = TclTrimLeft(string1, length1, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim)); return TCL_OK; } @@ -3273,10 +3276,8 @@ StringTrimRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3288,33 +3289,10 @@ StringTrimRCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ + trim = TclTrimRight(string1, length1, string2, length2); - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim)); return TCL_OK; } @@ -3346,29 +3324,29 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, NULL, NULL, NULL}, - {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL}, - {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL}, - {"first", StringFirstCmd, NULL, NULL, NULL}, - {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL}, - {"is", StringIsCmd, NULL, NULL, NULL}, - {"last", StringLastCmd, NULL, NULL, NULL}, - {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL}, - {"map", StringMapCmd, NULL, NULL, NULL}, - {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL}, - {"range", StringRangeCmd, NULL, NULL, NULL}, - {"repeat", StringReptCmd, NULL, NULL, NULL}, - {"replace", StringRplcCmd, NULL, NULL, NULL}, - {"reverse", StringRevCmd, NULL, NULL, NULL}, - {"tolower", StringLowerCmd, NULL, NULL, NULL}, - {"toupper", StringUpperCmd, NULL, NULL, NULL}, - {"totitle", StringTitleCmd, NULL, NULL, NULL}, - {"trim", StringTrimCmd, NULL, NULL, NULL}, - {"trimleft", StringTrimLCmd, NULL, NULL, NULL}, - {"trimright", StringTrimRCmd, NULL, NULL, NULL}, - {"wordend", StringEndCmd, NULL, NULL, NULL}, - {"wordstart", StringStartCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, + {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, + {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, + {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, + {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, + {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, + {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, + {"repeat", StringReptCmd, NULL, NULL, NULL, 0}, + {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, + {"reverse", StringRevCmd, NULL, NULL, NULL, 0}, + {"tolower", StringLowerCmd, NULL, NULL, NULL, 0}, + {"toupper", StringUpperCmd, NULL, NULL, NULL, 0}, + {"totitle", StringTitleCmd, NULL, NULL, NULL, 0}, + {"trim", StringTrimCmd, NULL, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0}, + {"wordend", StringEndCmd, NULL, NULL, NULL, 0}, + {"wordstart", StringStartCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "string", stringImplMap); @@ -3562,9 +3540,11 @@ TclNRSwitchObjCmd( * Mode already set via -exact, -glob, or -regexp. */ - Tcl_AppendResult(interp, "bad option \"", - TclGetString(objv[i]), "\": ", options[mode], - " option already found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": %s option already found", + TclGetString(objv[i]), options[mode])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); return TCL_ERROR; } foundmode = 1; @@ -3579,8 +3559,11 @@ TclNRSwitchObjCmd( case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-indexvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3589,8 +3572,11 @@ TclNRSwitchObjCmd( case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-matchvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3606,13 +3592,17 @@ TclNRSwitchObjCmd( return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-indexvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-matchvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } @@ -3659,7 +3649,10 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra switch pattern with no body", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3672,10 +3665,12 @@ TclNRSwitchObjCmd( if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { - Tcl_AppendResult(interp, ", this may be due to a " - "comment incorrectly placed outside of a " - "switch body - see the \"switch\" " - "documentation", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ", this may be due to a comment incorrectly" + " placed outside of a switch body - see the" + " \"switch\" documentation", -1); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -3690,9 +3685,11 @@ TclNRSwitchObjCmd( */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "no body specified for pattern \"", - TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no body specified for pattern \"%s\"", + TclGetString(objv[objc-2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -3789,8 +3786,12 @@ TclNRSwitchObjCmd( if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; - rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); + if (info.matches[j].end > 0) { + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); + } else { + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + } /* * Never fails; the object is always clean at this point. @@ -3881,7 +3882,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3895,7 +3896,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3925,6 +3926,7 @@ TclNRSwitchObjCmd( INT2PTR(pc), (ClientData) pattern); return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); } + static int SwitchPostProc( ClientData data[], /* Data passed from Tcl_NRAddCallback above */ @@ -3944,7 +3946,7 @@ SwitchPostProc( */ if (splitObjs) { - ckfree((char *) ctxPtr->line); + ckfree(ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -4011,7 +4013,10 @@ Tcl_ThrowObjCmd( if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { - Tcl_AppendResult(interp, "type must be non-empty list", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "type must be non-empty list", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); return TCL_ERROR; } @@ -4193,14 +4198,19 @@ TclNRTryObjCmd( switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { - Tcl_AppendResult(interp, "finally clause must be last", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "finally clause must be last", -1)); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "NONTERMINAL", NULL); return TCL_ERROR; } else if (i == objc-1) { - Tcl_AppendResult(interp, "wrong # args to finally clause: ", - "must be \"", TclGetString(objv[0]), - " ... finally script\"", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to finally clause: must be" + " \"... finally script\"", -1)); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); return TCL_ERROR; } finallyObj = objv[++i]; @@ -4208,13 +4218,16 @@ TclNRTryObjCmd( case TryOn: /* on code variableList script */ if (i > objc-4) { - Tcl_AppendResult(interp, "wrong # args to on clause: ", - "must be \"", TclGetString(objv[0]), - " ... on code variableList script\"", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to on clause: must be \"... on code" + " variableList script\"", -1)); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); return TCL_ERROR; } - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { + if (TclGetCompletionCodeFromObj(interp, objv[i+1], + &code) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4223,10 +4236,13 @@ TclNRTryObjCmd( case TryTrap: /* trap pattern variableList script */ if (i > objc-4) { - Tcl_AppendResult(interp, "wrong # args to trap clause: ", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to trap clause: " "must be \"... trap pattern variableList script\"", - NULL); + -1)); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); return TCL_ERROR; } code = 1; @@ -4235,6 +4251,8 @@ TclNRTryObjCmd( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); return TCL_ERROR; } info[2] = objv[i+1]; @@ -4262,10 +4280,11 @@ TclNRTryObjCmd( } } if (bodyShared) { - Tcl_AppendResult(interp, - "last non-finally clause must not have a body of \"-\"", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "last non-finally clause must not have a body of \"-\"", -1)); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); return TCL_ERROR; } if (!haveHandlers) { @@ -4499,6 +4518,8 @@ TryPostBody( ((Interp *) interp)->cmdFramePtr, 4*i + 5); handlerFailed: + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); options = During(interp, result, options, NULL); break; @@ -4772,7 +4793,7 @@ TclListLines( int i, length = strlen(listStr); const char *element = NULL, *next = NULL; ContLineLoc *clLocPtr = TclContinuationsGet(listObj); - int *clNext= (clLocPtr ? &clLocPtr->loc[0] : NULL); + int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); for (i = 0; i < n; i++) { TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 473dcb4..160fa3c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -11,12 +11,11 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompCmds.c,v 1.169 2010/04/30 09:23:06 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Prototypes for procedures defined later in this file: @@ -42,6 +41,13 @@ static int PushVarName(Tcl_Interp *interp, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); +static int CompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr, int collect); +static int CompileDictEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr, int collect); + /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -85,6 +91,18 @@ static int PushVarName(Tcl_Interp *interp, mapPtr->loc[eclIndex].next[(word)]) /* + * Often want to issue one of two versions of an instruction based on whether + * the argument will fit in a single byte or not. This makes it much clearer. + */ + +#define Emit14Inst(nm,idx,envPtr) \ + if (idx <= 255) { \ + TclEmitInstInt1(nm##1,idx,envPtr); \ + } else { \ + TclEmitInstInt4(nm##4,idx,envPtr); \ + } + +/* * Flags bits used by PushVarName. */ @@ -188,18 +206,14 @@ TclCompileAppendCmd( if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { - TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); } else { - TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); } } } else { @@ -212,6 +226,245 @@ TclCompileAppendCmd( /* *---------------------------------------------------------------------- * + * TclCompileArray*Cmd -- + * + * Functions called to compile "array" sucommands. + * + * Results: + * All return TCL_OK for a successful compile, and TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "array" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileArrayExistsCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + } + return TCL_OK; +} + +int +TclCompileArraySetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex; + int dataVar, iterVar, keyVar, valVar, infoIndex; + int back, fwd, offsetBack, offsetFwd, savedStackDepth; + ForeachInfo *infoPtr; + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Special case: literal empty value argument is just an "ensure array" + * operation. + */ + + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; + } + + /* + * Prepare for the internal foreach. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr->numLists = 1; + infoPtr->firstValueTemp = dataVar; + infoPtr->loopCtTemp = iterVar; + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0]->numVars = 2; + infoPtr->varLists[0]->varIndexes[0] = keyVar; + infoPtr->varLists[0]->varIndexes[1] = valVar; + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + + /* + * Start issuing instructions to write to the array. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_BITAND, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + PushLiteral(envPtr, "list must have an even number of elements", + strlen("list must have an even number of elements")); + PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", + strlen("-errorCode {TCL ARGUMENT FORMAT}")); + TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr); + TclEmitInt4( 0, envPtr); + envPtr->currStackDepth = savedStackDepth; + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitOpcode( INST_DUP, envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + back = offsetBack - CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, back, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( dataVar, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +int +TclCompileArrayUnsetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int simpleVarName, isScalar, localIndex, savedStackDepth; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + PushVarNameWord(interp, tokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + + if (localIndex >= 0) { + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); + TclEmitInt4( localIndex, envPtr); + } else { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); + TclEmitInstInt1(INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitOpcode( INST_POP, envPtr); + } + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. @@ -245,6 +498,7 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -279,7 +533,8 @@ TclCompileCatchCmd( Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; const char *name; int resultIndex, optsIndex, nameChars, range; - int savedStackDepth = envPtr->currStackDepth; + int initStackDepth = envPtr->currStackDepth; + int savedStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -345,112 +600,168 @@ TclCompileCatchCmd( } /* - * We will compile the catch command. Emit a beginCatch instruction at the - * start of the catch body: the subcommand it controls. + * We will compile the catch command. Declare the exception range that it + * uses. */ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); /* - * If the body is a simple word, compile the instructions to eval it. - * Otherwise, compile instructions to substitute its text without - * catching, a catch instruction that resets the stack to what it was - * before substituting the body, and then an instruction to eval the body. - * Care has to be taken to register the correct startOffset for the catch - * range so that errors in the substitution are not caught. [Bug 219184] + * If the body is a simple word, compile a BEGIN_CATCH instruction, + * followed by the instructions to eval the body. + * Otherwise, compile instructions to substitute the body text before + * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the + * substituted body. + * Care has to be taken to make sure that substitution happens outside the + * catch range so that errors in the substitution are not caught. + * [Bug 219184] + * The reason for duplicating the script is that EVAL_STK would otherwise + * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); } else { CompileTokens(envPtr, cmdTokenPtr, interp); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_EVAL_STK, envPtr); + } + /* Stack at this point: + * nonsimple: script <mark> result + * simple: <mark> result + */ + + if (resultIndex == -1) { + /* + * Special case when neither result nor options are being saved. In + * that case, we can skip quite a bit of the command epilogue; all we + * have to do is drop the result and push the return code (and, of + * course, finish the catch context). + */ + + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "0", 1); + TclEmitInstInt1( INST_JUMP1, 3, envPtr); + envPtr->currStackDepth = savedStackDepth; + ExceptionRangeTarget(envPtr, range, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); ExceptionRangeEnds(envPtr, range); + TclEmitOpcode( INST_END_CATCH, envPtr); + + /* + * Stack at this point: + * nonsimple: script <mark> returnCode + * simple: <mark> returnCode + */ + + goto dropScriptAtEnd; } /* - * The "no errors" epilogue code: store the body's result into the - * variable (if any), push "0" (TCL_OK) as the catch's "no error" result, - * and jump around the "error case" code. Note that we issue the push of - * the return options first so that if alterations happen to the current - * interpreter state during the writing of the variable, we won't see - * them; this results in a slightly complex instruction issuing flow - * (can't exchange, only duplicate and pop). + * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, + * and jump around the "error case" code. */ - if (resultIndex != -1) { - if (optsIndex != -1) { - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - } - if (resultIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); - } - if (optsIndex != -1) { - TclEmitOpcode(INST_POP, envPtr); - if (optsIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - } - TclEmitOpcode(INST_POP, envPtr); PushLiteral(envPtr, "0", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + /* Stack at this point: ?script? <mark> result TCL_OK */ - /* - * The "error case" code: store the body's result into the variable (if - * any), then push the error result code. The initial PC offset here is - * the catch's error target. Note that if we are saving the return - * options, we do that first so the preservation cannot get affected by - * any intermediate result handling. + /* + * Emit the "error case" epilogue. Push the interpreter result and the + * return code. */ envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); - if (resultIndex != -1) { - if (optsIndex != -1) { - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); - } - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - if (resultIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - if (optsIndex != -1) { - if (optsIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - } - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + /* Stack at this point: ?script? */ + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); /* - * Update the target of the jump after the "no errors" code, then emit an - * endCatch instruction at the end of the catch command. + * Update the target of the jump after the "no errors" code. */ + /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - TclEmitOpcode(INST_END_CATCH, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; + /* + * Push the return options if the caller wants them. + */ + + if (optsIndex != -1) { + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + } + + /* + * End the catch + */ + + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode( INST_END_CATCH, envPtr); + + /* + * At this point, the top of the stack is inconveniently ordered: + * ?script? result returnCode ?returnOptions? + * Reverse the stack to bring the result to the top. + */ + + if (optsIndex != -1) { + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + } else { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + } + + /* + * Store the result and remove it from the stack. + */ + + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Stack is now ?script? ?returnOptions? returnCode. + * If the options dict has been requested, it is buried on the stack under + * the return code. Reverse the stack to bring it to the top, store it and + * remove it from the stack. + */ + + if (optsIndex != -1) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + dropScriptAtEnd: + + /* + * Stack is now ?script? result. Get rid of the subst'ed script if it's + * hanging arond. + */ + + if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* + * Result of all this, on either branch, should have been to leave one + * operand -- the return code -- on the stack. + */ + + if (envPtr->currStackDepth != initStackDepth + 1) { + Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", + envPtr->currStackDepth, initStackDepth+1); + } return TCL_OK; } @@ -494,6 +805,7 @@ TclCompileContinueCmd( */ TclEmitOpcode(INST_CONTINUE, envPtr); + PushLiteral(envPtr, "", 0); /* Evil hack! */ return TCL_OK; } @@ -512,25 +824,6 @@ TclCompileContinueCmd( * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. * - * Notes: - * The following commands are in fairly common use and are possibly worth - * bytecoding: - * dict append - * dict create [*] - * dict exists [*] - * dict for - * dict get [*] - * dict incr - * dict keys [*] - * dict lappend - * dict set - * dict unset - * - * In practice, those that are pure-value operators (marked with [*]) can - * probably be left alone (except perhaps [dict get] which is very very - * common) and [dict update] should be considered instead (really big - * win!) - * *---------------------------------------------------------------------- */ @@ -595,6 +888,7 @@ TclCompileDictSetCmd( TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -712,6 +1006,310 @@ TclCompileDictGetCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} + +int +TclCompileDictExistsCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int numWords, i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least two arguments after the command (the single-arg + * case is legal, but too special and magic for us to deal with here). + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + numWords = parsePtr->numWords-1; + + /* + * Now we do the code generation. + */ + + for (i=0 ; i<numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} + +int +TclCompileDictUnsetCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int i, dictVarIndex, nameChars; + const char *name; + + /* + * There must be at least one argument after the variable name for us to + * compile to bytecode. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + /* + * The dictionary variable must be a local scalar that is knowable at + * compile time; anything else exceeds the complexity of the opcode. So + * discover what the index is. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = tokenPtr[1].start; + nameChars = tokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + if (dictVarIndex < 0) { + return TCL_ERROR; + } + + /* + * Remaining words (the key path) can be handled normally. + */ + + for (i=2 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + /* + * Now emit the instruction to do the dict manipulation. + */ + + TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); + TclEmitInt4( dictVarIndex, envPtr); + return TCL_OK; +} + +int +TclCompileDictCreateCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int worker; /* Temp var for building the value in. */ + Tcl_Token *tokenPtr; + Tcl_Obj *keyObj, *valueObj, *dictObj; + const char *bytes; + int i, len; + + if ((parsePtr->numWords & 1) == 0) { + return TCL_ERROR; + } + + /* + * See if we can build the value at compile time... + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + dictObj = Tcl_NewObj(); + Tcl_IncrRefCount(dictObj); + for (i=1 ; i<parsePtr->numWords ; i+=2) { + keyObj = Tcl_NewObj(); + Tcl_IncrRefCount(keyObj); + if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(dictObj); + goto nonConstant; + } + tokenPtr = TokenAfter(tokenPtr); + valueObj = Tcl_NewObj(); + Tcl_IncrRefCount(valueObj); + if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + Tcl_DecrRefCount(dictObj); + goto nonConstant; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + } + + /* + * We did! Excellent. The "verifyDict" is to do type forcing. + */ + + bytes = Tcl_GetStringFromObj(dictObj, &len); + PushLiteral(envPtr, bytes, len); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + Tcl_DecrRefCount(dictObj); + return TCL_OK; + + /* + * Otherwise, we've got to issue runtime code to do the building, which we + * do by [dict set]ting into an unnamed local variable. This requires that + * we are in a context with an LVT. + */ + + nonConstant: + worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (worker < 0) { + return TCL_ERROR; + } + + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, worker, envPtr); + TclEmitOpcode( INST_POP, envPtr); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=1 ; i<parsePtr->numWords ; i+=2) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i+1); + tokenPtr = TokenAfter(tokenPtr); + TclEmitInstInt4( INST_DICT_SET, 1, envPtr); + TclEmitInt4( worker, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( worker, envPtr); + return TCL_OK; +} + +int +TclCompileDictMergeCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + int i, workerIndex, infoIndex, outLoop; + + /* + * Deal with some special edge cases. Note that in the case with one + * argument, the only thing to do is to verify the dict-ness. + */ + + if (parsePtr->numWords < 2) { + PushLiteral(envPtr, "", 0); + return TCL_OK; + } else if (parsePtr->numWords == 2) { + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + return TCL_OK; + } + + /* + * There's real merging work to do. + * + * Allocate some working space. This means we'll only ever compile this + * command when there's an LVT present. + */ + + workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (workerIndex < 0) { + return TCL_ERROR; + } + infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + /* + * Get the first dictionary and verify that it is so. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DICT_VERIFY, envPtr); + Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * For each of the remaining dictionaries... + */ + + outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); + ExceptionRangeStarts(envPtr, outLoop); + for (i=2 ; i<parsePtr->numWords ; i++) { + /* + * Get the dictionary, and merge its pairs into the first dict (using + * a small loop). + */ + + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_SET, 1, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + } + ExceptionRangeEnds(envPtr, outLoop); + TclEmitOpcode( INST_END_CATCH, envPtr); + + /* + * Clean up any state left over. + */ + + Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclEmitInstInt1( INST_JUMP1, 18, envPtr); + + /* + * If an exception happens when starting to iterate over the second (and + * subsequent) dicts. This is strictly not necessary, but it is nice. + */ + + ExceptionRangeTarget(envPtr, outLoop, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( workerIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + return TCL_OK; } @@ -724,11 +1322,42 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); +} + +int +TclCompileDictMapCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +int +CompileDictEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Flag == TCL_EACH_COLLECT to collect and + * construct a new dictionary with the loop + * body result. */ +{ DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; int numVars, endTargetOffset; + int collectVar = -1; /* Index of temp var holding the result + * dict. */ int savedStackDepth = envPtr->currStackDepth; /* Needed because jumps confuse the stack * space calculator. */ @@ -752,12 +1381,25 @@ TclCompileDictForCmd( } /* + * Create temporary variable to capture return values from loop body when + * we're collecting results. + */ + + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + + /* * Check we've got a pair of variables and that they are local variables. * Then extract their indices in the LVT. */ Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size); + TclDStringAppendToken(&buffer, &varsTokenPtr[1]); if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, &argv) != TCL_OK) { Tcl_DStringFree(&buffer); @@ -765,24 +1407,24 @@ TclCompileDictForCmd( } Tcl_DStringFree(&buffer); if (numVars != 2) { - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } nameChars = strlen(argv[0]); if (!TclIsLocalScalar(argv[0], nameChars)) { - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr); nameChars = strlen(argv[1]); if (!TclIsLocalScalar(argv[1], nameChars)) { - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr); - ckfree((char *) argv); + ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { return TCL_ERROR; @@ -804,14 +1446,24 @@ TclCompileDictForCmd( * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * - * First up, get the dictionary and start the iteration. No catching of - * errors at this point. + * First up, initialize the accumulator dictionary if needed. + */ + + if (collect == TCL_EACH_COLLECT) { + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* + * Get the dictionary and start the iteration. No catching of errors at + * this point. */ CompileWord(envPtr, dictTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search @@ -819,7 +1471,7 @@ TclCompileDictForCmd( */ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); /* @@ -827,10 +1479,10 @@ TclCompileDictForCmd( */ bodyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Set up the loop exception targets. @@ -843,9 +1495,17 @@ TclCompileDictForCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(4); + SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); - TclEmitOpcode( INST_POP, envPtr); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_DICT_SET, 1, envPtr); + TclEmitInt4( collectVar, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. @@ -861,11 +1521,11 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Now do the final cleanup for the no-error case (this is where we break @@ -876,10 +1536,11 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration @@ -887,11 +1548,16 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } + TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we @@ -899,24 +1565,31 @@ TclCompileDictForCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - envPtr->currStackDepth = savedStackDepth+2; + envPtr->currStackDepth = savedStackDepth + 2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty - * object. This is done last to promote peephole optimization when it's - * dropped immediately. + * object (or push the accumulator as the result object). This is done + * last to promote peephole optimization when it's dropped immediately. */ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); - PushLiteral(envPtr, "", 0); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } return TCL_OK; } @@ -981,8 +1654,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *) - ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); @@ -1022,7 +1694,7 @@ TclCompileDictUpdateCmd( } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { failedUpdateInfoAssembly: - ckfree((char *) duiPtr); + ckfree(duiPtr); TclStackFree(interp, keyTokenPtrs); return TCL_ERROR; } @@ -1038,15 +1710,16 @@ TclCompileDictUpdateCmd( for (i=0 ; i<numVars ; i++) { CompileWord(envPtr, keyTokenPtrs[i], interp, i); } - TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInstInt4( INST_LIST, numVars, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); envPtr->currStackDepth++; + SetLineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); envPtr->currStackDepth = savedStackDepth; ExceptionRangeEnds(envPtr, range); @@ -1056,10 +1729,10 @@ TclCompileDictUpdateCmd( * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. @@ -1074,20 +1747,21 @@ TclCompileDictUpdateCmd( */ ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1194,7 +1868,272 @@ TclCompileDictLappendCmd( } CompileWord(envPtr, keyTokenPtr, interp, 3); CompileWord(envPtr, valueTokenPtr, interp, 4); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + return TCL_OK; +} + +int +TclCompileDictWithCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; + int bodyIsEmpty = 1; + Tcl_Token *varTokenPtr, *tokenPtr; + int savedStackDepth = envPtr->currStackDepth; + JumpFixup jumpFixup; + const char *ptr, *end; + + /* + * There must be at least one argument after the command. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + /* + * Parse the command (trivially). Expect the following: + * dict with <any (varName)> ?<any> ...? <literal> + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(varTokenPtr); + for (i=3 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Test if the last word is an empty script; if so, we can compile it in + * all cases, but if it is non-empty we need local variable table entries + * to hold the temporary variables (used to keep stack usage simple). + */ + + for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { + if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + bodyIsEmpty = 0; + break; + } + } + + /* + * Determine if we're manipulating a dict in a simple local variable. + */ + + gotPath = (parsePtr->numWords > 3); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD && + TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) { + dictVar = TclFindCompiledLocal(varTokenPtr[1].start, + varTokenPtr[1].size, 1, envPtr); + } + + /* + * Special case: an empty body means we definitely have no need to issue + * try-finally style code or to allocate local variable table entries for + * storing temporaries. Still need to do both INST_DICT_EXPAND and + * INST_DICT_RECOMBINE_* though, because we can't determine if we're free + * of traces. + */ + + if (bodyIsEmpty) { + if (dictVar >= 0) { + if (gotPath) { + /* + * Case: Path into dict in LVT with empty body. + */ + + tokenPtr = TokenAfter(varTokenPtr); + for (i=2 ; i<parsePtr->numWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + } else { + /* + * Case: Direct dict in LVT with empty body. + */ + + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + PushLiteral(envPtr, "", 0); + } + } else { + if (gotPath) { + /* + * Case: Path into dict in non-simple var with empty body. + */ + + tokenPtr = varTokenPtr; + for (i=1 ; i<parsePtr->numWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + PushLiteral(envPtr, "", 0); + } else { + /* + * Case: Direct dict in non-simple var with empty body. + */ + + CompileWord(envPtr, varTokenPtr, interp, 0); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + PushLiteral(envPtr, "", 0); + } + } + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; + } + + /* + * OK, we have a non-trivial body. This means that the focus is on + * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes + * in the 'finally' clause. + * + * Start by allocating local (unnamed, untraced) working variables. + */ + + if (dictVar == -1) { + varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + } else { + varNameTmp = -1; + } + if (gotPath) { + pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + } else { + pathTmp = -1; + } + keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + + /* + * Issue instructions. First, the part to expand the dictionary. + */ + + if (varNameTmp > -1) { + CompileWord(envPtr, varTokenPtr, interp, 0); + Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); + } + tokenPtr = TokenAfter(varTokenPtr); + if (gotPath) { + for (i=2 ; i<parsePtr->numWords-1 ; i++) { + CompileWord(envPtr, tokenPtr, interp, i-1); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); + Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + if (dictVar == -1) { + TclEmitOpcode( INST_LOAD_STK, envPtr); + } else { + Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + } + if (gotPath) { + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } + TclEmitOpcode( INST_DICT_EXPAND, envPtr); + Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now the body of the [dict with]. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + + ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth++; + SetLineInformation(parsePtr->numWords-1); + CompileBody(envPtr, tokenPtr, interp); + envPtr->currStackDepth = savedStackDepth; + ExceptionRangeEnds(envPtr, range); + + /* + * Now fold the results back into the dictionary in the OK case. + */ + + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp > -1) { + Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); + } + if (gotPath) { + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } + Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); + if (dictVar == -1) { + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + } else { + TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + } + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Now fold the results back into the dictionary in the exception case. + */ + + ExceptionRangeTarget(envPtr, range, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + if (varNameTmp > -1) { + Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); + } + if (parsePtr->numWords > 3) { + Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } + Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); + if (dictVar == -1) { + TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + } else { + TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + } + TclEmitOpcode( INST_RETURN_STK, envPtr); + + /* + * Prepare for the start of the next command. + */ + + envPtr->currStackDepth = savedStackDepth + 1; + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + } return TCL_OK; } @@ -1228,7 +2167,7 @@ DupDictUpdateInfo( dui1Ptr = clientData; len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); - dui2Ptr = (DictUpdateInfo *) ckalloc(len); + dui2Ptr = ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } @@ -1290,6 +2229,7 @@ TclCompileErrorCmd( * However, we only deal with the case where there is just a message. */ Tcl_Token *messageTokenPtr; + int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { @@ -1300,6 +2240,7 @@ TclCompileErrorCmd( PushLiteral(envPtr, "-code error -level 0", 20); CompileWord(envPtr, messageTokenPtr, interp, 1); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1541,6 +2482,39 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); +} + +/* + *---------------------------------------------------------------------- + * + * CompileEachloopCmd -- + * + * Procedure called to compile the "foreach" and "lmap" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileEachloopCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Select collecting or accumulating mode + * (TCL_EACH_*) */ +{ Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData @@ -1549,6 +2523,9 @@ TclCompileForeachCmd( * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ + int collectVar = -1; /* Index of temp var holding the result var + * index. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; @@ -1632,7 +2609,7 @@ TclCompileForeachCmd( */ Tcl_DStringInit(&varList); - Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size); + TclDStringAppendToken(&varList, &tokenPtr[1]); code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); @@ -1664,6 +2641,14 @@ TclCompileForeachCmd( loopIndex++; } + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + /* * We will compile the foreach command. Reserve (numLists + 1) temporary * variables: @@ -1692,8 +2677,8 @@ TclCompileForeachCmd( * pointing to the ForeachInfo structure. */ - infoPtr = (ForeachInfo *) ckalloc((unsigned) - sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); + infoPtr = ckalloc(sizeof(ForeachInfo) + + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; @@ -1701,8 +2686,8 @@ TclCompileForeachCmd( ForeachVarList *varListPtr; numVars = varcList[loopIndex]; - varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); + varListPtr = ckalloc(sizeof(ForeachVarList) + + numVars * sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; @@ -1733,21 +2718,27 @@ TclCompileForeachCmd( SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); - if (tempVar <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); loopIndex++; } } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == TCL_EACH_COLLECT) { + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* * Initialize the temporary var that holds the count of loop iterations. */ - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); /* * Top of loop code: assign each loop variable and check whether @@ -1755,7 +2746,7 @@ TclCompileForeachCmd( */ ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* @@ -1767,7 +2758,11 @@ TclCompileForeachCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); + + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); + } + TclEmitOpcode( INST_POP, envPtr); /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if @@ -1817,17 +2812,24 @@ TclCompileForeachCmd( ExceptionRangeTarget(envPtr, range, breakOffset); /* - * The foreach command's result is an empty string. + * The command's result is an empty string if not collecting, or the + * list of results from evaluating the loop body. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } else { + PushLiteral(envPtr, "", 0); + } envPtr->currStackDepth = savedStackDepth + 1; done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { - ckfree((char *) varvList[loopIndex]); + ckfree(varvList[loopIndex]); } } TclStackFree(interp, (void *)varvList); @@ -1866,8 +2868,8 @@ DupForeachInfo( register ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = (ForeachInfo *) ckalloc((unsigned) - sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); + dupPtr = ckalloc(sizeof(ForeachInfo) + + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; @@ -1875,8 +2877,8 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr = ckalloc(sizeof(ForeachVarList) + + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; @@ -1917,9 +2919,9 @@ FreeForeachInfo( for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - ckfree((char *) listPtr); + ckfree(listPtr); } - ckfree((char *) infoPtr); + ckfree(infoPtr); } /* @@ -1982,6 +2984,226 @@ PrintForeachInfo( /* *---------------------------------------------------------------------- * + * TclCompileFormatCmd -- + * + * Procedure called to compile the "format" command. Handles cases that + * can be done as constants or simple string concatenation only. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "format" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileFormatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + Tcl_Obj **objv, *formatObj, *tmpObj; + char *bytes, *start; + int i, j, len; + + /* + * Don't handle any guaranteed-error cases. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + /* + * Check if the argument words are all compile-time-known literals; that's + * a case we can handle by compiling to a constant. + */ + + formatObj = Tcl_NewObj(); + Tcl_IncrRefCount(formatObj); + tokenPtr = TokenAfter(tokenPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + + objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + objv[i] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[i]); + if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { + goto checkForStringConcatCase; + } + } + + /* + * Everything is a literal, so the result is constant too (or an error if + * the format is broken). Do the format now. + */ + + tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), + parsePtr->numWords-2, objv); + for (; --i>=0 ;) { + Tcl_DecrRefCount(objv[i]); + } + ckfree(objv); + Tcl_DecrRefCount(formatObj); + if (tmpObj == NULL) { + return TCL_ERROR; + } + + /* + * Not an error, always a constant result, so just push the result as a + * literal. Job done. + */ + + bytes = Tcl_GetStringFromObj(tmpObj, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(tmpObj); + return TCL_OK; + + checkForStringConcatCase: + /* + * See if we can generate a sequence of things to concatenate. This + * requires that all the % sequences be %s or %%, as everything else is + * sufficiently complex that we don't bother. + * + * First, get the state of the system relatively sensible (cleaning up + * after our attempt to spot a literal). + */ + + for (; --i>=0 ;) { + Tcl_DecrRefCount(objv[i]); + } + ckfree(objv); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(tokenPtr); + i = 0; + + /* + * Now scan through and check for non-%s and non-%% substitutions. + */ + + for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { + if (*bytes == '%') { + bytes++; + if (*bytes == 's') { + i++; + continue; + } else if (*bytes == '%') { + continue; + } + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + } + + /* + * Check if the number of things to concatenate will fit in a byte. + */ + + if (i+2 != parsePtr->numWords || i > 125) { + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } + + /* + * Generate the pushes of the things to concatenate, a sequence of + * literals and compiled tokens (of which at least one is non-literal or + * we'd have the case in the first half of this function) which we will + * concatenate. + */ + + i = 0; /* The count of things to concat. */ + j = 2; /* The index into the argument tokens, for + * TIP#280 handling. */ + start = Tcl_GetString(formatObj); + /* The start of the currently-scanned literal + * in the format string. */ + tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal + * being built. */ + for (bytes = start ; *bytes ; bytes++) { + if (*bytes == '%') { + Tcl_AppendToObj(tmpObj, start, bytes - start); + if (*++bytes == '%') { + Tcl_AppendToObj(tmpObj, "%", 1); + } else { + char *b = Tcl_GetStringFromObj(tmpObj, &len); + + /* + * If there is a non-empty literal from the format string, + * push it and reset. + */ + + if (len > 0) { + PushLiteral(envPtr, b, len); + Tcl_DecrRefCount(tmpObj); + tmpObj = Tcl_NewObj(); + i++; + } + + /* + * Push the code to produce the string that would be + * substituted with %s, except we'll be concatenating + * directly. + */ + + CompileWord(envPtr, tokenPtr, interp, j); + tokenPtr = TokenAfter(tokenPtr); + j++; + i++; + } + start = bytes + 1; + } + } + + /* + * Handle the case of a trailing literal. + */ + + Tcl_AppendToObj(tmpObj, start, bytes - start); + bytes = Tcl_GetStringFromObj(tmpObj, &len); + if (len > 0) { + PushLiteral(envPtr, bytes, len); + i++; + } + Tcl_DecrRefCount(tmpObj); + Tcl_DecrRefCount(formatObj); + + if (i > 1) { + /* + * Do the concatenation, which produces the result. + */ + + TclEmitInstInt1(INST_CONCAT1, i, envPtr); + } else { + /* + * EVIL HACK! Force there to be a string representation in the case + * where there's just a "%s" in the format; case covered by the test + * format-20.1 (and it is horrible...) + */ + + TclEmitOpcode(INST_DUP, envPtr); + PushLiteral(envPtr, "", 0); + TclEmitOpcode(INST_STR_EQ, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileGlobalCmd -- * * Procedure called to compile the "global" command. @@ -2042,14 +3264,14 @@ TclCompileGlobalCmd( } CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -2448,43 +3670,41 @@ TclCompileIncrCmd( * Emit the instruction to increment the variable. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } + if (!simpleVarName) { + if (haveImmValue) { + TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_STK, envPtr); + } + } else if (isScalar) { /* Simple scalar variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); - } + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); - } + TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); } } - } else { /* Non-simple variable name. */ - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { /* Simple array variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } } else { - TclEmitOpcode(INST_INCR_STK, envPtr); + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); + } } } @@ -2494,22 +3714,105 @@ TclCompileIncrCmd( /* *---------------------------------------------------------------------- * - * TclCompileInfoExistsCmd -- + * TclCompileInfo*Cmd -- * - * Procedure called to compile the "info exists" subcommand. + * Procedures called to compile "info" subcommands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "info exists" - * subcommand at runtime. + * Instructions are added to envPtr to execute the "info" subcommand at + * runtime. * *---------------------------------------------------------------------- */ int +TclCompileInfoCommandsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + + /* + * We require one compile-time known argument for the case we can compile. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + goto notCompilable; + } + bytes = Tcl_GetString(objPtr); + + /* + * We require that the argument start with "::" and not have any of "*\[?" + * in it. (Theoretically, we should look in only the final component, but + * the difference is so slight given current naming practices.) + */ + + if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { + goto notCompilable; + } + Tcl_DecrRefCount(objPtr); + + /* + * Confirmed as a literal that will not frighten the horses. Compile. Note + * that the result needs to be list-ified. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_STR_LEN, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_LIST, 1, envPtr); + return TCL_OK; + + notCompilable: + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; +} + +int +TclCompileInfoCoroutineCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info coroutine] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + return TCL_OK; +} + +int TclCompileInfoExistsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -2542,24 +3845,134 @@ TclCompileInfoExistsCmd( * Emit instruction to check the variable for existence. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); - } + if (!simpleVarName) { + TclEmitOpcode( INST_EXIST_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_STK, envPtr); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); - } + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); } } else { - TclEmitOpcode(INST_EXIST_STK, envPtr); + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +int +TclCompileInfoLevelCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info level] without arguments or with a single argument. + */ + + if (parsePtr->numWords == 1) { + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } else { + DefineLineInformation; /* TIP #280 */ + + /* + * Compile the argument, then add the instruction to convert it into a + * list of arguments. + */ + + SetLineInformation(1); + CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } + return TCL_OK; +} + +int +TclCompileInfoObjectClassCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectIsACmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * We only handle [info object isa object <somevalue>]. The first three + * words are compressed to a single token by the ensemble compilation + * engine. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 + || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Issue the code. + */ + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectNamespaceCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_NS, envPtr); return TCL_OK; } @@ -2647,26 +4060,20 @@ TclCompileLappendCmd( * LOAD/STORE instructions. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); - } + if (!simpleVarName) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); - } + Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); } } else { - TclEmitOpcode(INST_LAPPEND_STK, envPtr); + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + } } return TCL_OK; @@ -2739,50 +4146,44 @@ TclCompileLassignCmd( * the stack and assign it to the variable. */ - if (simpleVarName) { - if (isScalar) { - if (localIndex >= 0) { - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } + if (!simpleVarName) { + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else if (isScalar) { + if (localIndex >= 0) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); } } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_STK, envPtr); + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } } - TclEmitOpcode(INST_POP, envPtr); } /* * Generate code to leave the rest of the list on the stack. */ - TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4(-2, envPtr); /* -2 == "end" */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( -2 /* == "end" */, envPtr); return TCL_OK; } @@ -2838,19 +4239,30 @@ TclCompileLindexCmd( tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); + if (result == TCL_OK && idx > -2) { + result = TCL_ERROR; + } + } TclDecrRefCount(tmpObj); - if (result == TCL_OK && idx >= 0) { + if (result == TCL_OK) { /* - * All checks have been completed, and we have exactly this - * construct: + * All checks have been completed, and we have exactly one of + * these constructs: * lindex <arbitraryValue> <posInt> + * lindex <arbitraryValue> end-<posInt> * This is best compiled as a push of the arbitrary value followed * by an "immediate lindex" which is the most efficient variety. */ CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } @@ -2876,9 +4288,9 @@ TclCompileLindexCmd( */ if (numWords == 3) { - TclEmitOpcode(INST_LIST_INDEX, envPtr); + TclEmitOpcode( INST_LIST_INDEX, envPtr); } else { - TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); } return TCL_OK; @@ -2912,6 +4324,8 @@ TclCompileListCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr; + int i, numWords; /* * If we're not in a procedure, don't compile. @@ -2932,17 +4346,13 @@ TclCompileListCmd( * Push the all values onto the stack. */ - Tcl_Token *valueTokenPtr; - int i, numWords; - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); + TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); } return TCL_OK; @@ -2984,7 +4394,227 @@ TclCompileLlengthCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode(INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLrangeCmd -- + * + * How to compile the "lrange" command. We only bother because we needed + * the opcode anyway for "lassign". + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLrangeCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, result; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the first index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx1); + if (result == TCL_OK) { + if (idx1 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); + if (result == TCL_OK && idx1 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Parse the second index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx2); + if (result == TCL_OK) { + if (idx2 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); + if (result == TCL_OK && idx2 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Issue instructions. It's not safe to skip doing the LIST_RANGE, as + * we've not proved that the 'list' argument is really a list. Not that it + * is worth trying to do that given current knowledge. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where there are no elements to insert and where both the 'first' and + * 'last' arguments are constant and one can be deterined to be at the + * end of the list. (This is the case that could also be written with + * "lrange".) + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, result, guaranteedDropAll = 0; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the first index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx1); + if (result == TCL_OK) { + if (idx1 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); + if (result == TCL_OK && idx1 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Parse the second index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx2); + if (result == TCL_OK) { + if (idx2 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); + if (result == TCL_OK && idx2 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Sanity check: can only issue when we're removing a range at one or + * other end of the list. If we're at one end or the other, convert the + * indices into the equivalent for an [lrange]. + */ + + if (idx1 == 0) { + if (idx2 == -2) { + guaranteedDropAll = 1; + } + idx1 = idx2 + 1; + idx2 = -2; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + } else { + return TCL_ERROR; + } + + /* + * Issue instructions. It's not safe to skip doing the LIST_RANGE, as + * we've not proved that the 'list' argument is really a list. Not that it + * is worth trying to do that given current knowledge. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (guaranteedDropAll) { + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + } else { + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + } return TCL_OK; } @@ -3090,7 +4720,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 1; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* @@ -3103,7 +4733,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 2; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* @@ -3111,22 +4741,18 @@ TclCompileLsetCmd( */ if (!simpleVarName) { - TclEmitOpcode(INST_LOAD_STK, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); } } @@ -3135,9 +4761,9 @@ TclCompileLsetCmd( */ if (parsePtr->numWords == 4) { - TclEmitOpcode(INST_LSET_LIST, envPtr); + TclEmitOpcode( INST_LSET_LIST, envPtr); } else { - TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* @@ -3145,22 +4771,18 @@ TclCompileLsetCmd( */ if (!simpleVarName) { - TclEmitOpcode(INST_STORE_STK, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); } } @@ -3170,10 +4792,42 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileNamespaceCmd -- + * TclCompileLmapCmd -- * - * Procedure called to compile the "namespace" command; currently, only - * the subcommand "namespace upvar" is compiled to bytecodes. + * Procedure called to compile the "lmap" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lmap" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLmapCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileNamespace*Cmd -- + * + * Procedures called to compile the "namespace" command; currently, only + * the subcommands "namespace current" and "namespace upvar" are compiled + * to bytecodes, and the latter only inside a procedure(-like) context. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -3187,7 +4841,7 @@ TclCompileLsetCmd( */ int -TclCompileNamespaceCmd( +TclCompileNamespaceCurrentCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ @@ -3195,30 +4849,168 @@ TclCompileNamespaceCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + /* + * Only compile [namespace current] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceCodeCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - if (envPtr->procPtr == NULL) { + if (parsePtr->numWords != 2) { return TCL_ERROR; } + tokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Only compile [namespace upvar ...]: needs an odd number of args, >=5 + * The specification of [namespace code] is rather shocking, in that it is + * supposed to check if the argument is itself the result of [namespace + * code] and not apply itself in that case. Which is excessively cautious, + * but what the test suite checks for. */ - numWords = parsePtr->numWords; - if (!(numWords%2) || (numWords < 5)) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 + && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { + /* + * Technically, we could just pass a literal '::namespace inscope ' + * term through, but that's something which really shouldn't be + * occurring as something that the user writes so we'll just punt it. + */ + return TCL_ERROR; } /* - * Check if the second argument is "upvar" + * Now we can compile using the same strategy as [namespace code]'s normal + * implementation does internally. Note that we can't bind the namespace + * name directly here, because TclOO plays complex games with namespaces; + * the value needs to be determined at runtime for safety. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ - || strncmp(tokenPtr->start, "upvar", 5)) { + PushLiteral(envPtr, "::namespace", 11); + PushLiteral(envPtr, "inscope", 7); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST, 4, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceQualifiersCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + int off; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "0", 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + off = CurrentOffset(envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_SUB, envPtr); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_INDEX, envPtr); + PushLiteral(envPtr, ":", 1); + TclEmitOpcode( INST_STR_EQ, envPtr); + off = off - CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceTailCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + JumpFixup jumpFixup; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Take care; only add 2 to found index if the string was actually found. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + PushLiteral(envPtr, "0", 1); + TclEmitOpcode( INST_GE, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + PushLiteral(envPtr, "2", 1); + TclEmitOpcode( INST_ADD, envPtr); + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + PushLiteral(envPtr, "end", 3); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceUpvarCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an even number of args, >=4 + */ + + numWords = parsePtr->numWords; + if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -3226,7 +5018,7 @@ TclCompileNamespaceCmd( * Push the namespace */ - tokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); /* @@ -3236,7 +5028,7 @@ TclCompileNamespaceCmd( */ localTokenPtr = tokenPtr; - for (i=4; i<=numWords; i+=2) { + for (i=3; i<=numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); @@ -3247,17 +5039,63 @@ TclCompileNamespaceCmd( if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } + +int +TclCompileNamespaceWhichCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *opt; + int idx; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + idx = 1; + + /* + * If there's an option, check that it's "-command". We don't handle + * "-variable" (currently) and anything else is an error. + */ + + if (parsePtr->numWords == 3) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + opt = tokenPtr + 1; + if (opt->size < 2 || opt->size > 8 + || strncmp(opt->start, "-command", opt->size) != 0) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + idx++; + } + + /* + * Issue the bytecode. + */ + + CompileWord(envPtr, tokenPtr, interp, idx); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -3405,9 +5243,9 @@ TclCompileRegexpCmd( if (simple) { if (exact && !nocase) { - TclEmitOpcode(INST_STR_EQ, envPtr); + TclEmitOpcode( INST_STR_EQ, envPtr); } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); } } else { /* @@ -3418,7 +5256,7 @@ TclCompileRegexpCmd( int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + TclEmitInstInt1( INST_REGEXP, cflags, envPtr); } return TCL_OK; @@ -3427,6 +5265,180 @@ TclCompileRegexpCmd( /* *---------------------------------------------------------------------- * + * TclCompileRegsubCmd -- + * + * Procedure called to compile the "regsub" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regsub" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegsubCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + /* + * We only compile the case with [regsub -all] where the pattern is both + * known at compile time and simple (i.e., no RE metacharacters). That is, + * the pattern must be translatable into a glob like "*foo*" with no other + * glob metacharacters inside it; there must be some "foo" in there too. + * The substitution string must also be known at compile time and free of + * metacharacters ("\digit" and "&"). Finally, there must not be a + * variable mentioned in the [regsub] to write the result back to (because + * we can't get the count of substitutions that would be the result in + * that case). The key is that these are the conditions under which a + * [string map] could be used instead, in particular a [string map] of the + * form we can compile to bytecode. + * + * In short, we look for: + * + * regsub -all [--] simpleRE string simpleReplacement + * + * The only optional part is the "--", and no other options are handled. + */ + + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *stringTokenPtr; + Tcl_Obj *patternObj = NULL, *replacementObj = NULL; + Tcl_DString pattern; + const char *bytes; + int len, exact, result = TCL_ERROR; + + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + return TCL_ERROR; + } + + /* + * Parse the "-all", which must be the first argument (other options not + * supported, non-"-all" substitution we can't compile). + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 + || strncmp(tokenPtr[1].start, "-all", 4)) { + return TCL_ERROR; + } + + /* + * Get the pattern into patternObj, checking for "--" in the process. + */ + + Tcl_DStringInit(&pattern); + tokenPtr = TokenAfter(tokenPtr); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + if (Tcl_GetString(patternObj)[0] == '-') { + if (strcmp(Tcl_GetString(patternObj), "--") != 0 + || parsePtr->numWords == 5) { + goto done; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DecrRefCount(patternObj); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + } else if (parsePtr->numWords == 6) { + goto done; + } + + /* + * Identify the code which produces the string to apply the substitution + * to (stringTokenPtr), and the replacement string (into replacementObj). + */ + + stringTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(stringTokenPtr); + replacementObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { + goto done; + } + + /* + * Next, higher-level checks. Is the RE a very simple glob? Is the + * replacement "simple"? + */ + + bytes = Tcl_GetStringFromObj(patternObj, &len); + if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + goto done; + } + bytes = Tcl_DStringValue(&pattern); + if (*bytes++ != '*') { + goto done; + } + while (1) { + switch (*bytes) { + case '*': + if (bytes[1] == '\0') { + /* + * OK, we've proved there are no metacharacters except for the + * '*' at each end. + */ + + len = Tcl_DStringLength(&pattern) - 2; + if (len > 0) { + goto isSimpleGlob; + } + + /* + * The pattern is "**"! I believe that should be impossible, + * but we definitely can't handle that at all. + */ + } + case '\0': case '?': case '[': case '\\': + goto done; + } + bytes++; + } + isSimpleGlob: + for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + switch (*bytes) { + case '\\': case '&': + goto done; + } + } + + /* + * Proved the simplicity constraints! Time to issue the code. + */ + + result = TCL_OK; + bytes = Tcl_DStringValue(&pattern) + 1; + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + TclEmitOpcode( INST_STR_MAP, envPtr); + + done: + Tcl_DStringFree(&pattern); + if (patternObj) { + Tcl_DecrRefCount(patternObj); + } + if (replacementObj) { + Tcl_DecrRefCount(replacementObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. @@ -3459,6 +5471,7 @@ TclCompileReturnCmd( int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; + int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ @@ -3481,6 +5494,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -3613,9 +5627,10 @@ TclCompileSyntaxError( int numBytes; const char *bytes = TclGetStringFromObj(msg, &numBytes); + TclErrorStackResetIf(interp, bytes, numBytes); TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, - Tcl_GetReturnOptions(interp, TCL_ERROR)); + TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); } /* @@ -3715,14 +5730,14 @@ TclCompileUpvarCmd( if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); } /* * Pop the frame index, and set the result to empty */ - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -3787,7 +5802,7 @@ TclCompileVariableCmd( } CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); + TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); if (i != numWords) { /* @@ -3795,12 +5810,8 @@ TclCompileVariableCmd( */ CompileWord(envPtr, valueTokenPtr, interp, 1); - if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } } @@ -3908,6 +5919,69 @@ IndexTailVarIfKnown( return localIndex; } +int +TclCompileObjectSelfCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * We only handle [self] and [self object] (which is the same operation). + * These are the only very common operations on [self] for which + * bytecoding is at all reasonable. + */ + + if (parsePtr->numWords == 1) { + goto compileSelfObject; + } else if (parsePtr->numWords == 2) { + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { + return TCL_ERROR; + } + + subcmd = tokenPtr + 1; + if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + goto compileSelfObject; + } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + goto compileSelfNamespace; + } + } + + /* + * Can't compile; handle with runtime call. + */ + + return TCL_ERROR; + + compileSelfObject: + + /* + * This delegates the entire problem to a single opcode. + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + return TCL_OK; + + compileSelfNamespace: + + /* + * This is formally only correct with TclOO methods as they are currently + * implemented; it assumes that the current namespace is invariably when a + * TclOO context is present is the object's namespace, and that's + * technically only something that's a matter of current policy. But it + * avoids creating another opcode, so that's all good! + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8fef58d..7bead0d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -13,8 +13,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.9 2010/05/28 09:11:31 dkf Exp $ */ #include "tclInt.h" @@ -135,6 +133,8 @@ const AuxDataType tclJumptableInfoType = { #define OP(name) TclEmitOpcode(INST_##name, envPtr) #define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) #define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) +#define OP14(name,val1,val2) \ + TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ @@ -251,18 +251,18 @@ TclCompileSetCmd( /* *---------------------------------------------------------------------- * - * TclCompileStringCmpCmd -- + * TclCompileString*Cmd -- * - * Procedure called to compile the simplest and most common form of the - * "string compare" command. + * Procedures called to compile various subcommands of the "string" + * command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "string compare" - * command at runtime. + * Instructions are added to envPtr to execute the "string" command at + * runtime. * *---------------------------------------------------------------------- */ @@ -298,25 +298,6 @@ TclCompileStringCmpCmd( TclEmitOpcode(INST_STR_CMP, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringEqualCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string equal" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string equal" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringEqualCmd( @@ -349,25 +330,70 @@ TclCompileStringEqualCmd( TclEmitOpcode(INST_STR_EQ, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringIndexCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string index" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string index" command - * at runtime. - * - *---------------------------------------------------------------------- - */ + +int +TclCompileStringFirstCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + OP(STR_FIND); + return TCL_OK; +} + +int +TclCompileStringLastCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + OP(STR_FIND_LAST); + return TCL_OK; +} int TclCompileStringIndexCmd( @@ -396,25 +422,6 @@ TclCompileStringIndexCmd( TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringMatchCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string match" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string match" command - * at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringMatchCmd( @@ -496,25 +503,6 @@ TclCompileStringMatchCmd( } return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringLenCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string length" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string length" - * command at runtime. - * - *---------------------------------------------------------------------- - */ int TclCompileStringLenCmd( @@ -555,6 +543,158 @@ TclCompileStringLenCmd( TclDecrRefCount(objPtr); return TCL_OK; } + +int +TclCompileStringMapCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *mapTokenPtr, *stringTokenPtr; + Tcl_Obj *mapObj, **objv; + char *bytes; + int len; + + /* + * We only handle the case: + * + * string map {foo bar} $thing + * + * That is, a literal two-element list (doesn't need to be brace-quoted, + * but does need to be compile-time knowable) and any old argument (the + * thing to map). + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + mapTokenPtr = TokenAfter(parsePtr->tokenPtr); + stringTokenPtr = TokenAfter(mapTokenPtr); + mapObj = Tcl_NewObj(); + Tcl_IncrRefCount(mapObj); + if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (len != 2) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } + + /* + * Now issue the opcodes. Note that in the case that we know that the + * first word is an empty word, we don't issue the map at all. That is the + * correct semantics for mapping. + */ + + bytes = Tcl_GetStringFromObj(objv[0], &len); + if (len == 0) { + CompileWord(envPtr, stringTokenPtr, interp, 2); + } else { + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(objv[1], &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, 2); + OP(STR_MAP); + } + Tcl_DecrRefCount(mapObj); + return TCL_OK; +} + +int +TclCompileStringRangeCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; + Tcl_Obj *tmpObj; + int idx1, idx2, result; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + stringTokenPtr = TokenAfter(parsePtr->tokenPtr); + fromTokenPtr = TokenAfter(stringTokenPtr); + toTokenPtr = TokenAfter(fromTokenPtr); + + /* + * Parse the first index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tmpObj = Tcl_NewObj(); + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { + if (idx1 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { + if (idx1 <= -2) { + result = TCL_OK; + } + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + goto nonConstantIndices; + } + + /* + * Parse the second index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tmpObj = Tcl_NewObj(); + result = TCL_ERROR; + if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { + if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { + if (idx2 >= 0) { + result = TCL_OK; + } + } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { + if (idx2 <= -2) { + result = TCL_OK; + } + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + goto nonConstantIndices; + } + + /* + * Push the operand onto the stack and then the substring operation. + */ + + CompileWord(envPtr, stringTokenPtr, interp, 1); + OP44( STR_RANGE_IMM, idx1, idx2); + return TCL_OK; + + /* + * Push the operands onto the stack and then the substring operation. + */ + + nonConstantIndices: + CompileWord(envPtr, stringTokenPtr, interp, 1); + CompileWord(envPtr, fromTokenPtr, interp, 2); + CompileWord(envPtr, toTokenPtr, interp, 3); + OP( STR_RANGE); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -690,19 +830,48 @@ TclSubstCompile( count++; continue; case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, NULL, buf); + length = TclParseBackslash(tokenPtr->start, tokenPtr->size, + NULL, buf); literal = TclRegisterNewLiteral(envPtr, buf, length); TclEmitPush(literal, envPtr); count++; continue; + case TCL_TOKEN_VARIABLE: + /* + * Check for simple variable access; see if we can only generate + * TCL_OK or TCL_ERROR from the substituted variable read; if so, + * there is no need to generate elaborate exception-management + * code. Note that the first component of TCL_TOKEN_VARIABLE is + * always TCL_TOKEN_TEXT... + */ + + if (tokenPtr->numComponents > 1) { + int i, foundCommand = 0; + + for (i=2 ; i<=tokenPtr->numComponents ; i++) { + if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { + foundCommand = 1; + break; + } + } + if (foundCommand) { + break; + } + } + + envPtr->line = bline; + TclCompileVarSubst(interp, tokenPtr, envPtr); + bline = envPtr->line; + count++; + continue; } while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + OP1( CONCAT1, 255); count -= 254; } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1( CONCAT1, count); count = 1; } @@ -717,13 +886,13 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - CurrentOffset(envPtr) - startFixup.codeOffset); + (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } envPtr->line = bline; catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr); + OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); switch (tokenPtr->type) { @@ -744,20 +913,20 @@ TclSubstCompile( ExceptionRangeEnds(envPtr, catchRange); /* Substitution produced TCL_OK */ - TclEmitOpcode(INST_END_CATCH, envPtr); + OP( END_CATCH); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - TclEmitOpcode(INST_END_CATCH, envPtr); - TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( RETURN_CODE_BRANCH); /* ERROR -> reraise it */ - TclEmitOpcode(INST_RETURN_STK, envPtr); - TclEmitOpcode(INST_NOP, envPtr); + OP( RETURN_STK); + OP( NOP); /* RETURN */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); @@ -774,43 +943,43 @@ TclSubstCompile( /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - CurrentOffset(envPtr) - breakFixup.codeOffset); + (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); + OP( POP); breakJump = CurrentOffset(envPtr) - breakOffset; if (breakJump > 127) { - TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr); + OP4(JUMP4, -breakJump); } else { - TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr); + OP1(JUMP1, -breakJump); } /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - CurrentOffset(envPtr) - continueFixup.codeOffset); + (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); + OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - CurrentOffset(envPtr) - returnFixup.codeOffset); + (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - CurrentOffset(envPtr) - otherFixup.codeOffset); + (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* * Pull the result to top of stack, discard options dict. */ - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_POP, envPtr); + OP4( REVERSE, 2); + OP( POP); /* * We've emitted several POP instructions, and the automatic @@ -826,28 +995,27 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - CurrentOffset(envPtr) - okFixup.codeOffset); + (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1(CONCAT1, count); count = 1; } /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - CurrentOffset(envPtr) - endFixup.codeOffset); + (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } - while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + OP1( CONCAT1, 255); count -= 254; } if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); + OP1( CONCAT1, count); } Tcl_FreeParse(&parse); @@ -855,6 +1023,7 @@ TclSubstCompile( if (state != NULL) { Tcl_RestoreInterpState(interp, state); TclCompileSyntaxError(interp, envPtr); + TclAdjustStackDepth(-1, envPtr); } /* Final target of the multi-jump from all BREAKs */ @@ -898,9 +1067,11 @@ TclCompileSwitchCmd( { Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ int numWords; /* Number of words in command. */ + Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ + Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ int *bodyLines; /* Array of line numbers for body list @@ -908,7 +1079,6 @@ TclCompileSwitchCmd( int **bodyContLines; /* Array of continuation line info. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ - int isListedArms = 0; int i, valueIndex; int result = TCL_ERROR; DefineLineInformation; /* TIP #280 */ @@ -1049,130 +1219,71 @@ TclCompileSwitchCmd( */ if (numWords == 1) { - Tcl_DString bodyList; - const char **argv = NULL, *tokenStartPtr, *p; + const char *bytes; + int maxLen, numBytes; int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ - int isTokenBraced; - - /* - * Test that we've got a suitable body list as a simple (i.e. braced) - * word, and that the elements of the body are simple words too. This - * is really rather nasty indeed. - */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } + bytes = tokenPtr[1].start; + numBytes = tokenPtr[1].size; - Tcl_DStringInit(&bodyList); - Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, - &argv) != TCL_OK) { - Tcl_DStringFree(&bodyList); + /* Allocate enough space to work in. */ + maxLen = TclMaxListLength(bytes, numBytes, NULL); + if (maxLen < 2) { return TCL_ERROR; } - Tcl_DStringFree(&bodyList); - - /* - * Now we know what the switch arms are, we've got to see whether we - * can synthesize tokens for the arms. First check whether we've got a - * valid number of arms since we can do that now. - */ - - if (numWords == 0 || numWords % 2) { - ckfree((char *) argv); - return TCL_ERROR; - } - - isListedArms = 1; - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyContLines = (int **) ckalloc(sizeof(int*) * numWords); - - /* - * Locate the start of the arms within the overall word. - */ + bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen); + bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = ckalloc(sizeof(int) * maxLen); + bodyContLines = ckalloc(sizeof(int*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; - p = tokenStartPtr = tokenPtr[1].start; - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } - - /* - * TIP #280: Count lines within the literal list. - */ - - for (i=0 ; i<numWords ; i++) { - bodyTokenArray[i].type = TCL_TOKEN_TEXT; - bodyTokenArray[i].start = tokenStartPtr; - bodyTokenArray[i].size = strlen(argv[i]); - bodyTokenArray[i].numComponents = 0; - bodyToken[i] = bodyTokenArray+i; - tokenStartPtr += bodyTokenArray[i].size; + numWords = 0; - /* - * Test to see if we have guessed the end of the word correctly; - * if not, we can't feed the real string to the sub-compilation - * engine, and we're then stuck and so have to punt out to doing - * everything at runtime. - */ + while (numBytes > 0) { + const char *prevBytes = bytes; + int literal; - if ((isTokenBraced && *(tokenStartPtr++) != '}') || - (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size - && !isspace(UCHAR(*tokenStartPtr)))) { - ckfree((char *) argv); - goto freeTemporaries; + if (TCL_OK != TclFindElement(NULL, bytes, numBytes, + &(bodyTokenArray[numWords].start), &bytes, + &(bodyTokenArray[numWords].size), &literal) || !literal) { + goto abort; } + bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; + bodyTokenArray[numWords].numComponents = 0; + bodyToken[numWords] = bodyTokenArray + numWords; + /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ - TclAdvanceLines(&bline, p, bodyTokenArray[i].start); + TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); TclAdvanceContinuations(&bline, &clNext, - bodyTokenArray[i].start - envPtr->source); - bodyLines[i] = bline; - bodyContLines[i] = clNext; - p = bodyTokenArray[i].start; - - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { - break; - } - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } - } - ckfree((char *) argv); - - /* - * Check that we've parsed everything we thought we were going to - * parse. If not, something odd is going on (I believe it is possible - * to defeat the code above) and we should bail out. - */ - - if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { - goto freeTemporaries; + bodyTokenArray[numWords].start - envPtr->source); + bodyLines[numWords] = bline; + bodyContLines[numWords] = clNext; + TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); + TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source); + + numBytes -= (bytes - prevBytes); + numWords++; + } + if (numWords % 2) { + abort: + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyContLines); + return TCL_ERROR; } - } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. @@ -1188,9 +1299,9 @@ TclCompileSwitchCmd( * Multi-word definition of patterns & actions. */ - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyContLines = (int **) ckalloc(sizeof(int*) * numWords); + bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords); + bodyLines = ckalloc(sizeof(int) * numWords); + bodyContLines = ckalloc(sizeof(int*) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* @@ -1199,8 +1310,7 @@ TclCompileSwitchCmd( * traces, etc. */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - tokenPtr->numComponents != 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto freeTemporaries; } bodyToken[i] = tokenPtr+1; @@ -1233,7 +1343,7 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ - if ((isListedArms) && (mode == Switch_Exact) && (!noCase)) { + if (mode == Switch_Exact) { IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); } else { @@ -1248,11 +1358,11 @@ TclCompileSwitchCmd( */ freeTemporaries: - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); + ckfree(bodyToken); + ckfree(bodyLines); + ckfree(bodyContLines); if (bodyTokenArray != NULL) { - ckfree((char *) bodyTokenArray); + ckfree(bodyTokenArray); } return result; } @@ -1337,14 +1447,14 @@ IssueSwitchChainedTests( switch (mode) { case Switch_Exact: - TclEmitOpcode(INST_DUP, envPtr); + OP( DUP); TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); break; case Switch_Glob: TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + OP4( OVER, 1); + OP1( STR_MATCH, noCase); break; case Switch_Regexp: simple = exact = 0; @@ -1383,7 +1493,7 @@ IssueSwitchChainedTests( TclCompileTokens(interp, bodyToken[i], 1, envPtr); } - TclEmitInstInt4(INST_OVER, 1, envPtr); + OP4( OVER, 1); if (!simple) { /* * Pass correct RE compile flags. We use only Int1 @@ -1395,11 +1505,11 @@ IssueSwitchChainedTests( int cflags = TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + OP1(REGEXP, cflags); } else if (exact && !noCase) { - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); } else { - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + OP1(STR_MATCH, noCase); } break; default: @@ -1464,7 +1574,7 @@ IssueSwitchChainedTests( * pattern. */ - TclEmitOpcode(INST_POP, envPtr); + OP( POP); envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ @@ -1486,7 +1596,7 @@ IssueSwitchChainedTests( */ if (!foundDefault) { - TclEmitOpcode(INST_POP, envPtr); + OP( POP); PushLiteral(envPtr, "", 0); } @@ -1558,6 +1668,7 @@ IssueSwitchJumpTable( int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; + int savedStackDepth = envPtr->currStackDepth; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; @@ -1580,7 +1691,7 @@ IssueSwitchJumpTable( * Start by allocating the jump table itself, plus some workspace. */ - jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo)); + jtPtr = ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); @@ -1597,9 +1708,9 @@ IssueSwitchJumpTable( */ jumpLocation = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); + OP4( JUMP_TABLE, infoIndex); jumpToDefault = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP4, 0); for (i=0 ; i<numBodyTokens ; i+=2) { /* @@ -1618,8 +1729,7 @@ IssueSwitchJumpTable( */ Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, bodyToken[i]->start, - bodyToken[i]->size); + TclDStringAppendToken(&buffer, bodyToken[i]); hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, Tcl_DStringValue(&buffer), &isNew); if (isNew) { @@ -1671,6 +1781,7 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ + envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1691,7 +1802,7 @@ IssueSwitchJumpTable( * rewriting when we fixed this all up. */ - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP4, 0); } } @@ -1702,6 +1813,7 @@ IssueSwitchJumpTable( */ if (!foundDefault) { + envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); PushLiteral(envPtr, "", 0); @@ -1722,6 +1834,7 @@ IssueSwitchJumpTable( */ TclStackFree(interp, finalFixups); + envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1750,8 +1863,7 @@ DupJumptableInfo( ClientData clientData) { JumptableInfo *jtPtr = clientData; - JumptableInfo *newJtPtr = (JumptableInfo *) - ckalloc(sizeof(JumptableInfo)); + JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo)); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; int isNew; @@ -1773,7 +1885,7 @@ FreeJumptableInfo( JumptableInfo *jtPtr = clientData; Tcl_DeleteHashTable(&jtPtr->hashTable); - ckfree((char *) jtPtr); + ckfree(jtPtr); } static void @@ -1808,6 +1920,50 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * + * TclCompileTailcallCmd -- + * + * Procedure called to compile the "tailcall" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "tailcall" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileTailcallCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 256 + || envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + for (i=1 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileThrowCmd -- * * Procedure called to compile the "throw" command. @@ -1834,6 +1990,7 @@ TclCompileThrowCmd( { DefineLineInformation; /* TIP #280 */ int numWords = parsePtr->numWords; + int savedStackDepth = envPtr->currStackDepth; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; @@ -1863,6 +2020,8 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); TclCompileSyntaxError(interp, envPtr); + Tcl_DecrRefCount(objPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } if (len == 0) { @@ -1883,6 +2042,7 @@ TclCompileThrowCmd( PushLiteral(envPtr, string, len); TclDecrRefCount(dictPtr); OP44( RETURN_IMM, 1, 0); + envPtr->currStackDepth = savedStackDepth + 1; } else { /* * When the code token is not known at compilation time, we need to do @@ -1911,6 +2071,7 @@ TclCompileThrowCmd( PUSH( ""); OP44( RETURN_IMM, 1, 0); } + envPtr->currStackDepth = savedStackDepth + 1; TclDecrRefCount(objPtr); return TCL_OK; } @@ -2178,6 +2339,7 @@ IssueTryInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; + int savedStackDepth = envPtr->currStackDepth; int i, j, len, forwardsNeedFixing = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2239,6 +2401,7 @@ IssueTryInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2279,6 +2442,7 @@ IssueTryInstructions( forwardsToFix[j] = -1; } } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); } @@ -2310,6 +2474,7 @@ IssueTryInstructions( } TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2346,6 +2511,7 @@ IssueTryFinallyInstructions( range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); + envPtr->currStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); PUSH( "0"); @@ -2390,6 +2556,7 @@ IssueTryFinallyInstructions( LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); PUSH( TclGetString(matchClauses[i])); OP( STR_EQ); @@ -2462,6 +2629,7 @@ IssueTryFinallyInstructions( } OP4( BEGIN_CATCH4, range); } + envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); OP( PUSH_RETURN_OPTIONS); @@ -2513,7 +2681,6 @@ IssueTryFinallyInstructions( */ OP( POP); - envPtr->currStackDepth = savedStackDepth; /* * Process the finally clause (at last!) Note that we do not wrap this in @@ -2523,11 +2690,13 @@ IssueTryFinallyInstructions( * next command (or some inter-command manipulation). */ + envPtr->currStackDepth = savedStackDepth; BODY( finallyToken, 3 + 4*numHandlers); OP( POP); LOAD( optionsVar); LOAD( resultVar); OP( RETURN_STK); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2586,6 +2755,7 @@ TclCompileUnsetCmd( * evaluation with reasonable effort, so spill to interpreted version. */ + TclDecrRefCount(leadingWord); return TCL_ERROR; } TclDecrRefCount(leadingWord); @@ -2607,20 +2777,18 @@ TclCompileUnsetCmd( */ if (!simpleVarName) { - TclEmitInstInt1( INST_UNSET_STK, flags, envPtr); + OP1( UNSET_STK, flags); } else if (isScalar) { if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_STK, flags, envPtr); + OP1( UNSET_STK, flags); } else { - TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr); - TclEmitInt4( localIndex, envPtr); + OP14( UNSET_SCALAR, flags, localIndex); } } else { if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr); + OP1( UNSET_ARRAY_STK, flags); } else { - TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr); - TclEmitInt4( localIndex, envPtr); + OP14( UNSET_ARRAY, flags, localIndex); } } @@ -2757,7 +2925,7 @@ TclCompileWhileCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); + OP( POP); /* * Compile the test expression then emit the conditional jump that @@ -2812,6 +2980,49 @@ TclCompileWhileCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldCmd -- + * + * Procedure called to compile the "yield" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "yield" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { + return TCL_ERROR; + } + + if (parsePtr->numWords == 1) { + PushLiteral(envPtr, "", 0); + } else { + DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, valueTokenPtr, interp, 1); + } + OP( YIELD); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * PushVarName -- * * Procedure used in the compiling where pushing a variable name is @@ -3134,7 +3345,7 @@ CompileAssociativeBinaryOpCmd( * calcuations, including roundoff errors. */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + OP4( REVERSE, words-1); } while (--words > 1) { TclEmitOpcode(instruction, envPtr); @@ -3225,31 +3436,19 @@ CompileComparisonOpCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } + STORE(tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; words<parsePtr->numWords ;) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); - } + LOAD(tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } + STORE(tmpIndex); } TclEmitOpcode(instruction, envPtr); } for (; words>3 ; words--) { - TclEmitOpcode(INST_BITAND, envPtr); + OP( BITAND); } /* @@ -3257,13 +3456,7 @@ CompileComparisonOpCmd( * might be expensive elsewhere. */ - PushLiteral(envPtr, "", 0); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + OP14( UNSET_SCALAR, 0, tmpIndex); } return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 672b1cd..890d518 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompExpr.c,v 1.106 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" @@ -169,135 +167,135 @@ enum Marks { /* Leaf lexemes */ -#define NUMBER ( LEAF | 1) /* For literal numbers */ -#define SCRIPT ( LEAF | 2) /* Script substitution; [foo] */ -#define BOOLEAN ( LEAF | BAREWORD) /* For literal booleans */ -#define BRACED ( LEAF | 4) /* Braced string; {foo bar} */ -#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ -#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ -#define EMPTY ( LEAF | 7) /* Used only for an empty argument - * list to a function. Represents the - * empty string within parens in the - * expression: rand() */ +#define NUMBER (LEAF | 1) + /* For literal numbers */ +#define SCRIPT (LEAF | 2) + /* Script substitution; [foo] */ +#define BOOLEAN (LEAF | BAREWORD) + /* For literal booleans */ +#define BRACED (LEAF | 4) + /* Braced string; {foo bar} */ +#define VARIABLE (LEAF | 5) + /* Variable substitution; $x */ +#define QUOTED (LEAF | 6) + /* Quoted string; "foo $bar [soom]" */ +#define EMPTY (LEAF | 7) + /* Used only for an empty argument list to a + * function. Represents the empty string + * within parens in the expression: rand() */ /* Unary operator lexemes */ -#define UNARY_PLUS ( UNARY | PLUS) -#define UNARY_MINUS ( UNARY | MINUS) -#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative - * interpretation" on the part of the - * parser. A function call is parsed - * into the parse tree according to - * the perspective that the function - * name is a unary operator and its - * argument list, enclosed in parens, - * is its operand. The additional - * requirements not implied generally - * by treatment as a unary operator -- - * for example, the requirement that - * the operand be enclosed in parens - * -- are hard coded in the relevant - * portions of ParseExpr(). We trade - * off the need to include such - * exceptional handling in the code - * against the need we would otherwise - * have for more lexeme categories. */ -#define START ( UNARY | 4) /* This lexeme isn't parsed from the - * expression text at all. It - * represents the start of the - * expression and sits at the root of - * the parse tree where it serves as - * the start/end point of - * traversals. */ -#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative - * interpretation, where we treat "(" - * as a unary operator with the - * sub-expression between it and its - * matching ")" as its operand. See - * CLOSE_PAREN below. */ -#define NOT ( UNARY | 6) -#define BIT_NOT ( UNARY | 7) +#define UNARY_PLUS (UNARY | PLUS) +#define UNARY_MINUS (UNARY | MINUS) +#define FUNCTION (UNARY | BAREWORD) + /* This is a bit of "creative interpretation" + * on the part of the parser. A function call + * is parsed into the parse tree according to + * the perspective that the function name is a + * unary operator and its argument list, + * enclosed in parens, is its operand. The + * additional requirements not implied + * generally by treatment as a unary operator + * -- for example, the requirement that the + * operand be enclosed in parens -- are hard + * coded in the relevant portions of + * ParseExpr(). We trade off the need to + * include such exceptional handling in the + * code against the need we would otherwise + * have for more lexeme categories. */ +#define START (UNARY | 4) + /* This lexeme isn't parsed from the + * expression text at all. It represents the + * start of the expression and sits at the + * root of the parse tree where it serves as + * the start/end point of traversals. */ +#define OPEN_PAREN (UNARY | 5) + /* Another bit of creative interpretation, + * where we treat "(" as a unary operator with + * the sub-expression between it and its + * matching ")" as its operand. See + * CLOSE_PAREN below. */ +#define NOT (UNARY | 6) +#define BIT_NOT (UNARY | 7) /* Binary operator lexemes */ -#define BINARY_PLUS ( BINARY | PLUS) -#define BINARY_MINUS ( BINARY | MINUS) -#define COMMA ( BINARY | 3) /* The "," operator is a low - * precedence binary operator that - * separates the arguments in a - * function call. The additional - * constraint that this operator can - * only legally appear at the right - * places within a function call - * argument list are hard coded within - * ParseExpr(). */ -#define MULT ( BINARY | 4) -#define DIVIDE ( BINARY | 5) -#define MOD ( BINARY | 6) -#define LESS ( BINARY | 7) -#define GREATER ( BINARY | 8) -#define BIT_AND ( BINARY | 9) -#define BIT_XOR ( BINARY | 10) -#define BIT_OR ( BINARY | 11) -#define QUESTION ( BINARY | 12) /* These two lexemes make up the */ -#define COLON ( BINARY | 13) /* ternary conditional operator, - * $x ? $y : $z . We treat them as two - * binary operators to avoid another - * lexeme category, and code the - * additional constraints directly in - * ParseExpr(). For instance, the - * right operand of a "?" operator - * must be a ":" operator. */ -#define LEFT_SHIFT ( BINARY | 14) -#define RIGHT_SHIFT ( BINARY | 15) -#define LEQ ( BINARY | 16) -#define GEQ ( BINARY | 17) -#define EQUAL ( BINARY | 18) -#define NEQ ( BINARY | 19) -#define AND ( BINARY | 20) -#define OR ( BINARY | 21) -#define STREQ ( BINARY | 22) -#define STRNEQ ( BINARY | 23) -#define EXPON ( BINARY | 24) /* Unlike the other binary operators, - * EXPON is right associative and this - * distinction is coded directly in - * ParseExpr(). */ -#define IN_LIST ( BINARY | 25) -#define NOT_IN_LIST ( BINARY | 26) -#define CLOSE_PAREN ( BINARY | 27) /* By categorizing the CLOSE_PAREN - * lexeme as a BINARY operator, the - * normal parsing rules for binary - * operators assure that a close paren - * will not directly follow another - * operator, and the machinery already - * in place to connect operands to - * operators according to precedence - * performs most of the work of - * matching open and close parens for - * us. In the end though, a close - * paren is not really a binary - * operator, and some special coding - * in ParseExpr() make sure we never - * put an actual CLOSE_PAREN node in - * the parse tree. The sub-expression - * between parens becomes the single - * argument of the matching OPEN_PAREN - * unary operator. */ -#define END ( BINARY | 28) /* This lexeme represents the end of - * the string being parsed. Treating - * it as a binary operator follows the - * same logic as the CLOSE_PAREN - * lexeme and END pairs with START, in - * the same way that CLOSE_PAREN pairs - * with OPEN_PAREN. */ +#define BINARY_PLUS (BINARY | PLUS) +#define BINARY_MINUS (BINARY | MINUS) +#define COMMA (BINARY | 3) + /* The "," operator is a low precedence binary + * operator that separates the arguments in a + * function call. The additional constraint + * that this operator can only legally appear + * at the right places within a function call + * argument list are hard coded within + * ParseExpr(). */ +#define MULT (BINARY | 4) +#define DIVIDE (BINARY | 5) +#define MOD (BINARY | 6) +#define LESS (BINARY | 7) +#define GREATER (BINARY | 8) +#define BIT_AND (BINARY | 9) +#define BIT_XOR (BINARY | 10) +#define BIT_OR (BINARY | 11) +#define QUESTION (BINARY | 12) + /* These two lexemes make up the */ +#define COLON (BINARY | 13) + /* ternary conditional operator, $x ? $y : $z. + * We treat them as two binary operators to + * avoid another lexeme category, and code the + * additional constraints directly in + * ParseExpr(). For instance, the right + * operand of a "?" operator must be a ":" + * operator. */ +#define LEFT_SHIFT (BINARY | 14) +#define RIGHT_SHIFT (BINARY | 15) +#define LEQ (BINARY | 16) +#define GEQ (BINARY | 17) +#define EQUAL (BINARY | 18) +#define NEQ (BINARY | 19) +#define AND (BINARY | 20) +#define OR (BINARY | 21) +#define STREQ (BINARY | 22) +#define STRNEQ (BINARY | 23) +#define EXPON (BINARY | 24) + /* Unlike the other binary operators, EXPON is + * right associative and this distinction is + * coded directly in ParseExpr(). */ +#define IN_LIST (BINARY | 25) +#define NOT_IN_LIST (BINARY | 26) +#define CLOSE_PAREN (BINARY | 27) + /* By categorizing the CLOSE_PAREN lexeme as a + * BINARY operator, the normal parsing rules + * for binary operators assure that a close + * paren will not directly follow another + * operator, and the machinery already in + * place to connect operands to operators + * according to precedence performs most of + * the work of matching open and close parens + * for us. In the end though, a close paren is + * not really a binary operator, and some + * special coding in ParseExpr() make sure we + * never put an actual CLOSE_PAREN node in the + * parse tree. The sub-expression between + * parens becomes the single argument of the + * matching OPEN_PAREN unary operator. */ +#define END (BINARY | 28) + /* This lexeme represents the end of the + * string being parsed. Treating it as a + * binary operator follows the same logic as + * the CLOSE_PAREN lexeme and END pairs with + * START, in the same way that CLOSE_PAREN + * pairs with OPEN_PAREN. */ + /* * When ParseExpr() builds the parse tree it must choose which operands to * connect to which operators. This is done according to operator precedence. - * The greater an operator's precedence the greater claim it has to link to - * an available operand. The Precedence enumeration lists the precedence - * values used by Tcl expression operators, from lowest to highest claim. - * Each precedence level is commented with the operators that hold that - * precedence. + * The greater an operator's precedence the greater claim it has to link to an + * available operand. The Precedence enumeration lists the precedence values + * used by Tcl expression operators, from lowest to highest claim. Each + * precedence level is commented with the operators that hold that precedence. */ enum Precedence { @@ -322,9 +320,9 @@ enum Precedence { }; /* - * Here the same information contained in the comments above is stored - * in inverted form, so that given a lexeme, one can quickly look up - * its precedence value. + * Here the same information contained in the comments above is stored in + * inverted form, so that given a lexeme, one can quickly look up its + * precedence value. */ static const unsigned char prec[] = { @@ -438,7 +436,7 @@ static const unsigned char instruction[] = { * ParseLexeme(). */ -static unsigned char Lexeme[] = { +static const unsigned char Lexeme[] = { INVALID /* NUL */, INVALID /* SOH */, INVALID /* STX */, INVALID /* ETX */, INVALID /* EOT */, INVALID /* ENQ */, @@ -601,12 +599,21 @@ ParseExpr( * actual leaf at the time the complete tree * is needed. */ - /* These variables control generation of the error message. */ + /* + * These variables control generation of the error message. + */ + Tcl_Obj *msg = NULL; /* The error message. */ Tcl_Obj *post = NULL; /* In a few cases, an additional postscript * for the error message, supplying more * information after the error msg and * location have been reported. */ + const char *errCode = NULL; /* The detail word of the errorCode list, or + * NULL to indicate that no changes to the + * errorCode are to be done. */ + const char *subErrCode = NULL; + /* Extra information for use in generating the + * errorCode. */ const char *mark = "_@_"; /* In the portion of the complete error * message where the error location is * reported, this "mark" substring is inserted @@ -623,9 +630,10 @@ ParseExpr( TclParseInit(interp, start, numBytes, parsePtr); - nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode)); + nodes = attemptckalloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); + errCode = "NOMEM"; goto error; } @@ -654,11 +662,6 @@ ParseExpr( Tcl_Obj *literal; /* Filled by the ParseLexeme() call when a * literal is parsed that has a Tcl_Obj rep * worth preserving. */ - const char *lastStart = start - scanned; - /* Compute where the lexeme parsed the - * previous pass through the loop began. This - * is helpful for detecting invalid octals and - * providing more complete error messages. */ /* * Each pass through this loop adds up to one more OpNode. Allocate @@ -670,13 +673,13 @@ ParseExpr( OpNode *newPtr; do { - newPtr = (OpNode *) attemptckrealloc((char *) nodes, - (unsigned int) size * sizeof(OpNode)); + newPtr = attemptckrealloc(nodes, size * sizeof(OpNode)); } while ((newPtr == NULL) && ((size -= (size - nodesUsed) / 2) > nodesUsed)); if (newPtr == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); + errCode = "NOMEM"; goto error; } nodesAvailable = size; @@ -684,23 +687,33 @@ ParseExpr( } nodePtr = nodes + nodesUsed; - /* Skip white space between lexemes. */ + /* + * Skip white space between lexemes. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, &literal); - /* Use context to categorize the lexemes that are ambiguous. */ + /* + * Use context to categorize the lexemes that are ambiguous. + */ + if ((NODE_TYPE & lexeme) == 0) { + int b; + switch (lexeme) { case INVALID: - msg = Tcl_ObjPrintf( - "invalid character \"%.*s\"", scanned, start); + msg = Tcl_ObjPrintf("invalid character \"%.*s\"", + scanned, start); + errCode = "BADCHAR"; goto error; case INCOMPLETE: - msg = Tcl_ObjPrintf( - "incomplete operator \"%.*s\"", scanned, start); + msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", + scanned, start); + errCode = "PARTOP"; goto error; case BAREWORD: @@ -723,53 +736,57 @@ ParseExpr( */ Tcl_ListObjAppendElement(NULL, funcList, literal); + } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { + lexeme = BOOLEAN; } else { - int b; - if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) { - lexeme = BOOLEAN; - } else { - Tcl_DecrRefCount(literal); - msg = Tcl_ObjPrintf( - "invalid bareword \"%.*s%s\"", - (scanned < limit) ? scanned : limit - 3, start, - (scanned < limit) ? "" : "..."); - post = Tcl_ObjPrintf( - "should be \"$%.*s%s\" or \"{%.*s%s}\"", - (scanned < limit) ? scanned : limit - 3, - start, (scanned < limit) ? "" : "...", - (scanned < limit) ? scanned : limit - 3, - start, (scanned < limit) ? "" : "..."); - Tcl_AppendPrintfToObj(post, - " or \"%.*s%s(...)\" or ...", - (scanned < limit) ? scanned : limit - 3, - start, (scanned < limit) ? "" : "..."); - if (NotOperator(lastParsed)) { - if ((lastStart[0] == '0') - && ((lastStart[1] == 'o') - || (lastStart[1] == 'O')) - && (lastStart[2] >= '0') - && (lastStart[2] <= '9')) { - const char *end = lastStart + 2; - Tcl_Obj *copy; - - while (isdigit(UCHAR(*end))) { - end++; - } - copy = Tcl_NewStringObj(lastStart, - end - lastStart); - if (TclCheckBadOctal(NULL, - Tcl_GetString(copy))) { + Tcl_DecrRefCount(literal); + msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", + (scanned < limit) ? scanned : limit - 3, start, + (scanned < limit) ? "" : "..."); + post = Tcl_ObjPrintf( + "should be \"$%.*s%s\" or \"{%.*s%s}\"", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "...", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "..."); + Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "..."); + errCode = "BAREWORD"; + if (start[0] == '0') { + const char *stop; + TclParseNumber(NULL, NULL, NULL, start, scanned, + &stop, TCL_PARSE_NO_WHITESPACE); + + if (isdigit(UCHAR(*stop)) || (stop == start + 1)) { + switch (start[1]) { + case 'b': + Tcl_AppendToObj(post, + " (invalid binary number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "BINARY"; + break; + case 'o': + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "OCTAL"; + break; + default: + if (isdigit(UCHAR(start[1]))) { Tcl_AppendToObj(post, - "(invalid octal number?)", -1); + " (invalid octal number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "OCTAL"; } - Tcl_DecrRefCount(copy); + break; } - scanned = 0; - insertMark = 1; - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; } - goto error; } + goto error; } break; case PLUS: @@ -787,17 +804,19 @@ ParseExpr( } } /* Uncategorized lexemes */ - /* Handle lexeme based on its category. */ - switch (NODE_TYPE & lexeme) { - /* - * Each LEAF results in either a literal getting appended to the - * litList, or a sequence of Tcl_Tokens representing a Tcl word - * getting appended to the parsePtr->tokens. No OpNode is filled for - * this lexeme. + * Handle lexeme based on its category. */ + switch (NODE_TYPE & lexeme) { case LEAF: { + /* + * Each LEAF results in either a literal getting appended to the + * litList, or a sequence of Tcl_Tokens representing a Tcl word + * getting appended to the parsePtr->tokens. No OpNode is filled + * for this lexeme. + */ + Tcl_Token *tokenPtr; const char *end = start; int wordIndex; @@ -810,20 +829,14 @@ ParseExpr( if (NotOperator(lastParsed)) { msg = Tcl_ObjPrintf("missing operator at %s", mark); - if (lastStart[0] == '0') { - Tcl_Obj *copy = Tcl_NewStringObj(lastStart, - start + scanned - lastStart); - if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) { - TclNewLiteralStringObj(post, - "looks like invalid octal number"); - } - Tcl_DecrRefCount(copy); - } + errCode = "MISSING"; scanned = 0; insertMark = 1; - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - /* Free any literal to avoid a memleak. */ + /* + * Free any literal to avoid a memleak. + */ + if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { Tcl_DecrRefCount(literal); } @@ -881,7 +894,7 @@ ParseExpr( case BRACED: code = Tcl_ParseBraces(NULL, start, numBytes, - parsePtr, 1, &end); + parsePtr, 1, &end); scanned = end - start; break; @@ -896,6 +909,7 @@ ParseExpr( tokenPtr = parsePtr->tokenPtr + wordIndex + 1; if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) { TclNewLiteralStringObj(msg, "invalid character \"$\""); + errCode = "BADCHAR"; goto error; } scanned = tokenPtr->size; @@ -913,7 +927,7 @@ ParseExpr( end = start + numBytes; start++; while (1) { - code = Tcl_ParseCommand(interp, start, (end - start), 1, + code = Tcl_ParseCommand(interp, start, end - start, 1, nestedPtr); if (code != TCL_OK) { parsePtr->term = nestedPtr->term; @@ -921,10 +935,10 @@ ParseExpr( parsePtr->incomplete = nestedPtr->incomplete; break; } - start = (nestedPtr->commandStart + nestedPtr->commandSize); + start = nestedPtr->commandStart + nestedPtr->commandSize; Tcl_FreeParse(nestedPtr); - if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']') - && !(nestedPtr->incomplete)) { + if ((nestedPtr->term < end) && (nestedPtr->term[0] == ']') + && !nestedPtr->incomplete) { break; } @@ -934,6 +948,7 @@ ParseExpr( parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->incomplete = 1; code = TCL_ERROR; + errCode = "UNBALANCED"; break; } } @@ -944,7 +959,7 @@ ParseExpr( tokenPtr->size = scanned; parsePtr->numTokens++; break; - } + } /* SCRIPT case */ } if (code != TCL_OK) { /* @@ -964,6 +979,9 @@ ParseExpr( start = parsePtr->term; scanned = parsePtr->incomplete; + if (parsePtr->incomplete) { + errCode = "UNBALANCED"; + } goto error; } @@ -1013,10 +1031,14 @@ ParseExpr( msg = Tcl_ObjPrintf("missing operator at %s", mark); scanned = 0; insertMark = 1; + errCode = "MISSING"; goto error; } - /* Create an OpNode for the unary operator */ + /* + * Create an OpNode for the unary operator. + */ + nodePtr->lexeme = lexeme; nodePtr->precedence = prec[lexeme]; nodePtr->mark = MARK_RIGHT; @@ -1071,6 +1093,7 @@ ParseExpr( msg = Tcl_ObjPrintf("empty subexpression at %s", mark); scanned = 0; insertMark = 1; + errCode = "EMPTY"; goto error; } @@ -1078,30 +1101,34 @@ ParseExpr( if (nodePtr[-1].lexeme == OPEN_PAREN) { TclNewLiteralStringObj(msg, "unbalanced open paren"); parsePtr->errorType = TCL_PARSE_MISSING_PAREN; + errCode = "UNBALANCED"; } else if (nodePtr[-1].lexeme == COMMA) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; + errCode = "MISSING"; } else if (nodePtr[-1].lexeme == START) { TclNewLiteralStringObj(msg, "empty expression"); + errCode = "EMPTY"; } - } else { - if (lexeme == CLOSE_PAREN) { - TclNewLiteralStringObj(msg, "unbalanced close paren"); - } else if ((lexeme == COMMA) - && (nodePtr[-1].lexeme == OPEN_PAREN) - && (nodePtr[-2].lexeme == FUNCTION)) { - msg = Tcl_ObjPrintf( - "missing function argument at %s", mark); - scanned = 0; - insertMark = 1; - } + } else if (lexeme == CLOSE_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + errCode = "UNBALANCED"; + } else if ((lexeme == COMMA) + && (nodePtr[-1].lexeme == OPEN_PAREN) + && (nodePtr[-2].lexeme == FUNCTION)) { + msg = Tcl_ObjPrintf("missing function argument at %s", + mark); + scanned = 0; + insertMark = 1; + errCode = "UNBALANCED"; } if (msg == NULL) { msg = Tcl_ObjPrintf("missing operand at %s", mark); scanned = 0; insertMark = 1; + errCode = "MISSING"; } goto error; } @@ -1178,6 +1205,7 @@ ParseExpr( && (lexeme != CLOSE_PAREN)) { TclNewLiteralStringObj(msg, "unbalanced open paren"); parsePtr->errorType = TCL_PARSE_MISSING_PAREN; + errCode = "UNBALANCED"; goto error; } @@ -1185,10 +1213,10 @@ ParseExpr( if ((incompletePtr->lexeme == QUESTION) && (NotOperator(complete) || (nodes[complete].lexeme != COLON))) { - msg = Tcl_ObjPrintf( - "missing operator \":\" at %s", mark); + msg = Tcl_ObjPrintf("missing operator \":\" at %s", mark); scanned = 0; insertMark = 1; + errCode = "MISSING"; goto error; } @@ -1199,6 +1227,7 @@ ParseExpr( TclNewLiteralStringObj(msg, "unexpected operator \":\" " "without preceding \"?\""); + errCode = "SURPRISE"; goto error; } @@ -1261,6 +1290,7 @@ ParseExpr( if (lexeme == CLOSE_PAREN) { if (incompletePtr->lexeme != OPEN_PAREN) { TclNewLiteralStringObj(msg, "unbalanced close paren"); + errCode = "UNBALANCED"; goto error; } } @@ -1271,6 +1301,7 @@ ParseExpr( || (incompletePtr[-1].lexeme != FUNCTION)) { TclNewLiteralStringObj(msg, "unexpected \",\" outside function argument list"); + errCode = "SURPRISE"; goto error; } } @@ -1279,6 +1310,7 @@ ParseExpr( if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); + errCode = "SURPRISE"; goto error; } @@ -1335,13 +1367,12 @@ ParseExpr( numBytes -= scanned; } /* main parsing loop */ - error: - /* * We only get here if there's been an error. Any errors that didn't get a * suitable parsePtr->errorType, get recorded as syntax errors. */ + error: if (parsePtr->errorType == TCL_PARSE_SUCCESS) { parsePtr->errorType = TCL_PARSE_SYNTAX; } @@ -1351,7 +1382,7 @@ ParseExpr( */ if (nodes != NULL) { - ckfree((char*) nodes); + ckfree(nodes); } if (interp == NULL) { @@ -1363,7 +1394,6 @@ ParseExpr( Tcl_DecrRefCount(msg); } } else { - /* * Construct the complete error message. Start with the simple error * message, pulled from the interp result if necessary... @@ -1381,13 +1411,13 @@ ParseExpr( Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (start - parsePtr->string) : limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? parsePtr->end - (start + scanned) : limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); @@ -1411,6 +1441,10 @@ ParseExpr( "\n (parsing expression \"%.*s%s\")", (numBytes < limit) ? numBytes : limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); + if (errCode) { + Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, + subErrCode, NULL); + } } return TCL_ERROR; @@ -1475,7 +1509,10 @@ ConvertTreeToTokens( case OT_LITERAL: - /* Skip any white space that comes before the literal */ + /* + * Skip any white space that comes before the literal. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1558,7 +1595,10 @@ ConvertTreeToTokens( default: - /* Advance to the child node, which is an operator. */ + /* + * Advance to the child node, which is an operator. + */ + nodePtr = nodes + next; /* @@ -1639,7 +1679,10 @@ ConvertTreeToTokens( case MARK_RIGHT: next = nodePtr->right; - /* Skip any white space that comes before the operator */ + /* + * Skip any white space that comes before the operator. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1656,7 +1699,10 @@ ConvertTreeToTokens( case COMMA: case COLON: - /* No tokens for these lexemes -> nothing to do. */ + /* + * No tokens for these lexemes -> nothing to do. + */ + break; default: @@ -1691,7 +1737,10 @@ ConvertTreeToTokens( case OPEN_PAREN: - /* Skip past matching close paren. */ + /* + * Skip past matching close paren. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; @@ -1700,7 +1749,7 @@ ConvertTreeToTokens( numBytes -= scanned; break; - default: { + default: /* * Before we leave this node/operator/subexpression for the @@ -1734,7 +1783,6 @@ ConvertTreeToTokens( subExprTokenIdx = parentIdx; break; } - } /* * Since we're returning to parent, skip child handling code. @@ -1810,7 +1858,7 @@ Tcl_ParseExpr( Tcl_FreeParse(exprParsePtr); TclStackFree(interp, exprParsePtr); - ckfree((char *) opTree); + ckfree(opTree); return code; } @@ -1962,14 +2010,55 @@ ParseLexeme( literal = Tcl_NewObj(); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { - TclInitStringRep(literal, start, end-start); - *lexemePtr = NUMBER; - if (literalPtr) { - *literalPtr = literal; + if (end < start + numBytes && !isalnum(UCHAR(*end)) + && UCHAR(*end) != '_') { + + number: + TclInitStringRep(literal, start, end-start); + *lexemePtr = NUMBER; + if (literalPtr) { + *literalPtr = literal; + } else { + Tcl_DecrRefCount(literal); + } + return (end-start); } else { - Tcl_DecrRefCount(literal); + unsigned char lexeme; + + /* + * We have a number followed directly by bareword characters + * (alpha, digit, underscore). Is this a number followed by + * bareword syntax error? Or should we join into one bareword? + * Example: Inf + luence + () becomes a valid function call. + * [Bug 3401704] + */ + if (literal->typePtr == &tclDoubleType) { + const char *p = start; + + while (p < end) { + if (!isalnum(UCHAR(*p++))) { + /* + * The number has non-bareword characters, so we + * must treat it as a number. + */ + goto number; + } + } + } + ParseLexeme(end, numBytes-(end-start), &lexeme, NULL); + if ((NODE_TYPE & lexeme) == BINARY) { + /* + * The bareword characters following the number take the + * form of an operator (eq, ne, in, ni, ...) so we treat + * as number + operator. + */ + goto number; + } + + /* + * Otherwise, fall through and parse the whole as a bareword. + */ } - return (end-start); } if (Tcl_UtfCharComplete(start, numBytes)) { @@ -1981,7 +2070,7 @@ ParseLexeme( utfBytes[numBytes] = '\0'; scanned = Tcl_UtfToUniChar(utfBytes, &ch); } - if (!isalpha(UCHAR(ch))) { + if (!isalnum(UCHAR(ch))) { *lexemePtr = INVALID; Tcl_DecrRefCount(literal); return scanned; @@ -2069,7 +2158,7 @@ TclCompileExpr( TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); - ckfree((char *) opTree); + ckfree(opTree); } /* @@ -2101,7 +2190,7 @@ ExecConstantExprTree( ByteCode *byteCodePtr; int code; Tcl_Obj *byteCodeObj = Tcl_NewObj(); - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); /* * Note we are compiling an expression with literal arguments. This means @@ -2118,7 +2207,7 @@ ExecConstantExprTree( TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; + byteCodePtr = byteCodeObj->internalRep.otherValuePtr; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); @@ -2207,7 +2296,7 @@ CompileExprTree( int length; Tcl_DStringInit(&cmdName); - Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); + TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); @@ -2228,22 +2317,22 @@ CompileExprTree( break; } case QUESTION: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); envPtr->currStackDepth = jumpPtr->depth; jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { @@ -2286,12 +2375,12 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), + if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { jumpPtr->offset += 3; } - TclFixupForwardJump(envPtr, &(jumpPtr->jump), + TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2307,18 +2396,18 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &(jumpPtr->next->jump)); + &jumpPtr->next->jump); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpPtr->next->next->jump)); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); - if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { + &jumpPtr->next->next->jump); + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { jumpPtr->next->next->jump.codeOffset += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), + TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; envPtr->currStackDepth = jumpPtr->depth + 1; @@ -2338,8 +2427,8 @@ CompileExprTree( break; } if (nodePtr == rootPtr) { - /* We're done */ + return; } nodePtr = nodes + nodePtr->p.parent; @@ -2409,8 +2498,34 @@ CompileExprTree( if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - TclEmitPush(TclAddLiteralObj(envPtr, - Tcl_GetObjResult(interp), NULL), envPtr); + int index; + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + + /* + * Don't generate a string rep, but if we have one + * already, then use it to share via the literal table. + */ + + if (objPtr->bytes) { + Tcl_Obj *tableValue; + + index = TclRegisterNewLiteral(envPtr, objPtr->bytes, + objPtr->length); + tableValue = envPtr->literalArrayPtr[index].objPtr; + if ((tableValue->typePtr == NULL) && + (objPtr->typePtr != NULL)) { + /* + * Same intrep surgery as for OT_LITERAL. + */ + + tableValue->typePtr = objPtr->typePtr; + tableValue->internalRep = objPtr->internalRep; + objPtr->typePtr = NULL; + } + } else { + index = TclAddLiteralObj(envPtr, objPtr, NULL); + } + TclEmitPush(index, envPtr); } else { TclCompileSyntaxError(interp, envPtr); } @@ -2427,6 +2542,7 @@ CompileExprTree( *---------------------------------------------------------------------- * * TclSingleOpCmd -- + * * Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni * in the ::tcl::mathop namespace. These commands have no * extension to arbitrary arguments; they accept only exactly one @@ -2453,7 +2569,7 @@ TclSingleOpCmd( OpNode nodes[2]; Tcl_Obj *const *litObjv = objv + 1; - if (objc != 1+occdPtr->i.numArgs) { + if (objc != 1 + occdPtr->i.numArgs) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a34966d..309682d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompile.c,v 1.188 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" @@ -39,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex) int tclTraceCompile = 0; static int traceInitialized = 0; #endif - + /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The @@ -343,14 +341,16 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... key valueToAppend => ... newDict */ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, /* Begin iterating over the dictionary, using the local scalar - * indicated by op4 to hold the iterator state. If doneBool is true, - * dictDone *must* be called later on. + * indicated by op4 to hold the iterator state. The local scalar + * should not refer to a named variable as the value is not wholly + * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. */ + /* Terminate the iterator in op4's local scalar. Use unsetScalar + * instead (with 0 for flags). */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in @@ -372,13 +372,13 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {"upvar", 5, 0, 1, {OPERAND_LVT4}}, + {"upvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ - {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, + {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"variable", 5, 0, 1, {OPERAND_LVT4}}, + {"variable", 5, -1, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, @@ -421,6 +421,114 @@ InstructionDesc const tclInstructionTable[] = { /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ + {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, + /* Probe into a dict and extract it (or a subdict of it) into + * variables with matched names. Produces list of keys bound as + * result. Part of [dict with]. + * Stack: ... dict path => ... keyList */ + {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, + /* Map variable contents back into a dictionary in a variable. Part of + * [dict with]. + * Stack: ... dictVarName path keyList => ... */ + {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, + /* Map variable contents back into a dictionary in the local variable + * indicated by the LVT index. Part of [dict with]. + * Stack: ... path keyList => ... */ + {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top op4 words (min 1) are a key path into the dictionary just + * below the keys on the stack, and all those values are replaced by a + * boolean indicating whether it is possible to read out a value from + * that key-path (like [dict exists]). + * Stack: ... dict key1 ... keyN => ... boolean */ + {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, + /* Verifies that the word on the top of the stack is a dictionary, + * popping it if it is and throwing an error if it is not. + * Stack: ... value => ... */ + + {"strmap", 1, -2, 0, {OPERAND_NONE}}, + /* Simplified version of [string map] that only applies one change + * string, and only case-sensitively. + * Stack: ... from to string => ... changedString */ + {"strfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the first index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the last index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + /* String Range: push (string range stktop op4 op4) */ + {"strrange", 1, -2, 0, {OPERAND_NONE}}, + /* String Range with non-constant arguments. + * Stack: ... string idxA idxB => ... substring */ + + {"yield", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, and places the response back on top of the stack when it + * resumes. + * Stack: ... valueToYield => ... resumeValue */ + {"coroName", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current coroutine as an object + * on the stack. */ + {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Do a tailcall with the opnd items on the stack as the thing to + * tailcall to; opnd must be greater than 0 for the semantics to work + * right. */ + + {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current namespace as an object + * on the stack. */ + {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, + /* Push the stack depth (i.e., [info level]) of the interpreter as an + * object on the stack. */ + {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, + /* Push the argument words to a stack depth (i.e., [info level <n>]) + * of the interpreter as an object on the stack. + * Stack: ... depth => ... argList */ + {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Resolves the command named on the top of the stack to its fully + * qualified version, or produces the empty string if no such command + * exists. Never generates errors. + * Stack: ... cmdName => ... fullCmdName */ + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + /* Push the class of the TclOO object named at the top of the stack + * onto the stack. + * Stack: ... object => ... class */ + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + /* Push the namespace of the TclOO object named at the top of the + * stack onto the stack. + * Stack: ... object => ... namespace */ + {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, + /* Push whether the value named at the top of the stack is a TclOO + * object (i.e., a boolean). Can corrupt the interpreter result + * despite not throwing, so not safe for use in a post-exception + * context. + * Stack: ... value => ... boolean */ + + {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, + /* Looks up the element on the top of the stack and tests whether it + * is an array. Pushes a boolean describing whether this is the + * case. Also runs the whole-array trace on the named variable, so can + * throw anything. + * Stack: ... varName => ... boolean */ + {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, + /* Looks up the variable indexed by opnd and tests whether it is an + * array. Pushes a boolean describing whether this is the case. Also + * runs the whole-array trace on the named variable, so can throw + * anything. + * Stack: ... => ... boolean */ + {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Forces the element on the top of the stack to be the name of an + * array. + * Stack: ... varName => ... */ + {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, + /* Forces the variable indexed by opnd to be an array. Does not touch + * the stack. */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -450,6 +558,8 @@ static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + /* * TIP #280: Helper for building the per-word line information of all compiled * commands. @@ -484,6 +594,19 @@ static const Tcl_ObjType substCodeType = { NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; /* *---------------------------------------------------------------------- @@ -494,12 +617,13 @@ static const Tcl_ObjType substCodeType = { * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. This function also takes a hook * procedure that will be invoked to perform any needed post processing - * on the compilation results before generating byte codes. + * on the compilation results before generating byte codes. interp is + * compilation context and may not be NULL. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. + * result. * * Side effects: * Frees the old internal representation. If no error occurs, then the @@ -657,6 +781,9 @@ SetByteCodeFromAny( * compiled. Must not be NULL. */ Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ { + if (interp == NULL) { + return TCL_ERROR; + } TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); return TCL_OK; } @@ -714,12 +841,12 @@ FreeByteCodeInternalRep( { register ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* @@ -866,16 +993,16 @@ TclCleanupByteCode( 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); } Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree((char *) eclPtr); + ckfree(eclPtr); Tcl_DeleteHashEntry(hePtr); } } @@ -885,7 +1012,7 @@ TclCleanupByteCode( } TclHandleRelease(codePtr->interpHandle); - ckfree((char *) codePtr); + ckfree(codePtr); } /* @@ -912,7 +1039,7 @@ Tcl_SubstObj( Tcl_Obj *objPtr, /* The value to be substituted. */ int flags) /* What substitutions to do. */ { - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags), rootPtr) != TCL_OK) { @@ -986,7 +1113,7 @@ CompileSubstObj( if (objPtr->typePtr == &substCodeType) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr; + codePtr = objPtr->internalRep.ptrAndLongRep.ptr; if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) @@ -1050,12 +1177,12 @@ FreeSubstCodeInternalRep( { register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* @@ -1130,7 +1257,7 @@ TclInitCompileEnv( * non-compiling evaluator */ - envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; @@ -1287,26 +1414,26 @@ TclFreeCompileEnv( register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - ckfree((char *) envPtr->localLitTable.buckets); + ckfree(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); + ckfree(envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - ckfree((char *) envPtr->literalArrayPtr); + ckfree(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - ckfree((char *) envPtr->exceptArrayPtr); + ckfree(envPtr->exceptArrayPtr); } if (envPtr->mallocedCmdMap) { - ckfree((char *) envPtr->cmdMapPtr); + ckfree(envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - ckfree((char *) envPtr->auxDataArrayPtr); + ckfree(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { - ckfree((char *) envPtr->extCmdMapPtr); + ckfree(envPtr->extCmdMapPtr); } /* @@ -1378,7 +1505,8 @@ TclWordKnownAtCompileTime( case TCL_TOKEN_BS: if (tempPtr != NULL) { char utfBuf[TCL_UTF_MAX]; - int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); + int length = TclParseBackslash(tokenPtr->start, + tokenPtr->size, NULL, utfBuf); Tcl_AppendToObj(tempPtr, utfBuf, length); } @@ -1627,8 +1755,8 @@ TclCompileScript( * have side effects that rely on the unmodified string. */ - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); + TclDStringClear(&ds); + TclDStringAppendToken(&ds, &tokenPtr[1]); cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), @@ -1639,10 +1767,13 @@ TclCompileScript( && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; + int code, savedNumCmds = envPtr->numCommands; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int update = 0, code; + int update = 0; +#ifdef TCL_COMPILE_DEBUG + int startStackDepth = envPtr->currStackDepth; +#endif /* * Mark the start of the command; the proper bytecode @@ -1686,6 +1817,25 @@ TclCompileScript( envPtr); if (code == TCL_OK) { + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + +#ifdef TCL_COMPILE_DEBUG + int diff = envPtr->currStackDepth-startStackDepth; + + if (diff != 1 && (diff != 0 || + *(envPtr->codeNext-1) != INST_DONE)) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif if (update) { /* * Fix the bytecode length. @@ -1749,6 +1899,7 @@ TclCompileScript( * unmodified. We care only if the we are in a context * which already allows absolute counting. */ + objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); @@ -1797,7 +1948,6 @@ TclCompileScript( &isnew); Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -1820,8 +1970,8 @@ TclCompileScript( * reduced form now */ - ckfree((char *) eclPtr->loc[wlineat].line); - ckfree((char *) eclPtr->loc[wlineat].next); + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; } /* end if parsePtr->numWords > 0 */ @@ -1854,16 +2004,10 @@ TclCompileScript( /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. - * - * WARNING: push an unshared object! If the script being compiled is a - * shared empty string, it will otherwise be self-referential and cause - * difficulties with literal management [Bugs 467523, 983660]. We used to - * have special code in TclReleaseLiteral to handle this particular - * self-reference, but now opt for avoiding its creation altogether. */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } envPtr->numSrcBytes = p - script; @@ -2008,7 +2152,7 @@ TclCompileTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (int *) ckalloc(maxNumCL * sizeof(int)); + clPosition = ckalloc(maxNumCL * sizeof(int)); } Tcl_DStringInit(&textBuffer); @@ -2016,13 +2160,14 @@ TclCompileTokens( for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); + TclDStringAppendToken(&textBuffer, tokenPtr); TclAdvanceLines(&envPtr->line, tokenPtr->start, tokenPtr->start + tokenPtr->size); break; case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); + length = TclParseBackslash(tokenPtr->start, tokenPtr->size, + NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); /* @@ -2047,8 +2192,8 @@ TclCompileTokens( if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *) ckrealloc((char *) clPosition, - maxNumCL * sizeof(int)); + clPosition = ckrealloc(clPosition, + maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; numCL ++; @@ -2062,9 +2207,7 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); + int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); TclEmitPush(literal, envPtr); numObjsToConcat++; @@ -2091,9 +2234,7 @@ TclCompileTokens( if (Tcl_DStringLength(&textBuffer) > 0) { int literal; - literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); + literal = TclRegisterDStringLiteral(envPtr, &textBuffer); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); @@ -2116,13 +2257,10 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; + int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; - if (numCL) { TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, numCL, clPosition); @@ -2157,7 +2295,7 @@ TclCompileTokens( */ if (maxNumCL) { - ckfree((char *) clPosition); + ckfree(clPosition); } } @@ -2396,7 +2534,7 @@ TclInitByteCodeObj( namespacePtr = envPtr->iPtr->globalNsPtr; } - p = (unsigned char *) ckalloc((size_t) structureSize); + p = ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; @@ -2428,7 +2566,27 @@ TclInitByteCodeObj( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + if (objPtr == envPtr->literalArrayPtr[i].objPtr) { + /* + * 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]); + Tcl_DecrRefCount(objPtr); + } else { + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + } } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ @@ -2453,7 +2611,7 @@ TclInitByteCodeObj( #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes); + Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); } #endif @@ -2588,9 +2746,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameBytes + 1)); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -2651,19 +2807,17 @@ TclExpandCodeArray( */ size_t currBytes = envPtr->codeNext - envPtr->codeStart; - size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { - envPtr->codeStart = (unsigned char *) - ckrealloc((char *) envPtr->codeStart, newBytes); + envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes); } else { /* * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a * ckrealloc equivalent for ourselves. */ - unsigned char *newPtr = (unsigned char *) - ckalloc((unsigned) newBytes); + unsigned char *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->codeStart, currBytes); envPtr->codeStart = newPtr; @@ -2718,21 +2872,19 @@ EnterCmdStartData( */ size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2*currElems; + size_t newElems = 2 * currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = (CmdLocation *) - ckrealloc((char *) envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes); } else { /* * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a * ckrealloc equivalent for ourselves. */ - CmdLocation *newPtr = (CmdLocation *) - ckalloc((unsigned) newBytes); + CmdLocation *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->cmdMapPtr, currBytes); envPtr->cmdMapPtr = newPtr; @@ -2851,16 +3003,16 @@ EnterCmdWordData( size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); - eclPtr->loc = (ECL *) ckrealloc((char *) eclPtr->loc, newBytes); + eclPtr->loc = ckrealloc(eclPtr->loc, newBytes); eclPtr->nloc = newElems; } ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (int *) ckalloc(numWords * sizeof(int)); - ePtr->next = (int **) ckalloc(numWords * sizeof(int *)); + ePtr->line = ckalloc(numWords * sizeof(int)); + ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; - wwlines = (int *) ckalloc(numWords * sizeof(int)); + wwlines = ckalloc(numWords * sizeof(int)); last = cmd; wordLine = line; @@ -2923,16 +3075,15 @@ TclCreateExceptRange( size_t newBytes = newElems * sizeof(ExceptionRange); if (envPtr->mallocedExceptArray) { - envPtr->exceptArrayPtr = (ExceptionRange *) - ckrealloc((char *) envPtr->exceptArrayPtr, newBytes); + envPtr->exceptArrayPtr = + ckrealloc(envPtr->exceptArrayPtr, newBytes); } else { /* * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must * code a ckrealloc equivalent for ourselves. */ - ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); + ExceptionRange *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); envPtr->exceptArrayPtr = newPtr; @@ -3002,15 +3153,15 @@ TclCreateAuxData( size_t newBytes = newElems * sizeof(AuxData); if (envPtr->mallocedAuxDataArray) { - envPtr->auxDataArrayPtr = (AuxData *) - ckrealloc((char *) envPtr->auxDataArrayPtr, newBytes); + envPtr->auxDataArrayPtr = + ckrealloc(envPtr->auxDataArrayPtr, newBytes); } else { /* * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must * code a ckrealloc equivalent for ourselves. */ - AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); + AuxData *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); envPtr->auxDataArrayPtr = newPtr; @@ -3078,8 +3229,8 @@ TclInitJumpFixupArray( void TclExpandJumpFixupArray( register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure - * to enlarge. */ + /* Points to the JumpFixupArray structure to + * enlarge. */ { /* * The currently allocated jump fixup entries are stored from fixup[0] up @@ -3092,15 +3243,14 @@ TclExpandJumpFixupArray( size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = (JumpFixup *) - ckrealloc((char *) fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes); } else { /* * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a * ckrealloc equivalent for ourselves. */ - JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); + JumpFixup *newPtr = ckalloc(newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; @@ -3132,7 +3282,7 @@ TclFreeJumpFixupArray( * free. */ { if (fixupArrayPtr->mallocedArray) { - ckfree((char *) fixupArrayPtr->fixup); + ckfree(fixupArrayPtr->fixup); } } @@ -3313,6 +3463,70 @@ TclFixupForwardJump( rangePtr->type); } } + + /* + * TIP #280: Adjust the mapping from PC values to the per-command + * information about arguments and their line numbers. + * + * Note: We cannot simply remove an out-of-date entry and then reinsert + * with the proper PC, because then we might overwrite another entry which + * was at that location. Therefore we pull (copy + delete) all effected + * entries (beyond the fixed PC) into an array, update them there, and at + * last reinsert them all. + */ + + { + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + + /* A helper structure */ + + typedef struct { + int pc; + int cmd; + } MAP; + + /* + * And the helper array. At most the whole hashtable is placed into + * this. + */ + + MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); + + Tcl_HashSearch hSearch; + Tcl_HashEntry* hPtr; + int n, k, isnew; + + /* + * Phase I: Locate the affected entries, and save them in adjusted + * form to the array. This removes them from the hash. + */ + + for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); + map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); + + if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { + Tcl_DeleteHashEntry(hPtr); + map [n].pc += 3; + n++; + } + } + + /* + * Phase II: Re-insert the modified entries into the hash. + */ + + for (k=0;k<n;k++) { + hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew); + Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); + } + + ckfree (map); + } + return 1; /* the jump was grown */ } @@ -3467,6 +3681,7 @@ TclInitAuxDataTypeTable(void) TclRegisterAuxDataType(&tclForeachInfoType); TclRegisterAuxDataType(&tclJumptableInfoType); + TclRegisterAuxDataType(&tclDictUpdateInfoType); } /* @@ -4242,6 +4457,173 @@ FormatInstruction( /* *---------------------------------------------------------------------- * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * * PrintSourceToObj -- * * Appends a quoted representation of a string to a Tcl_Obj. @@ -4320,7 +4702,13 @@ RecordByteCodeStats( * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; - register ByteCodeStats *statsPtr = &iPtr->stats; + register ByteCodeStats *statsPtr; + + if (iPtr == NULL) { + /* Avoid segfaulting in case we're called in a deleted interp */ + return; + } + statsPtr = &(iPtr->stats); statsPtr->numCompilations++; statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; @@ -4347,5 +4735,6 @@ RecordByteCodeStats( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 * End: */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e6b0411..3302f9b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompile.h,v 1.127 2010/09/27 19:42:38 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -678,8 +676,43 @@ typedef struct ByteCode { #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 +/* For [dict with], [dict exists], [dict create] and [dict merge] */ +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE_STK 139 +#define INST_DICT_RECOMBINE_IMM 140 +#define INST_DICT_EXISTS 141 +#define INST_DICT_VERIFY 142 + +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 143 +#define INST_STR_FIND 144 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 + +/* For operations to do with coroutines and other NRE-manipulators */ +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 + +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 + /* The last opcode */ -#define LAST_INST_OPCODE 137 +#define LAST_INST_OPCODE 162 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -863,8 +896,7 @@ typedef struct { *---------------------------------------------------------------- */ -MODULE_SCOPE Tcl_NRPostProc NRCommand; -MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* *---------------------------------------------------------------- @@ -957,6 +989,8 @@ MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, + const char *name, Namespace *nsPtr); MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -975,6 +1009,14 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); +MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, + const char *script, + const char *command, int length, + const unsigned char *pc, Tcl_Obj **tosPtr); +MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, + const unsigned char *pc, Tcl_Obj **tosPtr); +MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); + /* *---------------------------------------------------------------- @@ -1352,6 +1394,16 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) /* + * Macros for making it easier to deal with tokens and DStrings. + */ + +#define TclDStringAppendToken(dsPtr, tokenPtr) \ + Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) +#define TclRegisterDStringLiteral(envPtr, dsPtr) \ + TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ + Tcl_DStringLength(dsPtr), /*flags*/ 0) + +/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 0bcd0d8..a4ba71a 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclConfig.c,v 1.25 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -80,7 +78,7 @@ Tcl_RegisterConfig( Tcl_DString cmdName; const Tcl_Config *cfg; Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); - QCCD *cdPtr = (QCCD *) ckalloc(sizeof(QCCD)); + QCCD *cdPtr = ckalloc(sizeof(QCCD)); cdPtr->interp = interp; cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); @@ -157,7 +155,7 @@ Tcl_RegisterConfig( */ Tcl_DStringInit(&cmdName); - Tcl_DStringAppend(&cmdName, "::", -1); + TclDStringAppendLiteral(&cmdName, "::"); Tcl_DStringAppend(&cmdName, pkgName, -1); /* @@ -175,7 +173,7 @@ Tcl_RegisterConfig( } } - Tcl_DStringAppend(&cmdName, "::pkgconfig", -1); + TclDStringAppendLiteral(&cmdName, "::pkgconfig"); if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { @@ -238,7 +236,9 @@ QueryConfigObjCmd( * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); + Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } @@ -249,9 +249,11 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { - Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } @@ -268,25 +270,20 @@ QueryConfigObjCmd( listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { - Tcl_SetResult(interp, "insufficient memory to create list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to create list", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } if (n) { - List *listRepPtr = (List *) - listPtr->internalRep.twoPtrValue.ptr1; Tcl_DictSearch s; - Tcl_Obj *key, **vals; - int done, i = 0; - - listRepPtr->elemCount = n; - vals = &listRepPtr->elements; + Tcl_Obj *key; + int done; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { - vals[i++] = key; - Tcl_IncrRefCount(key); + Tcl_ListObjAppendElement(NULL, listPtr, key); } } @@ -321,12 +318,13 @@ static void QueryConfigDelete( ClientData clientData) { - QCCD *cdPtr = (QCCD *) clientData; + QCCD *cdPtr = clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB = GetConfigDict(cdPtr->interp); + Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); - ckfree((char *)cdPtr); + ckfree(cdPtr); } /* diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d index 535a9ff..360bdff 100644 --- a/generic/tclDTrace.d +++ b/generic/tclDTrace.d @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclDTrace.d,v 1.4 2008/10/10 04:09:27 das Exp $ */ typedef struct Tcl_Obj Tcl_Obj; @@ -27,7 +25,7 @@ provider tcl { * arg1: number of arguments (int) * arg2: array of proc argument objects (Tcl_Obj**) */ - probe proc__entry(TclDTraceStr name, int objc, Tcl_Obj **objv); + probe proc__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution @@ -44,7 +42,7 @@ provider tcl { * arg3: proc result object (Tcl_Obj*) */ probe proc__result(TclDTraceStr name, int code, TclDTraceStr result, - Tcl_Obj *resultobj); + struct Tcl_Obj *resultobj); /* * tcl*:::proc-args probe * triggered before proc-entry probe, gives access to string @@ -81,7 +79,7 @@ provider tcl { * arg1: number of arguments (int) * arg2: array of command argument objects (Tcl_Obj**) */ - probe cmd__entry(TclDTraceStr name, int objc, Tcl_Obj **objv); + probe cmd__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution @@ -98,7 +96,7 @@ provider tcl { * arg3: command result object (Tcl_Obj*) */ probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result, - Tcl_Obj *resultobj); + struct Tcl_Obj *resultobj); /* * tcl*:::cmd-args probe * triggered before cmd-entry probe, gives access to string @@ -135,7 +133,7 @@ provider tcl { * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__start(TclDTraceStr name, int depth, Tcl_Obj **stack); + probe inst__start(TclDTraceStr name, int depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode @@ -143,7 +141,7 @@ provider tcl { * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__done(TclDTraceStr name, int depth, Tcl_Obj **stack); + probe inst__done(TclDTraceStr name, int depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* @@ -151,13 +149,13 @@ provider tcl { * triggered immediately after a new Tcl_Obj has been created * arg0: object created (Tcl_Obj*) */ - probe obj__create(Tcl_Obj* obj); + probe obj__create(struct Tcl_Obj* obj); /* * tcl*:::obj-free probe * triggered immediately before a Tcl_Obj is freed * arg0: object to be freed (Tcl_Obj*) */ - probe obj__free(Tcl_Obj* obj); + probe obj__free(struct Tcl_Obj* obj); /***************************** tcl probes ******************************/ /* diff --git a/generic/tclDate.c b/generic/tclDate.c index 13033f0..14bac51 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -129,7 +129,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * */ #include "tclInt.h" @@ -2801,10 +2800,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -2812,6 +2813,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -2819,26 +2821,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index fc9e082..2801102 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclDecls.h,v 1.187 2010/09/23 21:40:46 nijtmans Exp $ */ #ifndef _TCLDECLS @@ -46,7 +44,7 @@ EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ -EXTERN void Tcl_Panic(const char *format, ...); +EXTERN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ @@ -653,9 +651,9 @@ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ -EXTERN int Tcl_ScanElement(const char *str, int *flagPtr); +EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ -EXTERN int Tcl_ScanCountedElement(const char *str, int length, +EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); @@ -1664,10 +1662,10 @@ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 578 */ -EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...); +EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, - const char *format, ...); + const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, @@ -1804,13 +1802,17 @@ EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 628 */ -EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp, +EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); +/* 630 */ +EXTERN void Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj); -typedef struct TclStubHooks { +typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -1818,11 +1820,11 @@ typedef struct TclStubHooks { typedef struct TclStubs { int magic; - const struct TclStubHooks *hooks; + const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ - void (*tcl_Panic) (const char *format, ...); /* 2 */ + void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ @@ -1832,7 +1834,7 @@ typedef struct TclStubs { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -1841,7 +1843,7 @@ typedef struct TclStubs { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ void (*reserved10)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2006,7 +2008,7 @@ typedef struct TclStubs { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2062,8 +2064,8 @@ typedef struct TclStubs { void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ - int (*tcl_ScanElement) (const char *str, int *flagPtr); /* 218 */ - int (*tcl_ScanCountedElement) (const char *str, int length, int *flagPtr); /* 219 */ + 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 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ @@ -2422,8 +2424,8 @@ typedef struct TclStubs { void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ - Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...); /* 578 */ - void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...); /* 579 */ + Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ + void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ @@ -2472,8 +2474,9 @@ typedef struct TclStubs { int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ - void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ + 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 */ } TclStubs; #ifdef __cplusplus @@ -3766,6 +3769,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ +#define Tcl_ZlibStreamSetCompressionDictionary \ + (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3787,8 +3792,12 @@ extern const TclStubs *tclStubsPtr; # define Tcl_SetVar(interp, varName, newValue, flags) \ (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) #endif + #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) +# define Tcl_MainEx Tcl_MainExW + EXTERN void Tcl_MainExW(int argc, wchar_t **argv, + Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif #undef TCL_STORAGE_CLASS diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6a17b02..eb3625e 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclDictObj.c,v 1.84 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" @@ -78,35 +76,39 @@ static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictForLoopCallback(ClientData data[], Tcl_Interp *interp, int result); - +static int DictMapLoopCallback(ClientData data[], + Tcl_Interp *interp, int result); /* * Table of dict subcommand names and implementations. */ static const EnsembleImplMap implementationMap[] = { - {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL }, - {"create", DictCreateCmd, NULL, NULL, NULL }, - {"exists", DictExistsCmd, NULL, NULL, NULL }, - {"filter", DictFilterCmd, NULL, NULL, NULL }, - {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL }, - {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL }, - {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL }, - {"info", DictInfoCmd, NULL, NULL, NULL }, - {"keys", DictKeysCmd, NULL, NULL, NULL }, - {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL }, - {"merge", DictMergeCmd, NULL, NULL, NULL }, - {"remove", DictRemoveCmd, NULL, NULL, NULL }, - {"replace", DictReplaceCmd, NULL, NULL, NULL }, - {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL }, - {"size", DictSizeCmd, NULL, NULL, NULL }, - {"unset", DictUnsetCmd, NULL, NULL, NULL }, - {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL }, - {"values", DictValuesCmd, NULL, NULL, NULL }, - {"with", DictWithCmd, NULL, NULL, NULL }, - {NULL, NULL, NULL, NULL, NULL} + {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, + {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, + {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, + {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, + {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, + {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, + {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, + {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, + {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, + {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, + {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, + {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, + {"size", DictSizeCmd, NULL, NULL, NULL, 0 }, + {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, + {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, + {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, + {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -183,6 +185,23 @@ static const Tcl_HashKeyType chainHashType = { AllocChainEntry, TclFreeObjEntry }; + +/* + * Structure used in implementation of 'dict map' to hold the state that gets + * passed between parts of the implementation. + */ + +typedef struct { + Tcl_Obj *keyVarObj; /* The name of the variable that will have + * keys assigned to it. */ + Tcl_Obj *valueVarObj; /* The name of the variable that will have + * values assigned to it. */ + Tcl_DictSearch search; /* The dictionary search structure. */ + Tcl_Obj *scriptObj; /* The script to evaluate each time through + * the loop. */ + Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the + * results. */ +} DictMapStorage; /***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/ @@ -212,8 +231,8 @@ AllocChainEntry( Tcl_Obj *objPtr = keyPtr; ChainEntry *cPtr; - cPtr = (ChainEntry *) ckalloc(sizeof(ChainEntry)); - cPtr->entry.key.oneWordValue = (char *) objPtr; + cPtr = ckalloc(sizeof(ChainEntry)); + cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); cPtr->entry.clientData = NULL; cPtr->prevPtr = cPtr->nextPtr = NULL; @@ -343,7 +362,7 @@ DupDictInternalRep( Tcl_Obj *copyPtr) { Dict *oldDict = srcPtr->internalRep.otherValuePtr; - Dict *newDict = (Dict *) ckalloc(sizeof(Dict)); + Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; /* @@ -439,7 +458,7 @@ DeleteDict( Dict *dict) { DeleteChainTable(dict); - ckfree((char *) dict); + ckfree(dict); } /* @@ -469,20 +488,28 @@ UpdateStringOfDict( Tcl_Obj *dictPtr) { #define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; + int localFlags[LOCAL_SIZE], *flagPtr = NULL; Dict *dict = dictPtr->internalRep.otherValuePtr; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int numElems, i, length; + int i, length, bytesNeeded = 0; const char *elem; char *dst; + const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ - numElems = dict->table.numEntries * 2; + int numElems = dict->table.numEntries * 2; + + /* Handle empty list case first, simplifies what follows */ + if (numElems == 0) { + dictPtr->bytes = tclEmptyStringRep; + dictPtr->length = 0; + return; + } /* * Pass 1: estimate space, gather flags. @@ -490,55 +517,63 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; + } else if (numElems > maxFlags) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + flagPtr = ckalloc(numElems * sizeof(int)); } - dictPtr->length = 1; for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. */ + flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); - dictPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i]) + 1; + bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + flagPtr[i+1] = TCL_DONT_QUOTE_HASH; valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); - dictPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i+1]) + 1; + bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - dictPtr->bytes = ckalloc((unsigned) dictPtr->length); + dictPtr->length = bytesNeeded - 1; + dictPtr->bytes = ckalloc(bytesNeeded); dst = dictPtr->bytes; 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); elem = TclGetStringFromObj(keyPtr, &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); - *(dst++) = ' '; + dst += TclConvertElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; + flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i+1] | TCL_DONT_QUOTE_HASH); - *(dst++) = ' '; + dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); + *dst++ = ' '; } + dictPtr->bytes[dictPtr->length] = '\0'; + if (flagPtr != localFlags) { - ckfree((char *) flagPtr); - } - if (dst == dictPtr->bytes) { - *dst = 0; - } else { - *(--dst) = 0; + ckfree(flagPtr); } - dictPtr->length = dst - dictPtr->bytes; } /* @@ -566,15 +601,11 @@ SetDictFromAny( Tcl_Interp *interp, Tcl_Obj *objPtr) { - const char *string; - char *s; - const char *elemStart, *nextElem; - int lenRemain, length, elemSize, hasBrace, result, isNew; - const char *limit; /* Points just after string's last byte. */ - register const char *p; - register Tcl_Obj *keyPtr, *valuePtr; - Dict *dict; Tcl_HashEntry *hPtr; + int isNew, result; + Dict *dict = ckalloc(sizeof(Dict)); + + InitChainTable(dict); /* * Since lists and dictionaries have very closely-related string @@ -586,29 +617,15 @@ SetDictFromAny( int objc, i; Tcl_Obj **objv; - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } + /* Cannot fail, we already know the Tcl_ObjType is "list". */ + TclListObjGetElements(NULL, objPtr, &objc, &objv); if (objc & 1) { - if (interp != NULL) { - Tcl_SetResult(interp, "missing value to go with key", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } - return TCL_ERROR; + goto missingValue; } - /* - * Build the hash of key/value pairs. - */ - - dict = (Dict *) ckalloc(sizeof(Dict)); - InitChainTable(dict); for (i=0 ; i<objc ; i+=2) { - /* - * Store key and value in the hash table we're building. - */ - + + /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); @@ -626,112 +643,68 @@ SetDictFromAny( Tcl_SetHashValue(hPtr, objv[i+1]); Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } - - /* - * Share type-setting code with the string-conversion case. - */ - - goto installHash; - } - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetStringFromObj(objPtr, &length); - limit = (string + length); - - /* - * Allocate a new HashTable that has objects for keys and objects for - * values. - */ - - dict = (Dict *) ckalloc(sizeof(Dict)); - InitChainTable(dict); - for (p = string, lenRemain = length; - lenRemain > 0; - p = nextElem, lenRemain = (limit - nextElem)) { - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + } else { + int length; + const char *nextElem = TclGetStringFromObj(objPtr, &length); + const char *limit = (nextElem + length); + + while (nextElem < limit) { + Tcl_Obj *keyPtr, *valuePtr; + const char *elemStart; + int elemSize, literal; + + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + goto errorExit; } - goto errorExit; - } - if (elemStart >= limit) { - break; - } - - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ - - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy(s, elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } - - TclNewObj(keyPtr); - keyPtr->bytes = s; - keyPtr->length = elemSize; - - p = nextElem; - lenRemain = (limit - nextElem); - if (lenRemain <= 0) { - goto missingKey; - } - - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + if (elemStart == limit) { + break; + } + if (nextElem == limit) { + goto missingValue; } - TclDecrRefCount(keyPtr); - goto errorExit; - } - if (elemStart >= limit) { - goto missingKey; - } - - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy(s, elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } + if (literal) { + TclNewStringObj(keyPtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(keyPtr); + keyPtr->bytes = ckalloc((unsigned) elemSize + 1); + keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, + keyPtr->bytes); + } - TclNewObj(valuePtr); - valuePtr->bytes = s; - valuePtr->length = elemSize; + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + TclDecrRefCount(keyPtr); + goto errorExit; + } - /* - * Store key and value in the hash table we're building. - */ + if (literal) { + TclNewStringObj(valuePtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(valuePtr); + valuePtr->bytes = ckalloc((unsigned) elemSize + 1); + valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, + valuePtr->bytes); + } - hPtr = CreateChainEntry(dict, keyPtr, &isNew); - if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + /* Store key and value in the hash table we're building. */ + hPtr = CreateChainEntry(dict, keyPtr, &isNew); + if (!isNew) { + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); - TclDecrRefCount(keyPtr); - TclDecrRefCount(discardedValue); + TclDecrRefCount(keyPtr); + TclDecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, valuePtr); + Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - Tcl_SetHashValue(hPtr, valuePtr); - Tcl_IncrRefCount(valuePtr); /* Since hash now holds ref to it. */ } - installHash: /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular @@ -746,17 +719,20 @@ SetDictFromAny( objPtr->typePtr = &tclDictType; return TCL_OK; - missingKey: + missingValue: if (interp != NULL) { - Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } - TclDecrRefCount(keyPtr); result = TCL_ERROR; errorExit: + if (interp != NULL) { + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + } DeleteChainTable(dict); - ckfree((char *) dict); + ckfree(dict); return result; } @@ -825,9 +801,9 @@ TclTraceDictPath( } if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(keyv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(keyv[i]), NULL); } @@ -999,6 +975,7 @@ Tcl_DictObjGet( if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { + *valuePtrPtr = NULL; return result; } } @@ -1421,7 +1398,7 @@ Tcl_NewDictObj(void) TclNewObj(dictPtr); Tcl_InvalidateStringRep(dictPtr); - dict = (Dict *) ckalloc(sizeof(Dict)); + dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; @@ -1470,7 +1447,7 @@ Tcl_DbNewDictObj( TclDbNewObj(dictPtr, file, line); Tcl_InvalidateStringRep(dictPtr); - dict = (Dict *) ckalloc(sizeof(Dict)); + dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; @@ -1617,9 +1594,9 @@ DictGetCmd( return result; } if (valuePtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(objv[objc-1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(objv[objc-1]), NULL); return TCL_ERROR; @@ -2028,7 +2005,6 @@ DictExistsCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr; - int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); @@ -2037,18 +2013,13 @@ DictExistsCmd( dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, DICT_PATH_EXISTS); - if (dictPtr == NULL) { - return TCL_ERROR; - } - if (dictPtr == DICT_PATH_NON_EXISTENT) { + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT + || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], + &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; - } - result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr); - if (result != TCL_OK) { - return result; + } else { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); return TCL_OK; } @@ -2079,6 +2050,7 @@ DictInfoCmd( { Tcl_Obj *dictPtr; Dict *dict; + char *statsStr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2094,7 +2066,9 @@ DictInfoCmd( } dict = dictPtr->internalRep.otherValuePtr; - Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC); + statsStr = Tcl_HashStats(&dict->table); + Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); + ckfree(statsStr); return TCL_OK; } @@ -2383,7 +2357,7 @@ DictAppendCmd( * * DictForNRCmd -- * - * This function implements the "dict for" Tcl command. See the user + * These functions implement the "dict for" Tcl command. See the user * documentation for details on what it does, and TIP#111 for the formal * specification. * @@ -2423,8 +2397,8 @@ DictForNRCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2458,18 +2432,12 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2542,19 +2510,15 @@ DictForLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } @@ -2583,6 +2547,217 @@ DictForLoopCallback( /* *---------------------------------------------------------------------- * + * DictMapNRCmd -- + * + * These functions implement the "dict map" Tcl command. See the user + * documentation for details on what it does, and TIP#405 for the formal + * specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj **varv, *keyObj, *valueObj; + DictMapStorage *storagePtr; + int varc, done; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVar valueVar} dictionary script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); + return TCL_ERROR; + } + storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, + &valueObj, &done) != TCL_OK) { + TclStackFree(interp, storagePtr); + return TCL_ERROR; + } + if (done) { + /* + * Note that this exit leaves an empty value in the result (due to + * command calling conventions) but that is OK since an empty value is + * an empty dictionary. + */ + + TclStackFree(interp, storagePtr); + return TCL_OK; + } + TclNewObj(storagePtr->accumulatorObj); + TclListObjGetElements(NULL, objv[1], &varc, &varv); + storagePtr->keyVarObj = varv[0]; + storagePtr->valueVarObj = varv[1]; + storagePtr->scriptObj = objv[3]; + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. Note that the dictionary internal rep is locked + * internally so that updates, shimmering, etc are not a problem. + */ + + Tcl_IncrRefCount(storagePtr->accumulatorObj); + Tcl_IncrRefCount(storagePtr->keyVarObj); + Tcl_IncrRefCount(storagePtr->valueVarObj); + Tcl_IncrRefCount(storagePtr->scriptObj); + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything on error. + */ + + error: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return TCL_ERROR; +} + +static int +DictMapLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + DictMapStorage *storagePtr = data[0]; + Tcl_Obj *keyObj, *valueObj; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + 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 (\"dict map\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto done; + } else { + keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL, + TCL_LEAVE_ERR_MSG); + if (keyObj == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj, + Tcl_GetObjResult(interp)); + } + + /* + * Get the next mapping from the dictionary. + */ + + Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); + if (done) { + Tcl_SetObjResult(interp, storagePtr->accumulatorObj); + goto done; + } + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + done: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * * DictSetCmd -- * * This function implements the "dict set" Tcl command. See the user @@ -2851,8 +3026,8 @@ DictFilterCmd( return TCL_ERROR; } if (varc != 2) { - Tcl_SetResult(interp, "must have exactly two variable names", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; @@ -2892,16 +3067,19 @@ DictFilterCmd( if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set key variable: \"%s\"", + TclGetString(keyVarObj))); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set value variable: \"%s\"", + TclGetString(valueVarObj))); + result = TCL_ERROR; goto abnormalResult; } @@ -3168,9 +3346,7 @@ DictWithCmd( Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr; - Tcl_DictSearch s; - int done; + Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); @@ -3185,39 +3361,13 @@ DictWithCmd( if (dictPtr == NULL) { return TCL_ERROR; } - if (objc > 3) { - dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2, - DICT_PATH_READ); - if (dictPtr == NULL) { - return TCL_ERROR; - } - } - - /* - * Go over the list of keys and write each corresponding value to a - * variable in the current context with the same name. Also keep a copy of - * the keys so we can write back properly later on even if the dictionary - * has been structurally modified. - */ - if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, - &done) != TCL_OK) { + keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2); + if (keysPtr == NULL) { return TCL_ERROR; } - - TclNewObj(keysPtr); Tcl_IncrRefCount(keysPtr); - for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { - Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); - if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(keysPtr); - Tcl_DictObjDone(&s); - return TCL_ERROR; - } - } - /* * Execute the body, while making the invoking context available to the * loop body (TIP#280) and postponing the cleanup until later (NRE). @@ -3241,55 +3391,200 @@ FinalizeDictWith( Tcl_Interp *interp, int result) { - Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr; - int keyc, i, allocdict = 0; + Tcl_Obj **pathv; + int pathc; Tcl_InterpState state; Tcl_Obj *varName = data[0]; Tcl_Obj *keysPtr = data[1]; Tcl_Obj *pathPtr = data[2]; + Var *varPtr, *arrayPtr; if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); } /* + * Save the result state; TDWF doesn't guarantee to not modify that on + * TCL_OK result. + */ + + state = Tcl_SaveInterpState(interp, result); + if (pathPtr != NULL) { + Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); + } else { + pathc = 0; + pathv = NULL; + } + + /* + * Pack from local variables back into the dictionary. + */ + + varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + result = TCL_ERROR; + } else { + result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1, + pathc, pathv, keysPtr); + } + + /* + * Tidy up and return the real result (unless we had an error). + */ + + TclDecrRefCount(varName); + TclDecrRefCount(keysPtr); + if (pathPtr != NULL) { + TclDecrRefCount(pathPtr); + } + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + return TCL_ERROR; + } + return Tcl_RestoreInterpState(interp, state); +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithInit -- + * + * Part of the core of [dict with]. Pokes into a dictionary and converts + * the mappings there into assignments to (presumably) local variables. + * Returns a list of all the names that were mapped so that removal of + * either the variable or the dictionary entry won't surprise us when we + * come to stuffing everything back. + * + * Result: + * List of mapped names, or NULL if there was an error. + * + * Side effects: + * Assigns to variables, so potentially legion due to traces. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDictWithInit( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int pathc, + Tcl_Obj *const pathv[]) +{ + Tcl_DictSearch s; + Tcl_Obj *keyPtr, *valPtr, *keysPtr; + int done; + + if (pathc > 0) { + dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, + DICT_PATH_READ); + if (dictPtr == NULL) { + return NULL; + } + } + + /* + * Go over the list of keys and write each corresponding value to a + * variable in the current context with the same name. Also keep a copy of + * the keys so we can write back properly later on even if the dictionary + * has been structurally modified. + */ + + if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, + &done) != TCL_OK) { + return NULL; + } + + TclNewObj(keysPtr); + + for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { + Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); + if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(keysPtr); + Tcl_DictObjDone(&s); + return NULL; + } + } + + return keysPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictWithFinish -- + * + * Part of the core of [dict with]. Reassembles the piece of the dict (in + * varName, location given by pathc/pathv) from the variables named in + * the keysPtr argument. NB, does not try to preserve errors or manage + * argument lifetimes. + * + * Result: + * TCL_OK if we succeeded, or TCL_ERROR if we failed. + * + * Side effects: + * Assigns to a variable, so potentially legion due to traces. Updates + * the dictionary in the named variable. + * + *---------------------------------------------------------------------- + */ + +int +TclDictWithFinish( + Tcl_Interp *interp, /* Command interpreter in which variable + * exists. Used for state management, traces + * and error reporting. */ + Var *varPtr, /* Reference to the variable holding the + * dictionary. */ + Var *arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. NULL if the 'index' + * parameter is >= 0 */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + int index, /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ + int pathc, /* The number of elements in the path into the + * dictionary. */ + Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */ + Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is + * the result value from TclDictWithInit. */ +{ + Tcl_Obj *dictPtr, *leafPtr, *valPtr; + int i, allocdict, keyc; + Tcl_Obj **keyv; + + /* * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, index); if (dictPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - return result; + return TCL_OK; } /* * Double-check that it is still a dictionary. */ - state = Tcl_SaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr) { - TclDecrRefCount(pathPtr); - } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocdict = 1; + } else { + allocdict = 0; } - if (pathPtr != NULL) { - Tcl_Obj **pathv; - int pathc; - + if (pathc > 0) { /* * Want to get to the dictionary which we will update; need to do * prepare-for-update de-sharing along the path *but* avoid generating @@ -3299,26 +3594,19 @@ FinalizeDictWith( * perfectly efficient (but no memory should be leaked). */ - Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, DICT_PATH_EXISTS | DICT_PATH_UPDATE); - TclDecrRefCount(pathPtr); if (leafPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - Tcl_DiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } } else { leafPtr = dictPtr; @@ -3344,14 +3632,13 @@ FinalizeDictWith( Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr); } } - TclDecrRefCount(keysPtr); /* * Ensure that none of the dictionaries in the chain still have a string * rep. */ - if (pathPtr != NULL) { + if (pathc > 0) { InvalidateDictChain(leafPtr); } @@ -3359,13 +3646,14 @@ FinalizeDictWith( * Write back the outermost dictionary to the variable. */ - if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DiscardInterpState(state); + if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr, + TCL_LEAVE_ERR_MSG, index) == NULL) { + if (allocdict) { + TclDecrRefCount(dictPtr); + } return TCL_ERROR; } - TclDecrRefCount(varName); - return Tcl_RestoreInterpState(interp, state); + return TCL_OK; } /* @@ -3392,7 +3680,7 @@ TclInitDictCmd( { return TclMakeEnsemble(interp, "dict", implementationMap); } - + /* * Local Variables: * mode: c diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 11e0c9c..7a55724 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclEncoding.c,v 1.72 2010/09/16 14:49:37 nijtmans Exp $ */ #include "tclInt.h" @@ -594,14 +592,14 @@ TclInitEncodingSubsystem(void) * code to duplicate the structure of a table encoding here. */ - dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); + dataPtr = ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = '?'; size = 256*(sizeof(unsigned short *) + sizeof(unsigned short)); - dataPtr->toUnicode = (unsigned short **) ckalloc(size); + dataPtr->toUnicode = ckalloc(size); memset(dataPtr->toUnicode, 0, size); - dataPtr->fromUnicode = (unsigned short **) ckalloc(size); + dataPtr->fromUnicode = ckalloc(size); memset(dataPtr->fromUnicode, 0, size); dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256); @@ -851,8 +849,8 @@ FreeEncoding( if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - ckfree((char *) encodingPtr->name); - ckfree((char *) encodingPtr); + ckfree(encodingPtr->name); + ckfree(encodingPtr); } } @@ -981,13 +979,13 @@ Tcl_GetEncodingNames( int Tcl_SetSystemEncoding( Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */ - const char *name) /* The name of the desired encoding, or NULL + const char *name) /* The name of the desired encoding, or NULL/"" * to reset to default encoding. */ { Tcl_Encoding encoding; Encoding *encodingPtr; - if (name == NULL) { + if (!name || !*name) { Tcl_MutexLock(&encodingMutex); encoding = defaultEncoding; encodingPtr = (Encoding *) encoding; @@ -1056,9 +1054,9 @@ Tcl_CreateEncoding( encodingPtr->hPtr = NULL; } - name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); + name = ckalloc(strlen(typePtr->encodingName) + 1); - encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); + encodingPtr = ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; @@ -1544,7 +1542,8 @@ OpenEncodingFileChannel( } if ((NULL == chan) && (interp != NULL)) { - Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown encoding \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_DecrRefCount(fileNameObj); @@ -1618,7 +1617,8 @@ LoadEncodingFile( break; } if ((encoding == NULL) && (interp != NULL)) { - Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid encoding file \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_Close(NULL, chan); @@ -1709,7 +1709,7 @@ LoadTableEncoding( #undef PAGESIZE #define PAGESIZE (256 * sizeof(unsigned short)) - dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); + dataPtr = ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; @@ -1721,7 +1721,7 @@ LoadTableEncoding( */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->toUnicode = (unsigned short **) ckalloc(size); + dataPtr->toUnicode = ckalloc(size); memset(dataPtr->toUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); @@ -1779,7 +1779,7 @@ LoadTableEncoding( } } size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->fromUnicode = (unsigned short **) ckalloc(size); + dataPtr->fromUnicode = ckalloc(size); memset(dataPtr->fromUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); @@ -1874,9 +1874,9 @@ LoadTableEncoding( * Read lines from the encoding until EOF. */ - for (Tcl_DStringSetLength(&lineString, 0); + for (TclDStringClear(&lineString); (len = Tcl_Gets(chan, &lineString)) >= 0; - Tcl_DStringSetLength(&lineString, 0)) { + TclDStringClear(&lineString)) { const unsigned char *p; int to, from; @@ -2011,17 +2011,17 @@ LoadEscapeEncoding( Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } - ckfree((char *) argv); + ckfree(argv); Tcl_DStringFree(&lineString); } size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); - dataPtr = (EscapeEncodingData *) ckalloc(size); + dataPtr = ckalloc(size); dataPtr->initLen = strlen(init); - strcpy(dataPtr->init, init); + memcpy(dataPtr->init, init, (unsigned) dataPtr->initLen + 1); dataPtr->finalLen = strlen(final); - strcpy(dataPtr->final, final); + memcpy(dataPtr->final, final, (unsigned) dataPtr->finalLen + 1); dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData), @@ -2957,9 +2957,9 @@ TableFreeProc( * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ - ckfree((char *) dataPtr->toUnicode); - ckfree((char *) dataPtr->fromUnicode); - ckfree((char *) dataPtr); + ckfree(dataPtr->toUnicode); + ckfree(dataPtr->fromUnicode); + ckfree(dataPtr); } /* @@ -3434,7 +3434,7 @@ EscapeFreeProc( subTablePtr++; } } - ckfree((char *) dataPtr); + ckfree(dataPtr); } /* @@ -3572,7 +3572,7 @@ InitializeEncodingSearchPath( bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); *lengthPtr = numBytes; - *valuePtr = ckalloc((unsigned) numBytes + 1); + *valuePtr = ckalloc(numBytes + 1); memcpy(*valuePtr, bytes, (size_t) numBytes + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c4750c5..b76c603 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclEnsemble.c,v 1.5 2010/03/05 14:34:04 dkf Exp $ */ #include "tclInt.h" @@ -19,6 +17,7 @@ * Declarations for functions local to this file: */ +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); @@ -80,6 +79,19 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; +static inline Tcl_Obj * +NewNsObj( + Tcl_Namespace *namespacePtr) +{ + register Namespace *nsPtr = (Namespace *) namespacePtr; + + if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { + return Tcl_NewStringObj("::", 2); + } else { + return Tcl_NewStringObj(nsPtr->fullName, -1); + } +} + /* *---------------------------------------------------------------------- * @@ -118,18 +130,19 @@ TclNamespaceEnsembleCmd( if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[2], ensembleSubcommands, + if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -151,12 +164,12 @@ TclNamespaceEnsembleCmd( * Check that we've got option-value pairs... [Bug 1558654] */ - if ((objc & 1) == 0) { - Tcl_WrongNumArgs(interp, 3, objv, "?option value ...?"); + if (objc & 1) { + Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); return TCL_ERROR; } - objv += 3; - objc -= 3; + objv += 2; + objc -= 2; /* * Work out what name to use for the command to create. If supplied, @@ -237,9 +250,11 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -252,7 +267,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -324,29 +339,29 @@ TclNamespaceEnsembleCmd( } case ENS_EXISTS: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdname"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); + Tcl_FindEnsemble(interp, objv[2], 0) != NULL)); return TCL_OK; case ENS_CONFIG: - if (objc < 4 || (objc != 5 && objc & 1)) { - Tcl_WrongNumArgs(interp, 3, objv, + if (objc < 3 || (objc != 4 && !(objc & 1))) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdname ?-option value ...? ?arg ...?"); return TCL_ERROR; } - token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); + token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG); if (token == NULL) { return TCL_ERROR; } - if (objc == 5) { + if (objc == 4) { Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ - if (Tcl_GetIndexFromObj(interp, objv[4], ensembleConfigOptions, + if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -372,8 +387,7 @@ TclNamespaceEnsembleCmd( case CONF_NAMESPACE: namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName, - TCL_VOLATILE); + Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); break; case CONF_PREFIX: { int flags = 0; /* silence gcc 4 warning */ @@ -390,7 +404,7 @@ TclNamespaceEnsembleCmd( } break; } - } else if (objc == 4) { + } else if (objc == 3) { /* * Produce list of all information. */ @@ -413,9 +427,7 @@ TclNamespaceEnsembleCmd( -1)); namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName, - -1)); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); /* -parameters option */ Tcl_ListObjAppendElement(NULL, resultObj, @@ -459,8 +471,8 @@ TclNamespaceEnsembleCmd( Tcl_GetEnsembleFlags(NULL, token, &flags); permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; - objv += 4; - objc -= 4; + objv += 3; + objc -= 3; /* * Parse the option list, applying type checks as we go. Note that @@ -517,9 +529,11 @@ TclNamespaceEnsembleCmd( goto freeMapAndError; } if (len < 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); + "must be non-empty lists", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -529,8 +543,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_DuplicateObj(listObj); - Tcl_Obj *newCmd = - Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); @@ -556,7 +569,9 @@ TclNamespaceEnsembleCmd( continue; } case CONF_NAMESPACE: - Tcl_AppendResult(interp, "option -namespace is read-only", + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", NULL); goto freeMapAndError; case CONF_PREFIX: @@ -618,8 +633,7 @@ Tcl_CreateEnsemble( int flags) { Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = (EnsembleConfig *) - ckalloc(sizeof(EnsembleConfig)); + EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); Tcl_Obj *nameObj = NULL; if (nsPtr == NULL) { @@ -632,7 +646,7 @@ Tcl_CreateEnsemble( */ if (!(name[0] == ':' && name[1] == ':')) { - nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + nameObj = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr == NULL) { Tcl_AppendStringsToObj(nameObj, name, NULL); } else { @@ -705,7 +719,9 @@ Tcl_SetEnsembleSubcommandList( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (subcmdList != NULL) { @@ -779,7 +795,9 @@ Tcl_SetEnsembleParameterList( int length; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (paramList == NULL) { @@ -853,7 +871,9 @@ Tcl_SetEnsembleMappingDict( Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (mapDict != NULL) { @@ -876,9 +896,11 @@ Tcl_SetEnsembleMappingDict( } bytes = TclGetString(cmdObjPtr); if (bytes[0] != ':' || bytes[1] != ':') { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "UNQUALIFIED_TARGET", NULL); Tcl_DictObjDone(&search); return TCL_ERROR; } @@ -948,7 +970,9 @@ Tcl_SetEnsembleUnknownHandler( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } if (unknownList != NULL) { @@ -1012,7 +1036,9 @@ Tcl_SetEnsembleFlags( int wasCompiled; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1087,7 +1113,9 @@ Tcl_GetEnsembleSubcommandList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1127,7 +1155,9 @@ Tcl_GetEnsembleParameterList( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1167,7 +1197,9 @@ Tcl_GetEnsembleMappingDict( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1206,7 +1238,9 @@ Tcl_GetEnsembleUnknownHandler( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1245,7 +1279,9 @@ Tcl_GetEnsembleFlags( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1284,7 +1320,9 @@ Tcl_GetEnsembleNamespace( if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } return TCL_ERROR; } @@ -1340,8 +1378,9 @@ Tcl_FindEnsemble( if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), - "\" is not an ensemble command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not an ensemble command", + TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", TclGetString(cmdNameObj), NULL); } @@ -1417,16 +1456,21 @@ TclMakeEnsemble( { Tcl_Command ensemble; Tcl_Namespace *ns; - Tcl_DString buf; + Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0; + int i, nameCount = 0, ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. */ Tcl_DStringInit(&buf); + Tcl_DStringInit(&hiddenBuf); + TclDStringAppendLiteral(&hiddenBuf, "tcl:"); + Tcl_DStringAppend(&hiddenBuf, name, -1); + TclDStringAppendLiteral(&hiddenBuf, ":"); + hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { /* * An absolute name, so use it directly. @@ -1441,14 +1485,14 @@ TclMakeEnsemble( * multi-word list differently to a single word. */ - Tcl_DStringAppend(&buf, "::tcl", -1); + TclDStringAppendLiteral(&buf, "::tcl"); if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) { Tcl_Panic("invalid ensemble name '%s'", name); } for (i = 0; i < nameCount; ++i) { - Tcl_DStringAppend(&buf, "::", 2); + TclDStringAppendLiteral(&buf, "::"); Tcl_DStringAppend(&buf, nameParts[i], -1); } } @@ -1483,7 +1527,7 @@ TclMakeEnsemble( Tcl_Obj *mapDict, *fromObj, *toObj; Command *cmdPtr; - Tcl_DStringAppend(&buf, "::", 2); + TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { fromObj = Tcl_NewStringObj(map[i].name, -1); @@ -1491,10 +1535,35 @@ TclMakeEnsemble( Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, -1); Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + if (map[i].proc || map[i].nreProc) { - cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, TclGetString(toObj), - map[i].proc, map[i].nreProc, map[i].clientData, NULL); + /* + * If the command is unsafe, hide it when we're in a safe + * interpreter. The code to do this is really hokey! It also + * doesn't work properly yet; this function is always + * currently called before the safe-interp flag is set so the + * Tcl_IsSafe check fails. + */ + + if (map[i].unsafe && Tcl_IsSafe(interp)) { + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, + map[i].nreProc, map[i].clientData, NULL); + Tcl_DStringSetLength(&hiddenBuf, hiddenLen); + if (Tcl_HideCommand(interp, "___tmp", + Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } + } else { + /* + * Not hidden, so just create it. Yay! + */ + + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, TclGetString(toObj), + map[i].proc, map[i].nreProc, map[i].clientData, + NULL); + } cmdPtr->compileProc = map[i].compileProc; if (map[i].compileProc != NULL) { ensembleFlags |= ENSEMBLE_COMPILE; @@ -1508,6 +1577,7 @@ TclMakeEnsemble( } Tcl_DStringFree(&buf); + Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { Tcl_Free((char *) nameParts); } @@ -1563,6 +1633,7 @@ NsEnsembleImplementationCmdNR( * specified but not yet cached command * names. */ int reparseCount = 0; /* Number of reparses. */ + Tcl_Obj *errorObj; /* Used for building error messages. */ /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1587,10 +1658,10 @@ NsEnsembleImplementationCmdNR( Tcl_Panic("List of ensemble parameters is not a list"); } for (; len>0; len--,elemPtrs++) { - Tcl_DStringAppend(&buf, Tcl_GetString(*elemPtrs), -1); - Tcl_DStringAppend(&buf, " ", -1); + TclDStringAppendObj(&buf, *elemPtrs); + TclDStringAppendLiteral(&buf, " "); } - Tcl_DStringAppend(&buf, "subcommand ?arg ...?", -1); + TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); @@ -1603,8 +1674,9 @@ NsEnsembleImplementationCmdNR( */ if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, - "ensemble activated for deleted namespace", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble activated for deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); } return TCL_ERROR; } @@ -1795,11 +1867,6 @@ NsEnsembleImplementationCmdNR( * count both as inserted and removed arguments. */ -#if 0 - if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } -#else if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = @@ -1820,14 +1887,13 @@ NsEnsembleImplementationCmdNR( iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; } } -#endif /* * Hand off to the target command. */ iPtr->evalFlags |= TCL_EVAL_REDIRECT; - return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE); + return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); } unknownOrAmbiguousSubcommand: @@ -1858,35 +1924,34 @@ NsEnsembleImplementationCmdNR( */ Tcl_ResetResult(interp); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown subcommand \"%s\": namespace %s does not" + " export any commands", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": namespace ", ensemblePtr->nsPtr->fullName, - " does not export any commands", NULL); + ensemblePtr->nsPtr->fullName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown ", - (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]), - "\": must be ", NULL); + errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), + TclGetString(objv[1+ensemblePtr->numParameters])); if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { int i; for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { - Tcl_AppendResult(interp, - ensemblePtr->subcommandArrayPtr[i], ", ", NULL); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ", ", 2); } - Tcl_AppendResult(interp, "or ", - ensemblePtr->subcommandArrayPtr[i], NULL); + Tcl_AppendPrintfToObj(errorObj, "or %s", + ensemblePtr->subcommandArrayPtr[i]); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); + Tcl_SetObjResult(interp, errorObj); return TCL_ERROR; } @@ -2012,7 +2077,6 @@ EnsembleUnknownCallback( { int paramc, i, result, prefixObjc; Tcl_Obj **paramv, *unknownCmd, *ensObj; - char buf[TCL_INTEGER_SPACE]; /* * Create the unknown command callback to determine what to do. @@ -2039,9 +2103,12 @@ EnsembleUnknownCallback( ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT; result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { - Tcl_SetResult(interp, - "unknown subcommand handler deleted its ensemble", - TCL_STATIC); + if (!Tcl_InterpDeleted(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler deleted its ensemble", -1)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", + NULL); + } result = TCL_ERROR; } Tcl_Release(ensemblePtr); @@ -2090,26 +2157,26 @@ EnsembleUnknownCallback( if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); - Tcl_SetResult(interp, - "unknown subcommand handler returned bad code: ", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown subcommand handler returned bad code: ", -1)); switch (result) { case TCL_RETURN: - Tcl_AppendResult(interp, "return", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); break; case TCL_BREAK: - Tcl_AppendResult(interp, "break", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); break; case TCL_CONTINUE: - Tcl_AppendResult(interp, "continue", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); break; default: - sprintf(buf, "%d", result); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", + NULL); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); @@ -2160,7 +2227,7 @@ MakeCachedEnsembleCommand( */ TclFreeIntRep(objPtr); - ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); + ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = ensembleCmd; objPtr->typePtr = &tclEnsembleCmdType; } @@ -2175,7 +2242,7 @@ MakeCachedEnsembleCommand( ensemblePtr->nsPtr->refCount++; ensembleCmd->realPrefixObj = prefixObjPtr; length = strlen(subcommandName)+1; - ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); + ensembleCmd->fullSubcmdName = ckalloc(length); memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); Tcl_IncrRefCount(ensembleCmd->realPrefixObj); } @@ -2242,7 +2309,7 @@ DeleteEnsembleConfig( */ if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree((char *) ensemblePtr->subcommandArrayPtr); + ckfree(ensemblePtr->subcommandArrayPtr); } hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); while (hEnt != NULL) { @@ -2313,7 +2380,7 @@ BuildEnsembleConfig( * Remove pre-existing table. */ - ckfree((char *) ensemblePtr->subcommandArrayPtr); + ckfree(ensemblePtr->subcommandArrayPtr); hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); @@ -2370,7 +2437,7 @@ BuildEnsembleConfig( * the programmer's responsibility (or [::unknown] of course). */ - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { @@ -2468,7 +2535,7 @@ BuildEnsembleConfig( * the hash too, and vice versa) and running quicksort over the array. */ - ensemblePtr->subcommandArrayPtr = (char **) + ensemblePtr->subcommandArrayPtr = ckalloc(sizeof(char *) * hash->numEntries); /* @@ -2561,7 +2628,7 @@ FreeEnsembleCmdRep( Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ckfree(ensembleCmd->fullSubcmdName); TclNsDecrRefCount(ensembleCmd->nsPtr); - ckfree((char *) ensembleCmd); + ckfree(ensembleCmd); objPtr->typePtr = NULL; } @@ -2589,8 +2656,7 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) - ckalloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &tclEnsembleCmdType; @@ -2601,7 +2667,7 @@ DupEnsembleCmdRep( ensembleCopy->nsPtr->refCount++; ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(ensembleCopy->realPrefixObj); - ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); + ensembleCopy->fullSubcmdName = ckalloc(length + 1); memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, (unsigned) length+1); } @@ -2631,7 +2697,7 @@ StringOfEnsembleCmdRep( int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; - objPtr->bytes = ckalloc((unsigned) length+1); + objPtr->bytes = ckalloc(length + 1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } @@ -2862,7 +2928,10 @@ TclCompileEnsemble( Tcl_IncrRefCount(targetCmdObj); cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); - if (cmdPtr == NULL || cmdPtr->compileProc == NULL) { + if (cmdPtr == NULL || cmdPtr->compileProc == NULL + || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION + || cmdPtr->flags * CMD_HAS_EXEC_TRACES + || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { /* * Maps to an undefined command or a command without a compiler. * Cannot compile. diff --git a/generic/tclEnv.c b/generic/tclEnv.c index a64d38d..b5ae6ea 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclEnv.c,v 1.43 2010/04/28 11:50:54 nijtmans Exp $ */ #include "tclInt.h" @@ -47,11 +45,8 @@ MODULE_SCOPE void TclSetEnv(const char *name, const char *value); MODULE_SCOPE void TclUnsetEnv(const char *name); #if defined(__CYGWIN__) -/* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value); - DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value); -# define putenv TclCygwinPutenv -static void TclCygwinPutenv(char *string); + static void TclCygwinPutenv(char *string); +# define putenv TclCygwinPutenv #endif /* @@ -163,7 +158,8 @@ TclSetEnv( const char *value) /* New value for variable (UTF-8). */ { Tcl_DString envString; - int index, length, nameLength; + unsigned nameLength, valueLength; + int index, length; char *p, *oldValue; const char *p2; @@ -185,12 +181,11 @@ TclSetEnv( */ if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) { - char **newEnviron = (char **) - ckalloc(((unsigned) length + 5) * sizeof(char *)); + char **newEnviron = ckalloc((length + 5) * sizeof(char *)); memcpy(newEnviron, environ, length * sizeof(char *)); if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) { - ckfree((char *) env.ourEnviron); + ckfree(env.ourEnviron); } environ = env.ourEnviron = newEnviron; env.ourEnvironSize = length + 5; @@ -220,7 +215,7 @@ TclSetEnv( Tcl_DStringFree(&envString); oldValue = environ[index]; - nameLength = length; + nameLength = (unsigned) length; } /* @@ -229,18 +224,19 @@ TclSetEnv( * and set the environ array value. */ - p = ckalloc((unsigned) nameLength + strlen(value) + 2); - strcpy(p, name); + valueLength = strlen(value); + p = ckalloc(nameLength + valueLength + 2); + memcpy(p, name, nameLength); p[nameLength] = '='; - strcpy(p+nameLength+1, value); + memcpy(p+nameLength+1, value, valueLength+1); p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); /* * Copy the native string to heap memory. */ - p = ckrealloc(p, strlen(p2) + 1); - strcpy(p, p2); + p = ckrealloc(p, Tcl_DStringLength(&envString) + 1); + memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1); Tcl_DStringFree(&envString); #ifdef USE_PUTENV @@ -400,19 +396,20 @@ TclUnsetEnv( */ #if defined(__WIN32__) || defined(__CYGWIN__) - string = ckalloc((unsigned) length+2); + string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; string[length+1] = '\0'; #else - string = ckalloc((unsigned) length+1); + string = ckalloc(length + 1); memcpy(string, name, (size_t) length); string[length] = '\0'; #endif /* WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); - string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1); - strcpy(string, Tcl_DStringValue(&envString)); + string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); + memcpy(string, Tcl_DStringValue(&envString), + (unsigned) Tcl_DStringLength(&envString)+1); Tcl_DStringFree(&envString); putenv(string); @@ -645,11 +642,11 @@ ReplaceString( const int growth = 5; - env.cache = (char **) ckrealloc((char *) env.cache, + env.cache = ckrealloc(env.cache, (env.cacheSize + growth) * sizeof(char *)); env.cache[env.cacheSize] = newStr; - (void) memset(env.cache+env.cacheSize+1, (int) 0, - (size_t) (growth-1) * sizeof(char*)); + (void) memset(env.cache+env.cacheSize+1, 0, + (size_t) (growth-1) * sizeof(char *)); env.cacheSize += growth; } } @@ -684,7 +681,7 @@ TclFinalizeEnvironment(void) */ if (env.cache) { - ckfree((char *) env.cache); + ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV @@ -701,6 +698,7 @@ TclFinalizeEnvironment(void) * fork) and the Windows environment (in case the application TCL code calls * exec, which calls the Windows CreateProcess function). */ +DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *); static void TclCygwinPutenv( @@ -754,15 +752,11 @@ TclCygwinPutenv( */ if (strcmp(name, "Path") == 0) { -#ifdef __WIN32__ SetEnvironmentVariableA("PATH", NULL); -#endif unsetenv("PATH"); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, value); -#endif } else { char *buf; @@ -770,9 +764,7 @@ TclCygwinPutenv( * Eliminate any Path variable, to prevent any confusion. */ -#ifdef __WIN32__ SetEnvironmentVariableA("Path", NULL); -#endif unsetenv("Path"); if (value == NULL) { @@ -780,14 +772,12 @@ TclCygwinPutenv( } else { int size; - size = cygwin_posix_to_win32_path_list_buf_size(value); + size = cygwin_conv_path_list(0, value, NULL, 0); buf = alloca(size + 1); - cygwin_posix_to_win32_path_list(value, buf); + cygwin_conv_path_list(0, value, buf, size); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, buf); -#endif } } #endif /* __CYGWIN__ */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4de8f0b..ae79cad 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclEvent.c,v 1.94 2010/09/23 18:08:35 dgp Exp $ */ #include "tclInt.h" @@ -121,7 +119,6 @@ static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void InvokeExitHandlers(void); - /* *---------------------------------------------------------------------- @@ -162,7 +159,7 @@ Tcl_BackgroundException( return; } - errPtr = (BgError *) ckalloc(sizeof(BgError)); + errPtr = ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); @@ -229,7 +226,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; @@ -244,8 +241,8 @@ HandleBgErrors( Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - ckfree((char *) errPtr); - ckfree((char *) tempObjv); + ckfree(errPtr); + ckfree(tempObjv); if (code == TCL_BREAK) { /* @@ -258,7 +255,7 @@ HandleBgErrors( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree((char *) errPtr); + ckfree(errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); @@ -336,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -348,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { @@ -525,7 +524,7 @@ TclSetBgErrorHandler( * First access: initialize. */ - assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); + assocPtr = ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; @@ -604,7 +603,7 @@ BgErrorDeleteProc( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree((char *) errPtr); + ckfree(errPtr); } Tcl_CancelIdleCall(HandleBgErrors, assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); @@ -634,7 +633,7 @@ Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -667,7 +666,7 @@ TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -712,7 +711,7 @@ Tcl_DeleteExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree((char *) exitPtr); + ckfree(exitPtr); break; } } @@ -755,7 +754,7 @@ TclDeleteLateExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree((char *) exitPtr); + ckfree(exitPtr); break; } } @@ -789,7 +788,7 @@ Tcl_CreateThreadExitHandler( ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; @@ -831,7 +830,7 @@ Tcl_DeleteThreadExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree((char *) exitPtr); + ckfree(exitPtr); return; } } @@ -908,8 +907,8 @@ InvokeExitHandlers(void) firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); - (*exitPtr->proc)(exitPtr->clientData); - ckfree((char *) exitPtr); + exitPtr->proc(exitPtr->clientData); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstExitPtr = NULL; @@ -954,27 +953,38 @@ Tcl_Exit( currentAppExitPtr(INT2PTR(status)); Tcl_Panic("AppExitProc returned unexpectedly"); } else { - /* - * Use default handling. - */ - InvokeExitHandlers(); + if (TclFullFinalizationRequested()) { - /* - * Ensure the thread-specific data is initialised as it is used in - * Tcl_FinalizeThread() - */ - - (void) TCL_TSD_INIT(&dataKey); - - /* - * Now finalize the calling thread only (others are not safely - * reachable). Among other things, this triggers a flush of the - * Tcl_Channels that may have data enqueued. - */ - - Tcl_FinalizeThread(); - + /* + * Thorough finalization for Valgrind et al. + */ + + Tcl_Finalize(); + + } else { + + /* + * Fast and deterministic exit (default behavior) + */ + + InvokeExitHandlers(); + + /* + * Ensure the thread-specific data is initialised as it is used in + * Tcl_FinalizeThread() + */ + + (void) TCL_TSD_INIT(&dataKey); + + /* + * Now finalize the calling thread only (others are not safely + * reachable). Among other things, this triggers a flush of the + * Tcl_Channels that may have data enqueued. + */ + + Tcl_FinalizeThread(); + } TclpExit(status); Tcl_Panic("OS exit failed!"); } @@ -1124,7 +1134,7 @@ Tcl_Finalize(void) firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - ckfree((char *) exitPtr); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; @@ -1289,7 +1299,7 @@ Tcl_FinalizeThread(void) tsdPtr->firstExitPtr = exitPtr->nextPtr; exitPtr->proc(exitPtr->clientData); - ckfree((char *) exitPtr); + ckfree(exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); @@ -1406,7 +1416,7 @@ Tcl_VwaitObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); break; } } @@ -1416,8 +1426,9 @@ Tcl_VwaitObjCmd( if (!foundEvent) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't wait for variable \"%s\": would wait forever", + nameString)); Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); return TCL_ERROR; } @@ -1487,7 +1498,7 @@ Tcl_UpdateObjCmd( int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptions {REGEXP_IDLETASKS}; + enum updateOptions {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1497,7 +1508,7 @@ Tcl_UpdateObjCmd( return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: + case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: @@ -1514,7 +1525,7 @@ Tcl_UpdateObjCmd( } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); return TCL_ERROR; } } @@ -1555,7 +1566,7 @@ NewThreadProc( threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */ + ckfree(clientData); /* Allocated in Tcl_CreateThread() */ threadProc(threadClientData); @@ -1592,15 +1603,14 @@ Tcl_CreateThread( * thread. */ { #ifdef TCL_THREADS - ThreadClientData *cdPtr = (ThreadClientData *) - ckalloc(sizeof(ThreadClientData)); + ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); int result; cdPtr->proc = proc; cdPtr->clientData = clientData; result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); if (result != TCL_OK) { - ckfree((char *) cdPtr); + ckfree(cdPtr); } return result; #else diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4e6cb31..2b5f713 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,12 +13,11 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclExecute.c,v 1.499 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" #include "tommath.h" #include <math.h> @@ -55,6 +54,8 @@ static int execInitialized = 0; TCL_DECLARE_MUTEX(execMutex) +static int cachedInExit = 0; + #ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, @@ -170,42 +171,46 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct BottomData { +typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - struct BottomData *expanded;/* NULL if unchanged, pointer to the succesor - * if it was expanded */ const unsigned char *pc; /* These fields are used on return TO this */ ptrdiff_t *catchTop; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ int checkInterp; -} BottomData; - -#define NR_YIELD(invoke) \ - esPtr->tosPtr = tosPtr; \ - BP->pc = pc; \ - BP->cleanup = cleanup; \ - TclNRAddCallback(interp, TEBCresume, BP, \ - INT2PTR(invoke), NULL, NULL) - -#define NR_DATA_DIG() \ - pc = BP->pc; \ - cleanup = BP->cleanup; \ - tosPtr = esPtr->tosPtr - + CmdFrame cmdFrame; + void *stack[1]; /* Start of the actual combined catch and obj + * stacks; the struct will be expanded as + * necessary */ +} TEBCdata; + +#define TEBC_YIELD() \ + do { \ + esPtr->tosPtr = tosPtr; \ + TD->pc = pc; \ + TD->cleanup = cleanup; \ + TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ + } while (0) + +#define TEBC_DATA_DIG() \ + do { \ + pc = TD->pc; \ + cleanup = TD->cleanup; \ + tosPtr = esPtr->tosPtr; \ + } while (0) #define PUSH_TAUX_OBJ(objPtr) \ do { \ - objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ + objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) #define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ - Tcl_DecrRefCount(tmpPtr); \ + do { \ + tmpPtr = auxObjList; \ + auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + Tcl_DecrRefCount(tmpPtr); \ } while (0) /* @@ -335,7 +340,7 @@ VarHashCreateVar( #define OBJ_AT_DEPTH(n) *(tosPtr-(n)) -#define CURR_DEPTH (tosPtr - initTosPtr) +#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) /* * Macros used to trace instruction execution. The macros TRACE, @@ -345,7 +350,7 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ - while (traceInstructions) { \ + while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned) (pc - codePtr->codeStart), \ @@ -354,12 +359,12 @@ VarHashCreateVar( break; \ } # define TRACE_APPEND(a) \ - while (traceInstructions) { \ + while (traceInstructions) { \ printf a; \ break; \ } # define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ + while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned) (pc - codePtr->codeStart), \ @@ -385,13 +390,13 @@ VarHashCreateVar( #define TCL_DTRACE_INST_NEXT() \ do { \ if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ + if (curInstName) { \ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ tosPtr); \ } \ curInstName = tclInstructionTable[*pc].name; \ if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ + TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ tosPtr); \ } \ } else if (TCL_DTRACE_INST_START_ENABLED()) { \ @@ -401,7 +406,7 @@ VarHashCreateVar( } while (0) #define TCL_DTRACE_INST_LAST() \ do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ } \ } while (0) @@ -513,16 +518,6 @@ VarHashCreateVar( #else #define IsErroringNaNType(type) 0 #endif - -/* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. - */ - -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - NULL, NULL, NULL, NULL -}; /* * Auxiliary tables used to compute powers of small integers. @@ -707,13 +702,15 @@ static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, int *lengthPtr); + ByteCode *codePtr, int *lengthPtr, + const unsigned char **pcBeg); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int OFFSET(void *ptr); +static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); @@ -721,7 +718,6 @@ static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc TEBCresume; -static Tcl_NRPostProc TEBCreturn; /* * The structure below defines a bytecode Tcl object type to hold the @@ -735,6 +731,56 @@ static const Tcl_ObjType exprCodeType = { NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; + +/* + * Custom object type only used in this file; values of its type should never + * be seen by user scripts. + */ + +static const Tcl_ObjType dictIteratorType = { + "dictIterator", + ReleaseDictIterator, + NULL, NULL, NULL +}; + +/* + *---------------------------------------------------------------------- + * + * ReleaseDictIterator -- + * + * This takes apart a dictionary iterator that is stored in the given Tcl + * object. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory, marks the object as being untyped. + * + *---------------------------------------------------------------------- + */ + +static void +ReleaseDictIterator( + Tcl_Obj *objPtr) +{ + Tcl_DictSearch *searchPtr; + Tcl_Obj *dictPtr; + + /* + * First kill the search, and then release the reference to the dictionary + * that we were holding. + */ + + searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjDone(searchPtr); + ckfree(searchPtr); + + dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(dictPtr); + + objPtr->typePtr = NULL; +} /* *---------------------------------------------------------------------- @@ -803,8 +849,8 @@ TclCreateExecEnv( int size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack) + ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; @@ -855,7 +901,7 @@ static void DeleteExecStack( ExecStack *esPtr) { - if (esPtr->markerPtr) { + if (esPtr->markerPtr && !cachedInExit) { Tcl_Panic("freeing an execStack which is still in use"); } @@ -865,7 +911,7 @@ DeleteExecStack( if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - ckfree((char *) esPtr); + ckfree(esPtr); } void @@ -874,6 +920,8 @@ TclDeleteExecEnv( { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; + cachedInExit = TclInExit(); + /* * Delete all stacks in this exec env. */ @@ -889,13 +937,13 @@ TclDeleteExecEnv( TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); - if (eePtr->callbackPtr) { + if (eePtr->callbackPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } - if (eePtr->corPtr) { + if (eePtr->corPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with existing coroutine"); } - ckfree((char *) eePtr); + ckfree(eePtr); } /* @@ -1020,14 +1068,14 @@ GrowEvaluationStack( /* * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add the marker - * and maximal possible offset. + * any) and growth to hold the complete stack requirements: add one for + * the marker, (WALLOCALIGN-1) for the maximal possible offset. */ if (move) { moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } - needed = growth + moveWords + WALLOCALIGN - 1; + needed = growth + moveWords + WALLOCALIGN; /* * Check if there is enough room in the next stack (if there is one, it @@ -1065,7 +1113,7 @@ GrowEvaluationStack( newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *) ckalloc(newBytes); + esPtr = ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; @@ -1191,18 +1239,27 @@ TclStackFree( } /* - * Return to previous stack. + * Return to previous active stack. Note that repeated expansions or + * reallocs could have generated several unused intervening stacks: free + * them too. */ + while (esPtr->nextPtr) { + esPtr = esPtr->nextPtr; + } esPtr->tosPtr = &esPtr->stackWords[-1]; + while (esPtr->prevPtr) { + ExecStack *tmpPtr = esPtr->prevPtr; + if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { + DeleteExecStack(tmpPtr); + } else { + break; + } + } if (esPtr->prevPtr) { eePtr->execStackPtr = esPtr->prevPtr; - } - if (esPtr->nextPtr) { - if (!esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->nextPtr; - } - DeleteExecStack(esPtr); + } else { + eePtr->execStackPtr = esPtr; } } @@ -1281,7 +1338,7 @@ Tcl_ExprObj( Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); Tcl_Obj *resultPtr; TclNewObj(resultPtr); @@ -1365,7 +1422,6 @@ ExprObjCallback( if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_IncrRefCount(resultPtr); Tcl_SetObjResult(interp, saveObjPtr); } TclDecrRefCount(saveObjPtr); @@ -1411,7 +1467,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1451,7 +1507,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1523,14 +1579,14 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* @@ -1538,13 +1594,13 @@ FreeExprCodeInternalRep( * * TclCompileObj -- * - * This procedure compiles the script contained in a Tcl_Obj + * This procedure compiles the script contained in a Tcl_Obj. * * Results: * A pointer to the corresponding ByteCode, never NULL. * * Side effects: - * The object is shimmered to bytecode type + * The object is shimmered to bytecode type. * *---------------------------------------------------------------------- */ @@ -1584,30 +1640,29 @@ TclCompileObj( * here. */ - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto recompileObj; } + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; } - if (codePtr->procPtr == NULL) { - /* - * Check that any compiled locals do refer to the current proc - * environment! If not, recompile. - */ + /* + * Check that any compiled locals do refer to the current proc + * environment! If not, recompile. + */ - if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) { - goto recompileObj; - } + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && + (codePtr->procPtr == NULL) && + (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ + goto recompileObj; } /* @@ -1639,70 +1694,64 @@ TclCompileObj( * information. */ - { + if (invoker == NULL) { + return codePtr; + } else { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc *eclPtr; + CmdFrame *ctxCopyPtr; + int redo; - if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int redo = 0; - - if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - *ctxPtr = *invoker; + if (!hePtr) { + return codePtr; + } - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxCopyPtr = *invoker; - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + TclGetSrcInfoForPc(ctxCopyPtr); + if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ - if (word < ctxPtr->nline) { - /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). - */ + Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); + ctxCopyPtr->data.eval.path = NULL; + } + } - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); - } + if (word < ctxCopyPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This is a + * difference and requires a recompile (location changed from + * absolute to relative, literal is used fixed and through + * variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ - TclStackFree(interp, ctxPtr); - } + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxCopyPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); + } - if (redo) { - goto recompileObj; - } + TclStackFree(interp, ctxCopyPtr); + if (!redo) { + return codePtr; } } - - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - - runCompiledObj: - return codePtr; } recompileObj: @@ -1717,14 +1766,14 @@ TclCompileObj( iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; - tclByteCodeType.setFromAnyProc(interp, objPtr); + TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; codePtr = objPtr->internalRep.otherValuePtr; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - goto runCompiledObj; + return codePtr; } /* @@ -1871,10 +1920,10 @@ TclIncrObj( * *---------------------------------------------------------------------- */ -#define bcFramePtr ((CmdFrame *) (BP + 1)) -#define initCatchTop (((ptrdiff_t *) (bcFramePtr + 1)) - 1) +#define bcFramePtr (&TD->cmdFrame) +#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) #define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define esPtr (iPtr->execEnvPtr->execStackPtr) +#define esPtr (iPtr->execEnvPtr->execStackPtr) int TclNRExecuteByteCode( @@ -1882,18 +1931,22 @@ TclNRExecuteByteCode( ByteCode *codePtr) /* The bytecode sequence to interpret. */ { Interp *iPtr = (Interp *) interp; - BottomData *BP; - + TEBCdata *TD; + int size = sizeof(TEBCdata) - 1 + + (codePtr->maxStackDepth + codePtr->maxExceptDepth) + * sizeof(void *); + int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + if (iPtr->execEnvPtr->rewind) { return TCL_ERROR; } - + codePtr->refCount++; /* - * Reserve the stack, setup the BottomPtr and CallFrame + * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame * - * The execution uses a unified stack: first a BottomData, immediately + * The execution uses a unified stack: first a TEBCdata, immediately * above it a CmdFrame, then the catch stack, then the execution stack. * * Make sure the catch stack is large enough to hold the maximum number of @@ -1902,22 +1955,19 @@ TclNRExecuteByteCode( * execution stack is large enough to execute this ByteCode. */ - BP = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr, - sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame) - + codePtr->maxStackDepth, 0); + TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); esPtr->tosPtr = initTosPtr; - - BP->codePtr = codePtr; - BP->expanded = NULL; - BP->pc = codePtr->codeStart; - BP->catchTop = initCatchTop; - BP->cleanup = 0; - BP->auxObjList = NULL; - BP->checkInterp = 0; - + + TD->codePtr = codePtr; + TD->pc = codePtr->codeStart; + TD->catchTop = initCatchTop; + TD->cleanup = 0; + TD->auxObjList = NULL; + TD->checkInterp = 0; + /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed - * every time that we call out from this BP, popped when we return to it. + * every time that we call out from this TD, popped when we return to it. */ bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) @@ -1934,53 +1984,20 @@ TclNRExecuteByteCode( bcFramePtr->cmd.str.cmd = NULL; bcFramePtr->cmd.str.len = 0; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); - fflush(stdout); - } -#endif - #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; #endif /* - * Push the callbacks for - * - exception handling and cleanup - * - bytecode execution + * Push the callback for bytecode execution */ - - TclNRAddCallback(interp, TEBCreturn, BP, NULL, + + TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), NULL, NULL); - TclNRAddCallback(interp, TEBCresume, BP, - /*resume*/ INT2PTR(0), NULL, NULL); - return TCL_OK; } static int -TEBCreturn( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - BottomData *BP = data[0]; - ByteCode *codePtr = BP->codePtr; - - if (--codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - while (BP->expanded) { - BP = BP->expanded; - } - TclStackFree(interp, BP); /* free my stack */ - - return result; -} - -static int TEBCresume( ClientData data[], Tcl_Interp *interp, @@ -2003,7 +2020,6 @@ TEBCresume( /* * Bottom of allocated stack holds the NR data */ - /* NR_TEBC */ /* * Constants: variables that do not change during the execution, used @@ -2017,33 +2033,33 @@ TEBCresume( int traceInstructions; /* Whether we are doing instruction-level * tracing or not. */ #endif -#define LOCAL(i) (&iPtr->varFramePtr->compiledLocals[(i)]) -#define TCONST(i) (iPtr->execEnvPtr->constants[(i)]) + + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; + +#define LOCAL(i) (&compiledLocals[(i)]) +#define TCONST(i) (constants[(i)]) /* * These macros are just meant to save some global variables that are not * used too frequently */ - BottomData *BP = data[0]; -#define auxObjList (BP->auxObjList) -#define catchTop (BP->catchTop) -#define codePtr (BP->codePtr) -#define checkInterp (BP->checkInterp) - /* Indicates when a check of interp readyness - * is necessary. Set by CACHE_STACK_INFO() */ + TEBCdata *TD = data[0]; +#define auxObjList (TD->auxObjList) +#define catchTop (TD->catchTop) +#define codePtr (TD->codePtr) +#define checkInterp (TD->checkInterp) + /* Indicates when a check of interp readyness is + * necessary. Set by CACHE_STACK_INFO() */ /* * Globals: variables that store state, must remain valid at all times. */ - Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation - * stack. */ - const unsigned char *pc; /* The current program counter. */ - -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif + Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation + * stack. */ + const unsigned char *pc; /* The current program counter. */ /* * Transfer variables - needed only between opcodes, but not while @@ -2061,23 +2077,36 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv; - int opnd, objc, length, pcAdjustment; + int objc = 0; + int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; #endif - NR_DATA_DIG(); +#ifdef TCL_COMPILE_DEBUG + traceInstructions = (tclTraceExec == 3); +#endif + + TEBC_DATA_DIG(); + +#ifdef TCL_COMPILE_DEBUG + if (!data[1] && (tclTraceExec >= 2)) { + PrintByteCodeInfo(codePtr); + fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); + fflush(stdout); + } +#endif if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); - + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; @@ -2091,39 +2120,37 @@ TEBCresume( } #endif /* - * Push the call's object result and continue execution with - * the next instruction. + * Push the call's object result and continue execution with the + * next instruction. */ - + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - + objc, cmdNameBuf), Tcl_GetObjResult(interp)); + objResultPtr = Tcl_GetObjResult(interp); - + /* * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult - * to avoid any side effects caused by the resetting of - * errorInfo and errorCode [Bug 804681], which are not needed - * here. We chose instead to manipulate the interp's object - * result directly. + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of - * iPtr->objResultPtr. + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. */ - + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; - NEXT_INST_V(0, cleanup, -1); + NEXT_INST_V(0, cleanup, -1); } - + /* * Result not TCL_OK: fall through */ } - + if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; goto abnormalReturn; @@ -2232,9 +2259,11 @@ TEBCresume( } } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + if (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; + } } if (TclLimitReady(iPtr->limit)) { @@ -2303,6 +2332,101 @@ TEBCresume( cleanup = 1; goto processExceptionReturn; + case INST_YIELD: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); + if (!corPtr) { + TRACE_APPEND(("ERROR: yield outside coroutine\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); + } +#endif + /* TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + + pc++; + cleanup = 1; + TEBC_YIELD(); + + Tcl_SetObjResult(interp, OBJ_AT_TOS); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + INT2PTR(0), NULL, NULL); + + return TCL_OK; + } + + case INST_TAILCALL: { + Tcl_Obj *listPtr, *nsObjPtr; + NRE_callback *tailcallPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { + TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + { + register int i; + + TRACE(("%d [", opnd)); + for (i=opnd-1 ; i>=0 ; i--) { + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); + if (i > 0) { + TRACE_APPEND((" ")); + } + } + TRACE_APPEND(("] => RETURN...")); + } +#endif + + /* + * Push the evaluation of the called command into the NR callback + * stack. + */ + + listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); + Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(nsObjPtr); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); + + /* + * Unstitch ourselves and do a [return]. + */ + + tailcallPtr = TOP_CB(interp); + TOP_CB(interp) = tailcallPtr->nextPtr; + iPtr->varFramePtr->tailcallPtr = tailcallPtr; + result = TCL_RETURN; + cleanup = opnd; + goto processExceptionReturn; + } + case INST_DONE: if (tosPtr > initTosPtr) { /* @@ -2403,7 +2527,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -2523,7 +2647,6 @@ TEBCresume( #if !TCL_COMPILE_DEBUG if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { TclFreeIntRep(objResultPtr); - objResultPtr->typePtr = NULL; objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); objResultPtr->length = length + appendLen; p = TclGetString(objResultPtr) + length; @@ -2531,7 +2654,7 @@ TEBCresume( } else #endif { - p = (char *) ckalloc((unsigned) (length + appendLen + 1)); + p = ckalloc(length + appendLen + 1); TclNewObj(objResultPtr); objResultPtr->bytes = p; objResultPtr->length = length + appendLen; @@ -2605,7 +2728,7 @@ TEBCresume( */ TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; + objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); @@ -2637,17 +2760,16 @@ TEBCresume( length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); DECACHE_STACK_INFO(); moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) BP; + - (Tcl_Obj **) TD; if (moved) { /* * Change the global data to point to the new stack: move the - * bottomPtr, recompute the position of every other + * TEBCdataPtr TD, recompute the position of every other * stack-allocated parameter, update the stack pointers. */ esPtr = iPtr->execEnvPtr->execStackPtr; - BP->expanded = (BottomData *) (((Tcl_Obj **)BP) + moved); - BP = BP->expanded; + TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); catchTop += moved; tosPtr += moved; @@ -2676,7 +2798,7 @@ TEBCresume( CACHE_STACK_INFO(); cleanup = 1; pc++; - NR_YIELD(1); + TEBC_YIELD(); return TclNRExecuteByteCode(interp, newCodePtr); } @@ -2691,13 +2813,12 @@ TEBCresume( cleanup = 1; pc += 1; - NR_YIELD(1); + TEBC_YIELD(); return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1; + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -2754,13 +2875,15 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } DECACHE_STACK_INFO(); pc += pcAdjustment; - NR_YIELD(1); + TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); @@ -3730,11 +3853,132 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; + + /* + * This is really an unset operation these days. Do not issue. + */ + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u\n", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { + if (!TclIsVarUndefined(varPtr)) { + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = NULL; + } else { + DECACHE_STACK_INFO(); + TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + NEXT_INST_F(5, 0, 0); } /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- + * Start of INST_ARRAY instructions. + */ + + case INST_ARRAY_EXISTS_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayExists; + case INST_ARRAY_EXISTS_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/0, /*createPart2*/0, &arrayPtr); + doArrayExists: + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + DECACHE_STACK_INFO(); + result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| + TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + } + if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + objResultPtr = TCONST(1); + } else { + objResultPtr = TCONST(0); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_ARRAY_MAKE_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 0; + part1Ptr = NULL; + arrayPtr = NULL; + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doArrayMake; + case INST_ARRAY_MAKE_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 1; + part1Ptr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + doArrayMake: + if (varPtr && !TclIsVarArray(varPtr)) { + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", + "variable isn't array", opnd); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + TRACE_APPEND(("ERROR: bad array ref: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, + TclGetVarNsPtr(varPtr)); +#ifdef TCL_COMPILE_DEBUG + TRACE_APPEND(("done\n")); + } else { + TRACE_APPEND(("nothing to do\n")); +#endif + } + NEXT_INST_V(pcAdjustment, cleanup, 0); + + /* + * End of INST_ARRAY instructions. + * ----------------------------------------------------------------- * Start of variable linking instructions. */ @@ -3970,7 +4214,7 @@ TEBCresume( (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + CACHE_STACK_INFO(); goto gotError; } @@ -3979,7 +4223,7 @@ TEBCresume( (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + CACHE_STACK_INFO(); goto gotError; } @@ -3995,6 +4239,136 @@ TEBCresume( /* * ----------------------------------------------------------------- + * Start of general introspector instructions. + */ + + case INST_NS_CURRENT: { + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objResultPtr, "::"); + } else { + TclNewStringObj(objResultPtr, currNsPtr->fullName, + strlen(currNsPtr->fullName)); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_COROUTINE_NAME: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TclNewObj(objResultPtr); + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, + objResultPtr); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_INFO_LEVEL_NUM: + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_INFO_LEVEL_ARGS: { + int level; + register CallFrame *framePtr = iPtr->varFramePtr; + register CallFrame *rootFramePtr = iPtr->rootFramePtr; + + valuePtr = OBJ_AT_TOS; + if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE(("%d => ", level)); + if (level <= 0) { + level += framePtr->level; + } + for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + framePtr = framePtr->callerVarPtr) { + /* Empty loop body */ + } + if (framePtr == rootFramePtr) { + Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), + "\"", NULL); + TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + TclGetString(valuePtr), NULL); + goto gotError; + } + objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + case INST_RESOLVE_COMMAND: { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + + TclNewObj(objResultPtr); + if (cmd != NULL) { + Tcl_GetCommandFullName(interp, cmd, objResultPtr); + } + TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } + case INST_TCLOO_SELF: { + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE(("=> ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "self may only be called from inside a method", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + goto gotError; + } + contextPtr = framePtr->clientData; + + /* + * Call out to get the name; it's expensive to compute but cached. + */ + + objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + { + Object *oPtr; + + case INST_TCLOO_IS_OBJECT: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + objResultPtr = TCONST(oPtr != NULL ? 1 : 0); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + case INST_TCLOO_CLASS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + case INST_TCLOO_NS: + oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + if (oPtr == NULL) { + TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + goto gotError; + } + + /* + * TclOO objects *never* have the global namespace as their NS. + */ + + TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, + strlen(oPtr->namespacePtr->fullName)); + TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } + + /* + * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4260,12 +4634,33 @@ TEBCresume( */ if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx<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; + + if (listPtr->refCount == 1) { + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), + TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); + for (index=toIdx+1 ; index<objc-1 ; index++) { + TclDecrRefCount(objv[index]); + } + listPtr->elemCount = toIdx+1; + listPtr->canonicalFlag = 1; + TclInvalidateStringRep(valuePtr); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(9, 0, 0); + } + } objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { TclNewObj(objResultPtr); @@ -4359,6 +4754,7 @@ TEBCresume( * 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) @@ -4370,7 +4766,7 @@ TEBCresume( s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->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 @@ -4520,6 +4916,176 @@ TEBCresume( O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + case INST_STR_RANGE: + TRACE(("\"%.20s\" %s %s =>", + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); + length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + goto gotError; + } + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(1, 3, 1); + + case INST_STR_RANGE_IMM: + valuePtr = OBJ_AT_TOS; + fromIdx = TclGetInt4AtPtr(pc+1); + toIdx = TclGetInt4AtPtr(pc+5); + length = Tcl_GetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + + /* + * Adjust indices for end-based indexing. + */ + + if (fromIdx < -1) { + fromIdx += 1 + length; + if (fromIdx < 0) { + fromIdx = 0; + } + } else if (fromIdx >= length) { + fromIdx = length; + } + if (toIdx < -1) { + toIdx += 1 + length; + } else if (toIdx >= length) { + toIdx = length - 1; + } + + /* + * Check if we can do a sane substring. + */ + + if (fromIdx <= toIdx) { + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); + + { + Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; + int length3; + Tcl_Obj *value3Ptr; + + case INST_STR_MAP: + valuePtr = OBJ_AT_TOS; /* "Main" string. */ + value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ + value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ + if (value3Ptr == value2Ptr) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } else if (valuePtr == value2Ptr) { + objResultPtr = value3Ptr; + NEXT_INST_V(1, 3, 1); + } + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } else if (length2 == length) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { + objResultPtr = valuePtr; + } else { + objResultPtr = value3Ptr; + } + NEXT_INST_V(1, 3, 1); + } + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + + objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + p = ustring1; + end = ustring1 + length; + for (; ustring1 < end; ustring1++) { + if ((*ustring1 == *ustring2) && (length2==1 || + memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) + == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + } + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ + + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + } + TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", + O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); + NEXT_INST_V(1, 3, 1); + + case INST_STR_FIND: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + end = ustring1 + length - length2 + 1; + for (p=ustring1 ; p<end ; p++) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + NEXT_INST_F(1, 2, 1); + + case INST_STR_FIND_LAST: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + NEXT_INST_F(1, 2, 1); + } + case INST_STR_MATCH: nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ @@ -4824,8 +5390,8 @@ TEBCresume( case INST_RSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4872,8 +5438,8 @@ TEBCresume( case INST_LSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -4895,9 +5461,8 @@ TEBCresume( * good place to draw the line. */ - Tcl_SetResult(interp, - "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", @@ -5165,7 +5730,7 @@ TEBCresume( NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: + case INST_BITNOT: valuePtr = OBJ_AT_TOS; if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { @@ -5572,46 +6137,78 @@ TEBCresume( { int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr; + Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; + case INST_DICT_VERIFY: + dictPtr = OBJ_AT_TOS; + TRACE(("=> ")); + if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", + O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(1, 1, 0); + case INST_DICT_GET: + case INST_DICT_EXISTS: { + register Tcl_Interp *interp2 = interp; + opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); + if (*pc == INST_DICT_EXISTS) { + interp2 = NULL; + } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { + if (*pc == INST_DICT_EXISTS) { + goto dictNotExists; + } TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(OBJ_AT_DEPTH(opnd))), + "ERROR tracing dictionary path into \"%s\": ", + O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { + if (*pc == INST_DICT_EXISTS) { + objResultPtr = TCONST(objResultPtr ? 1 : 0); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } if (objResultPtr) { TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); } DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); CACHE_STACK_INFO(); TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); } else { + if (*pc == INST_DICT_EXISTS) { + dictNotExists: + objResultPtr = TCONST(0); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } TRACE_WITH_OBJ(( "%u => ERROR reading leaf dictionary key \"%s\": ", opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); } goto gotError; + } case INST_DICT_SET: case INST_DICT_UNSET: @@ -5665,7 +6262,7 @@ TEBCresume( } result = TclIncrObj(interp, valuePtr, value2Ptr); if (result == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } TclDecrRefCount(value2Ptr); } @@ -5769,6 +6366,16 @@ TEBCresume( Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); } else { Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; case INST_DICT_LAPPEND: @@ -5799,6 +6406,16 @@ TEBCresume( } goto gotError; } + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; default: @@ -5840,10 +6457,10 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { - ckfree((char *) searchPtr); + ckfree(searchPtr); goto gotError; } TclNewObj(statePtr); @@ -5910,39 +6527,6 @@ TEBCresume( /* TODO: consider opt like INST_FOREACH_STEP4 */ NEXT_INST_F(5, 0, 1); - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL) { - Tcl_Panic("mis-issued dictDone!"); - } - - if (statePtr->typePtr == &dictIteratorType) { - /* - * First kill the search, and then release the reference to the - * dictionary that we were holding. - */ - - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree((char *) searchPtr); - - dictPtr = statePtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); - - /* - * Set the internal variable to an empty object to signify that we - * don't hold an iterator. - */ - - TclDecrRefCount(statePtr); - TclNewObj(emptyPtr); - (*LOCAL(opnd)).value.objPtr = emptyPtr; - Tcl_IncrRefCount(emptyPtr); - } - NEXT_INST_F(5, 0, 0); - case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); @@ -6022,6 +6606,9 @@ TEBCresume( if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); } + if (length > 0) { + TclInvalidateStringRep(dictPtr); + } for (i=0 ; i<length ; i++) { Var *var2Ptr = LOCAL(duiPtr->varIndices[i]); @@ -6062,6 +6649,78 @@ TEBCresume( } } NEXT_INST_F(9, 1, 0); + + case INST_DICT_EXPAND: + dictPtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", + O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + + case INST_DICT_RECOMBINE_STK: + keysPtr = POP_OBJECT(); + varNamePtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(keysPtr); + goto gotError; + } + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(keysPtr); + goto gotError; + } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, + objc, objv, keysPtr); + CACHE_STACK_INFO(); + TclDecrRefCount(keysPtr); + if (result != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(1, 2, 0); + + case INST_DICT_RECOMBINE_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + listPtr = OBJ_UNDER_TOS; + keysPtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), + O2S(keysPtr))); + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, + objc, objv, keysPtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(5, 2, 0); } /* @@ -6169,10 +6828,10 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - CACHE_STACK_INFO(); + CACHE_STACK_INFO(); goto gotError; /* @@ -6181,9 +6840,9 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); @@ -6209,9 +6868,12 @@ TEBCresume( goto abnormalReturn; } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + const unsigned char *pcBeg; + + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); DECACHE_STACK_INFO(); - Tcl_LogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0); + TclLogCommandInfo(interp, codePtr->source, bytes, + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6222,8 +6884,9 @@ TEBCresume( */ while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + if ((catchTop != initCatchTop) + && (*catchTop > (ptrdiff_t) + auxObjList->internalRep.ptrAndLongRep.value)) { break; } POP_TAUX_OBJ(); @@ -6238,7 +6901,7 @@ TEBCresume( * already be set prior to vectoring down to this point in the code. */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... cancel with unwind, returning %s\n", @@ -6352,15 +7015,15 @@ TEBCresume( CLANG_ASSERT(bcFramePtr); } - /* - * Store the previous bottomPtr for returning to it, then free all - * resources used by this bytecode and process callbacks until you return - * to the previous bytecode (if any). - */ - iPtr->cmdFramePtr = bcFramePtr->nextPtr; + if (--codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + TclStackFree(interp, TD); /* free my stack */ + return result; } + #undef codePtr #undef iPtr #undef bcFramePtr @@ -6555,7 +7218,8 @@ ExecuteExtendedBinaryMathOp( invalid = 0; } if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -6585,8 +7249,8 @@ ExecuteExtendedBinaryMathOp( * place to draw the line. */ - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const long *)ptr2)); @@ -6987,7 +7651,8 @@ ExecuteExtendedBinaryMathOp( */ if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -7225,7 +7890,8 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -7844,7 +8510,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); @@ -7958,7 +8624,7 @@ TclGetSrcInfoForCmd( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr); + codePtr, lenPtr, NULL); } void @@ -7970,7 +8636,7 @@ TclGetSrcInfoForPc( if (cfPtr->cmd.str.cmd == NULL) { cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len); + &cfPtr->cmd.str.len, NULL); } if (cfPtr->cmd.str.cmd != NULL) { @@ -8021,15 +8687,18 @@ TclGetSrcInfoForPc( static const char * GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to + const unsigned char *pc, /* The program counter value for which to * return the closest command's source info. - * This points to a bytecode instruction in - * codePtr's code. */ + * This points within a bytecode instruction + * in codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - int *lengthPtr) /* If non-NULL, the location where the length + int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ + const unsigned char **pcBeg)/* If non-NULL, the bytecode location + * where the current instruction starts. + * If NULL; no pointer is stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8041,6 +8710,7 @@ GetSrcInfoForPc( int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + if (pcBeg != NULL) *pcBeg = NULL; return NULL; } @@ -8109,6 +8779,23 @@ GetSrcInfoForPc( } } + if (pcBeg != NULL) { + const unsigned char *curr, *prev; + + /* + * Walk from beginning of command or BC to pc, by complete + * instructions. Stop when crossing pc; keep previous. + */ + + curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); + prev = curr; + while (curr <= pc) { + prev = curr; + curr += tclInstructionTable[*curr].numBytes; + } + *pcBeg = prev; + } + if (bestDist == INT_MAX) { return NULL; } @@ -8116,6 +8803,7 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + return (codePtr->source + bestSrcOffset); } @@ -8338,9 +9026,13 @@ EvalStatsCmd( int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; + Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + numInstructions = 0.0; for (i = 0; i < 256; i++) { if (statsPtr->instructionCount[i] != 0) { @@ -8371,65 +9063,65 @@ EvalStatsCmd( * Summary statistics, total and current source and ByteCode sizes. */ - fprintf(stdout, "\n----------------------------------------------------------------\n"); - fprintf(stdout, - "Compilation and execution statistics for interpreter 0x%p\n", - iPtr); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, + "Compilation and execution statistics for interpreter %#lx\n", + (long int)iPtr); - fprintf(stdout, "\nNumber ByteCodes executed\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", statsPtr->numExecutions); - fprintf(stdout, "Number ByteCodes compiled\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Mean executions/compile\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); - fprintf(stdout, "\nInstructions executed\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", numInstructions); - fprintf(stdout, " Mean inst/compile\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", numInstructions / statsPtr->numCompilations); - fprintf(stdout, " Mean inst/execution\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - fprintf(stdout, "\nTotal ByteCodes\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); - fprintf(stdout, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", totalCodeBytes); - fprintf(stdout, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->totalByteCodeBytes); - fprintf(stdout, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), statsPtr->totalLitStringBytes); - fprintf(stdout, " Mean code/compile\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", totalCodeBytes / statsPtr->numCompilations); - fprintf(stdout, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent (active) ByteCodes\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", numCurrentByteCodes); - fprintf(stdout, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); - fprintf(stdout, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", currentCodeBytes); - fprintf(stdout, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->currentByteCodeBytes); - fprintf(stdout, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), statsPtr->currentLitStringBytes); - fprintf(stdout, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - fprintf(stdout, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); @@ -8441,18 +9133,18 @@ EvalStatsCmd( */ numSharedMultX = 0; - fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); - fprintf(stdout, " Object had refcount <=1 (not shared)\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - fprintf(stdout, " refcount ==%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - fprintf(stdout, " refcount >=%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - fprintf(stdout, " Total shared objects\t\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", numSharedMultX); /* @@ -8489,48 +9181,48 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - fprintf(stdout, "\nTotal objects (all interps)\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", tclObjsAlloced); - fprintf(stdout, "Current objects\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", (tclObjsAlloced - tclObjsFreed)); - fprintf(stdout, "Total literal objects\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", statsPtr->numLiteralsCreated); - fprintf(stdout, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - fprintf(stdout, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - fprintf(stdout, " Literals reused > 1x\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", numSharedMultX); - fprintf(stdout, " Mean reference count\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - fprintf(stdout, " Mean len, str reused >1x \t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - fprintf(stdout, " Mean len, str used 1x\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - fprintf(stdout, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - fprintf(stdout, " Bytes with sharing\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), statsPtr->currentLitStringBytes); - fprintf(stdout, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - fprintf(stdout, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - fprintf(stdout, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); - fprintf(stdout, " table %lu + buckets %lu + entries %lu\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); @@ -8539,33 +9231,33 @@ EvalStatsCmd( * Breakdown of current ByteCode space requirements. */ - fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); - fprintf(stdout, " Bytes Pct of Avg per\n"); - fprintf(stdout, " total ByteCode\n"); - fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); + Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); + Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); + Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, statsPtr->currentByteCodeBytes / numCurrentByteCodes); - fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", currentHeaderBytes, Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), currentHeaderBytes / numCurrentByteCodes); - fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", statsPtr->currentInstBytes, Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), statsPtr->currentInstBytes / numCurrentByteCodes); - fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", statsPtr->currentLitBytes, Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), statsPtr->currentLitBytes / numCurrentByteCodes); - fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", statsPtr->currentExceptBytes, Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), statsPtr->currentExceptBytes / numCurrentByteCodes); - fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", statsPtr->currentAuxBytes, Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), statsPtr->currentAuxBytes / numCurrentByteCodes); - fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", statsPtr->currentCmdMapBytes, Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); @@ -8574,8 +9266,8 @@ EvalStatsCmd( * Detailed literal statistics. */ - fprintf(stdout, "\nLiteral string sizes:\n"); - fprintf(stdout, "\t Up to length\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { @@ -8587,21 +9279,21 @@ EvalStatsCmd( for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); - fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - ckfree((char *) litTableStats); + ckfree(litTableStats); /* * Source and ByteCode size distributions. */ - fprintf(stdout, "\nSource sizes:\n"); - fprintf(stdout, "\t Up to size\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { @@ -8619,12 +9311,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode sizes:\n"); - fprintf(stdout, "\t Up to size\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { @@ -8642,12 +9334,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); - fprintf(stdout, "\t Up to ms\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { @@ -8665,7 +9357,7 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - fprintf(stdout, "\t%12.3f\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -8673,28 +9365,46 @@ EvalStatsCmd( * Instruction counts. */ - fprintf(stdout, "\nInstruction counts:\n"); + Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s %8ld %6.1f%%\n", - tclInstructionTable[i].name, - statsPtr->instructionCount[i], + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", + tclInstructionTable[i].name, statsPtr->instructionCount[i]); + if (statsPtr->instructionCount[i]) { + Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", Percent(statsPtr->instructionCount[i], numInstructions)); - } - } - - fprintf(stdout, "\nInstructions NEVER executed:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + } else { + Tcl_AppendPrintfToObj(objPtr, "0\n"); } } #ifdef TCL_MEM_DEBUG - fprintf(stdout, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(stdout); + Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif - fprintf(stdout, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + + if (objc == 1) { + Tcl_SetObjResult(interp, objPtr); + } else { + Tcl_Channel outChan; + char *str = Tcl_GetStringFromObj(objv[1], &length); + + if (length) { + if (strcmp(str, "stdout") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(str, "stderr") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDERR); + } else { + outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); + } + } else { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } + if (outChan != NULL) { + Tcl_WriteObj(outChan, objPtr); + } + } + Tcl_DecrRefCount(objPtr); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 8ff6e39..33c1496 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -8,11 +8,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclFCmd.c,v 1.51 2010/02/24 10:32:17 dkf Exp $ */ #include "tclInt.h" +#include "tclFileSystem.h" /* * Declarations for local functions defined in this file: @@ -48,6 +47,7 @@ static int FileForceOption(Tcl_Interp *interp, int TclFileRenameCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Interp for error reporting or recursive * calls in the case of a tricky rename. */ int objc, /* Number of arguments. */ @@ -76,6 +76,7 @@ TclFileRenameCmd( int TclFileCopyCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting or recursive calls * in the case of a tricky copy. */ int objc, /* Number of arguments. */ @@ -113,22 +114,20 @@ FileCopyRename( Tcl_StatBuf statBuf; Tcl_Obj *target; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; + i++; if ((objc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - TclGetString(objv[0]), " ", TclGetString(objv[1]), - " ?-option value ...? source ?source ...? target\"", NULL); + Tcl_WrongNumArgs(interp, 1, objv, + "?-option value ...? source ?source ...? target"); return TCL_ERROR; } /* - * If target doesn't exist or isn't a directory, try the copy/rename. - * More than 2 arguments is only valid if the target is an existing - * directory. + * If target doesn't exist or isn't a directory, try the copy/rename. More + * than 2 arguments is only valid if the target is an existing directory. */ target = objv[objc - 1]; @@ -148,9 +147,9 @@ FileCopyRename( if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); - Tcl_AppendResult(interp, "error ", - (copyFlag ? "copying" : "renaming"), ": target \"", - TclGetString(target), "\" is not a directory", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error %s: target \"%s\" is not a directory", + (copyFlag?"copying":"renaming"), TclGetString(target))); result = TCL_ERROR; } else { /* @@ -173,7 +172,6 @@ FileCopyRename( for ( ; i<objc-1 ; i++) { Tcl_Obj *jargv[2]; Tcl_Obj *source, *newFileName; - Tcl_Obj *temp; source = FileBasename(interp, objv[i]); if (source == NULL) { @@ -182,13 +180,11 @@ FileCopyRename( } jargv[0] = objv[objc - 1]; jargv[1] = source; - temp = Tcl_NewListObj(2, jargv); - newFileName = Tcl_FSJoinPath(temp, -1); + newFileName = TclJoinPath(2, jargv); Tcl_IncrRefCount(newFileName); result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, force); Tcl_DecrRefCount(newFileName); - Tcl_DecrRefCount(temp); Tcl_DecrRefCount(source); if (result == TCL_ERROR) { @@ -218,26 +214,25 @@ FileCopyRename( int TclFileMakeDirsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_Obj *errfile; + Tcl_Obj *errfile = NULL; int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; - errfile = NULL; - result = TCL_OK; - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - split = Tcl_FSSplitPath(objv[i],&pobjc); + split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); if (pobjc == 0) { errno = ENOENT; @@ -274,19 +269,17 @@ TclFileMakeDirsCmd( * subdirectory. */ - if (errno == EEXIST) { - 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) { + 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; @@ -306,8 +299,9 @@ TclFileMakeDirsCmd( done: if (errfile != NULL) { - Tcl_AppendResult(interp, "can't create directory \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create directory \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); result = TCL_ERROR; } if (split != NULL) { @@ -338,6 +332,7 @@ TclFileMakeDirsCmd( int TclFileDeleteCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ @@ -346,16 +341,15 @@ TclFileDeleteCmd( Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; errfile = NULL; result = TCL_OK; - for ( ; i < objc; i++) { + for (i++ ; i < objc; i++) { Tcl_StatBuf statBuf; errfile = objv[i]; @@ -386,9 +380,9 @@ TclFileDeleteCmd( result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(objv[i]), "\": directory not empty", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": directory not empty", + TclGetString(objv[i]))); Tcl_PosixError(interp); goto done; } @@ -428,12 +422,13 @@ TclFileDeleteCmd( * We try to accomodate poor error results from our Tcl_FS calls. */ - Tcl_AppendResult(interp, "error deleting unknown file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting unknown file: %s", + Tcl_PosixError(interp))); } else { - Tcl_AppendResult(interp, "error deleting \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error deleting \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); } } @@ -522,7 +517,7 @@ CopyRenameOneFile( * 16 bits and we get collisions. See bug #2015723. */ -#ifndef WIN32 +#if !defined(WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { @@ -542,17 +537,17 @@ CopyRenameOneFile( if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", - TclGetString(target), "\" with directory \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite file \"%s\" with directory \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", - TclGetString(target), "\" with file \"", - TclGetString(source), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't overwrite directory \"%s\" with file \"%s\"", + TclGetString(target), TclGetString(source))); goto done; } @@ -583,10 +578,10 @@ CopyRenameOneFile( } if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", - TclGetString(source), "\" to \"", TclGetString(target), - "\": trying to rename a volume or " - "move a directory into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error renaming \"%s\" to \"%s\": trying to rename a" + " volume or move a directory into itself", + TclGetString(source), TclGetString(target))); goto done; } else if (errno != EXDEV) { errfile = target; @@ -630,8 +625,9 @@ CopyRenameOneFile( * Actual file doesn't exist. */ - Tcl_AppendResult(interp, "error copying \"", TclGetString(source), - "\": the target of this link doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error copying \"%s\": the target of this link doesn't" + " exist", TclGetString(source))); goto done; } else { int counter = 0; @@ -766,23 +762,27 @@ CopyRenameOneFile( } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s", + TclGetString(errfile), Tcl_PosixError(interp))); errfile = NULL; } } done: if (errfile != NULL) { - Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"), - " \"", TclGetString(source), NULL); + Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"", + (copyFlag ? "copying" : "renaming"), TclGetString(source)); + if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL); + Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"", + TclGetString(target)); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL); + Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"", + TclGetString(errfile)); } } - Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL); + Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp)); + Tcl_SetObjResult(interp, errorMsg); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); @@ -821,22 +821,25 @@ FileForceOption( int *forcePtr) /* If the "-force" was specified, *forcePtr is * filled with 1, otherwise with 0. */ { - int force, i; + int force, i, idx; + static const char *const options[] = { + "-force", "--", NULL + }; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } - if (strcmp(TclGetString(objv[i]), "-force") == 0) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + &idx) != TCL_OK) { + return -1; + } + if (idx == 0 /* -force */) { force = 1; - } else if (strcmp(TclGetString(objv[i]), "--") == 0) { + } else { /* -- */ i++; break; - } else { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), - "\": should be -force or --", NULL); - return -1; } } *forcePtr = force; @@ -940,6 +943,7 @@ FileBasename( int TclFileAttrsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ @@ -951,22 +955,25 @@ TclFileAttrsCmd( int numObjStrings = -1; Tcl_Obj *filePtr; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "name ?-option value ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); return TCL_ERROR; } - filePtr = objv[2]; + filePtr = objv[1]; if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - objc -= 3; - objv += 3; + objc -= 2; + objv += 2; result = TCL_ERROR; Tcl_SetErrno(0); + /* + * Get the set of attribute names from the filesystem. + */ + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { int index; @@ -978,12 +985,12 @@ TclFileAttrsCmd( * There was an error, probably that the filePtr is not * accepted by any filesystem */ - Tcl_AppendResult(interp, "could not read \"", - TclGetString(filePtr), "\": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(filePtr), Tcl_PosixError(interp))); } - goto end; + return TCL_ERROR; } /* @@ -1007,7 +1014,16 @@ TclFileAttrsCmd( } attributeStringsAllocated[index] = NULL; attributeStrings = attributeStringsAllocated; + } else if (objStrings != NULL) { + Tcl_Panic("must not update objPtrRef's variable and return non-NULL"); } + + /* + * Process the attributes to produce a list of all of them, the value of a + * particular attribute, or to set one or more attributes (depending on + * the number of arguments). + */ + if (objc == 0) { /* * Get all attributes. @@ -1058,9 +1074,10 @@ TclFileAttrsCmd( Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1068,6 +1085,9 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[0]); + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1081,9 +1101,10 @@ TclFileAttrsCmd( int i, index; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), - "\", there are no file attributes in this filesystem.", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\", there are no file attributes in this" + " filesystem", TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } @@ -1092,9 +1113,14 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[i]); + } if (i + 1 == objc) { - Tcl_AppendResult(interp, "value for \"", - TclGetString(objv[i]), "\" missing", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "value for \"%s\" missing", TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", + "NOVALUE", NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, @@ -1105,23 +1131,380 @@ TclFileAttrsCmd( } result = TCL_OK; + /* + * Free up the array we allocated and drop our reference to any list of + * attribute names issued by the filesystem. + */ + end: if (attributeStringsAllocated != NULL) { + TclStackFree(interp, (void *) attributeStringsAllocated); + } + if (objStrings != NULL) { + Tcl_DecrRefCount(objStrings); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileLinkCmd -- + * + * This function is invoked to process the "file link" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a new link. + * + *---------------------------------------------------------------------- + */ + +int +TclFileLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + int index; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* + * Index of the 'source' argument. + */ + + if (objc == 4) { + index = 2; + } else { + index = 1; + } + + if (objc > 2) { + int linkAction; + + if (objc == 4) { + /* + * We have a '-linktype' argument. + */ + + static const char *const linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, + &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + /* - * Free up the array we allocated. + * Create link from source to target. */ - TclStackFree(interp, (void *) attributeStringsAllocated); + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all other + * errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": that path already" + " exists", TclGetString(objv[index]))); + Tcl_PosixError(interp); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't exist, + * or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { + return TCL_ERROR; + } + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": no such file" + " or directory", TclGetString(objv[index]))); + Tcl_PosixError(interp); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\": target \"%s\" " + "doesn't exist", TclGetString(objv[index]), + TclGetString(objv[index+1]))); + errno = ENOENT; + Tcl_PosixError(interp); + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not create new link \"%s\" pointing to \"%s\": %s", + TclGetString(objv[index]), + TclGetString(objv[index+1]), Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } /* - * We don't need this object that was passed to us any more. + * Read link */ - if (objStrings != NULL) { - Tcl_DecrRefCount(objStrings); + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[index]), Tcl_PosixError(interp))); + return TCL_ERROR; } } - return result; + Tcl_SetObjResult(interp, contents); + if (objc == 2) { + /* + * If we are reading a link, we need to free this result refCount. If + * we are creating a link, this will just be objv[index+1], and so we + * don't own it. + */ + + Tcl_DecrRefCount(contents); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileReadLinkCmd -- + * + * This function is invoked to process the "file readlink" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileReadLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + contents = Tcl_FSLink(objv[1], NULL, 0); + + if (contents == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read link \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileTemporaryCmd + * + * This function implements the "tempfile" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary file. Opens a channel to that file and puts the + * name of that channel in the result. *Might* register suitable exit + * handlers to ensure that the temporary file gets deleted. Might write + * to a variable, so reentrancy is a potential issue. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTemporaryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary + * file in. */ + Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ + Tcl_Channel chan; /* The channel opened (RDWR) on the temporary + * file, or NULL if there's an error. */ + Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + nameVarObj = objv[1]; + TclNewObj(nameObj); + } + if (objc > 2) { + int length; + Tcl_Obj *templateObj = objv[2]; + const char *string = TclGetStringFromObj(templateObj, &length); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it. + */ + + if (strchr(string, '/') != NULL + || (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(string, '\\') != NULL)) { + tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + + /* + * Only allow creation of temporary files in the native filesystem + * since they are frequently used for integration with external + * tools or system libraries. [Bug 2388866] + */ + + if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + } + + /* + * The template only gives the filename if the last character isn't a + * directory separator. + */ + + if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS + || string[length-1] != '\\')) { + Tcl_Obj *tailObj = TclPathPart(interp, templateObj, + TCL_PATH_TAIL); + + if (tailObj != NULL) { + tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); + tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); + TclDecrRefCount(tailObj); + } + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (tempDirObj && !TclGetString(tempDirObj)[0]) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { + TclDecrRefCount(tempBaseObj); + tempBaseObj = NULL; + } + if (tempExtObj && !TclGetString(tempExtObj)[0]) { + TclDecrRefCount(tempExtObj); + tempExtObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (tempDirObj) { + TclDecrRefCount(tempDirObj); + } + if (tempBaseObj) { + TclDecrRefCount(tempBaseObj); + } + if (tempExtObj) { + TclDecrRefCount(tempExtObj); + } + + /* + * Deal with results. + */ + + if (chan == NULL) { + if (nameVarObj) { + TclDecrRefCount(nameObj); + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary file: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + if (nameVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_UnregisterChannel(interp, chan); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); + return TCL_OK; } /* diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7c4a360..5d4702b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclFileName.c,v 1.103 2010/05/19 08:23:09 nijtmans Exp $ */ #include "tclInt.h" @@ -74,9 +72,9 @@ SetResultLength( { Tcl_DStringSetLength(resultPtr, offset); if (extended == 2) { - Tcl_DStringAppend(resultPtr, "//?/UNC/", 8); + TclDStringAppendLiteral(resultPtr, "//?/UNC/"); } else if (extended == 1) { - Tcl_DStringAppend(resultPtr, "//?/", 4); + TclDStringAppendLiteral(resultPtr, "//?/"); } } @@ -133,7 +131,7 @@ ExtractWinRoot( if (path[1] != '/' && path[1] != '\\') { SetResultLength(resultPtr, offset, extended); *typePtr = TCL_PATH_VOLUME_RELATIVE; - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return &path[1]; } host = &path[2]; @@ -163,7 +161,7 @@ ExtractWinRoot( */ *typePtr = TCL_PATH_VOLUME_RELATIVE; - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return &path[2]; } SetResultLength(resultPtr, offset, extended); @@ -182,9 +180,9 @@ ExtractWinRoot( break; } } - Tcl_DStringAppend(resultPtr, "//", 2); + TclDStringAppendLiteral(resultPtr, "//"); Tcl_DStringAppend(resultPtr, host, hlen); - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); Tcl_DStringAppend(resultPtr, share, slen); tail = &share[slen]; @@ -223,7 +221,7 @@ ExtractWinRoot( *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringAppend(resultPtr, path, 2); - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return tail; } @@ -413,25 +411,36 @@ TclpGetNativePathType( * Paths that begin with / are absolute. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - if (*path && (pathLen > 3) && (path[0] == '/') - && (path[1] == '/') && isdigit(UCHAR(path[2]))) { - path += 3; - while (isdigit(UCHAR(*path))) { - path++; + if (path[0] == '/') { + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } - } #endif - if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX code was used. + * We need this addition in case the QNX or Cygwin code was used. */ - *driveNameLengthPtr = (1 + path - origPath); + *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; @@ -447,8 +456,7 @@ TclpGetNativePathType( if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { *driveNameLengthPtr = rootEnd - path; if (driveNameRef != NULL) { - *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + *driveNameRef = TclDStringToObj(&ds); Tcl_IncrRefCount(*driveNameRef); } } @@ -579,8 +587,7 @@ Tcl_SplitPath( * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **) ckalloc((unsigned) - ((((*argcPtr) + 1) * sizeof(char *)) + size)); + *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size); /* * Position p after the last argv pointer and copy the contents of the @@ -636,32 +643,43 @@ SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { int length; - const char *p, *elementStart; + const char *origPath = path, *elementStart; Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - - if ((path[0] == '/') && (path[1] == '/') - && isdigit(UCHAR(path[2]))) { /* INTL: digit */ - path += 3; - while (isdigit(UCHAR(*path))) { /* INTL: digit */ - path++; + if (*path == '/') { + Tcl_Obj *rootElt; + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } - } #endif - - if (path[0] == '/') { - Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1)); - p = path+1; - } else { - p = path; + rootElt = Tcl_NewStringObj(origPath, path - origPath); + Tcl_ListObjAppendElement(NULL, result, rootElt); + while (*path == '/') { + ++path; + } } /* @@ -670,14 +688,14 @@ SplitUnixPath( */ for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; + elementStart = path; + while ((*path != '\0') && (*path != '/')) { + path++; } - length = p - elementStart; + length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -685,7 +703,7 @@ SplitUnixPath( } Tcl_ListObjAppendElement(NULL, result, nextElt); } - if (*p++ == '\0') { + if (*path++ == '\0') { break; } } @@ -727,8 +745,7 @@ SplitWinPath( */ if (p != path) { - Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( - Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); + Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf)); } Tcl_DStringFree(&buf); @@ -790,32 +807,28 @@ Tcl_FSJoinToPath( int objc, /* Number of array elements to join */ Tcl_Obj *const objv[]) /* Path elements to join. */ { - int i; - Tcl_Obj *lobj, *ret; - if (pathPtr == NULL) { - lobj = Tcl_NewListObj(0, NULL); - } else { - lobj = Tcl_NewListObj(1, &pathPtr); + return TclJoinPath(objc, objv); } - - for (i = 0; i<objc;i++) { - Tcl_ListObjAppendElement(NULL, lobj, objv[i]); + if (objc == 0) { + return TclJoinPath(1, &pathPtr); } - ret = Tcl_FSJoinPath(lobj, -1); - - /* - * It is possible that 'ret' is just a member of the list and is therefore - * going to be freed here. Therefore we must adjust the refCount manually. - * (It would be better if we changed the documentation of this function - * and Tcl_FSJoinPath so that the returned object already has a refCount - * for the caller, hence avoiding these subtleties (and code ugliness)). - */ + if (objc == 1) { + Tcl_Obj *pair[2]; - Tcl_IncrRefCount(ret); - Tcl_DecrRefCount(lobj); - ret->refCount--; - return ret; + pair[0] = pathPtr; + pair[1] = objv[0]; + return TclJoinPath(2, pair); + } else { + int elemc = objc + 1; + Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj **)); + + elemv[0] = pathPtr; + memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj **)); + ret = TclJoinPath(elemc, elemv); + ckfree(elemv); + return ret; + } } /* @@ -872,7 +885,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -908,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -1049,7 +1062,7 @@ Tcl_TranslateFileName( } Tcl_DStringInit(bufferPtr); - Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1); + TclDStringAppendObj(bufferPtr, transPtr); Tcl_DecrRefCount(path); Tcl_DecrRefCount(transPtr); @@ -1166,9 +1179,10 @@ DoTildeSubst( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment " + "variable to expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); } return NULL; } @@ -1177,8 +1191,9 @@ DoTildeSubst( } else if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); } return NULL; } @@ -1213,7 +1228,7 @@ Tcl_GlobObjCmd( int index, i, globFlags, length, join, dir, result; char *string; const char *separators; - Tcl_Obj *typePtr, *resultPtr, *look; + Tcl_Obj *typePtr, *look; Tcl_Obj *pathOrDir = NULL; Tcl_DString prefix; static const char *const options[] = { @@ -1261,11 +1276,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-directory\" cannot be used with \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1283,11 +1301,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-path\" cannot be used with \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1298,6 +1319,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1314,9 +1336,11 @@ Tcl_GlobObjCmd( endOfForLoop: if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-tails\" must be used with either " - "\"-directory\" or \"-path\"", NULL); + "\"-directory\" or \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } @@ -1396,7 +1420,7 @@ Tcl_GlobObjCmd( search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { Tcl_DStringAppend(&prefix, search, find-search); - Tcl_DStringAppend(&prefix, "\\", 1); + TclDStringAppendLiteral(&prefix, "\\"); Tcl_DStringAppend(&prefix, find, 1); search = find+1; if (*search == '\0') { @@ -1491,8 +1515,8 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && - (len == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1522,10 +1546,10 @@ Tcl_GlobObjCmd( */ badTypesArg: - TclNewObj(resultPtr); - Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); - Tcl_AppendObjToObj(resultPtr, look); - Tcl_SetObjResult(interp, resultPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument to \"-types\": %s", + Tcl_GetString(look))); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1535,6 +1559,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); join = 0; goto endOfGlob; } @@ -1557,8 +1582,7 @@ Tcl_GlobObjCmd( Tcl_DStringInit(&prefix); } for (i = 0; i < objc; i++) { - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&prefix, string, length); + TclDStringAppendObj(&prefix, objv[i]); if (i != objc -1) { Tcl_DStringAppend(&prefix, separators, 1); } @@ -1574,11 +1598,9 @@ Tcl_GlobObjCmd( for (i = 0; i < objc; i++) { Tcl_DStringInit(&str); if (dir == PATH_GENERAL) { - Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), - Tcl_DStringLength(&prefix)); + TclDStringAppendDString(&str, &prefix); } - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&str, string, length); + TclDStringAppendObj(&str, objv[i]); if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1610,19 +1632,25 @@ Tcl_GlobObjCmd( } if (length == 0) { - Tcl_AppendResult(interp, "no files matched glob pattern", - (join || (objc == 1)) ? " \"" : "s \"", NULL); + Tcl_Obj *errorMsg = + Tcl_ObjPrintf("no files matched glob pattern%s \"", + (join || (objc == 1)) ? "" : "s"); + if (join) { - Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL); + Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); } else { const char *sep = ""; + for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - Tcl_AppendResult(interp, sep, string, NULL); + Tcl_AppendPrintfToObj(errorMsg, "%s%s", + sep, Tcl_GetString(objv[i])); sep = " "; } } - Tcl_AppendResult(interp, "\"", NULL); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", + NULL); result = TCL_ERROR; } } @@ -1745,8 +1773,7 @@ TclGlob( if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); } - pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), - Tcl_DStringLength(&buffer)); + pathPrefix = TclDStringToObj(&buffer); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { @@ -2154,67 +2181,6 @@ DoGlob( } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported. - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add an - * extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2251,13 +2217,17 @@ DoGlob( closeBrace = p; break; } - Tcl_SetResult(interp, "unmatched open-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open-brace in file name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } else if (*p == '}') { - Tcl_SetResult(interp, "unmatched close-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched close-brace in file name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } } @@ -2268,8 +2238,8 @@ DoGlob( if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2318,12 +2288,13 @@ DoGlob( */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2388,6 +2359,7 @@ DoGlob( const char *bytes; int numBytes; Tcl_Obj *fixme, *newObj; + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); @@ -2408,6 +2380,9 @@ DoGlob( */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2420,9 +2395,6 @@ DoGlob( * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); @@ -2437,41 +2409,22 @@ DoGlob( if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) || (*name == '/')) { - Tcl_DStringAppend(&append, "/", 1); + TclDStringAppendLiteral(&append, "/"); } else { - Tcl_DStringAppend(&append, ".", 1); + TclDStringAppendLiteral(&append, "."); } } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); - Tcl_DStringFree(&append); - Tcl_DStringAppend(&append, winbuf, -1); - } -#endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { - Tcl_DStringAppend(&append, "/", 1); + TclDStringAppendLiteral(&append, "/"); } else { - Tcl_DStringAppend(&append, ".", 1); + TclDStringAppendLiteral(&append, "."); } } -#if defined(__CYGWIN__) && !defined(__WIN32__) - DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, char *); - { - char winbuf[MAXPATHLEN+1]; - - cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf); - Tcl_DStringFree(&append); - Tcl_DStringAppend(&append, winbuf, -1); - } -#endif /* __CYGWIN__ && __WIN32__ */ break; } @@ -2480,8 +2433,7 @@ DoGlob( */ if (pathPtr == NULL) { - joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append), - Tcl_DStringLength(&append)); + joinedPtr = TclDStringToObj(&append); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); @@ -2570,7 +2522,7 @@ DoGlob( Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); + return ckalloc(sizeof(Tcl_StatBuf)); } /* diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index b9ca8b9..6be3e03 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclFileSystem.h,v 1.13 2008/07/28 21:31:21 nijtmans Exp $ */ #ifndef _TCLFILESYSTEM @@ -18,45 +16,6 @@ #include "tcl.h" /* - * struct FilesystemRecord -- - * - * A filesystem record is used to keep track of each filesystem currently - * registered with the core, in a linked list. Pointers to these structures - * are also kept by each "path" Tcl_Obj, and we must retain a refCount on the - * number of such references. - */ - -typedef struct FilesystemRecord { - ClientData clientData; /* Client specific data for the new filesystem - * (can be NULL) */ - const Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */ - int fileRefCount; /* How many Tcl_Obj's use this filesystem. */ - struct FilesystemRecord *nextPtr; - /* The next filesystem registered to Tcl, or - * NULL if no more. */ - struct FilesystemRecord *prevPtr; - /* The previous filesystem registered to Tcl, - * or NULL if no more. */ -} FilesystemRecord; - -/* - * This structure holds per-thread private copy of the current directory - * maintained by the global cwdPathPtr. This structure holds per-thread - * private copies of some global data. This way we avoid most of the - * synchronization calls which boosts performance, at cost of having to update - * this information each time the corresponding epoch counter changes. - */ - -typedef struct ThreadSpecificData { - int initialized; - int cwdPathEpoch; - int filesystemEpoch; - Tcl_Obj *cwdPathPtr; - ClientData cwdClientData; - FilesystemRecord *filesystemList; -} ThreadSpecificData; - -/* * The internal TclFS API provides routines for handling and manipulating * paths efficiently, taking direct advantage of the "path" Tcl_Obj type. * @@ -64,31 +23,23 @@ typedef struct ThreadSpecificData { */ MODULE_SCOPE int TclFSCwdPointerEquals(Tcl_Obj **pathPtrPtr); -MODULE_SCOPE int TclFSMakePathFromNormalized(Tcl_Interp *interp, - Tcl_Obj *pathPtr, ClientData clientData); MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, - Tcl_Obj *pathPtr, int startAt, - ClientData *clientDataPtr); + Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); -MODULE_SCOPE Tcl_Obj * TclFSInternalToNormalized( - const Tcl_Filesystem *fromFilesystem, - ClientData clientData, - FilesystemRecord **fsRecPtrPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, - FilesystemRecord *fsRecPtr, - ClientData clientData); + const Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, - Tcl_Obj *pathPtr, ClientData *clientDataPtr); + Tcl_Obj *pathPtr); +MODULE_SCOPE int TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c */ MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem; -MODULE_SCOPE Tcl_ThreadDataKey tclFsDataKey; /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c and diff --git a/generic/tclGet.c b/generic/tclGet.c index 2ff203b..4c19b55 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclGet.c,v 1.22 2008/07/08 17:52:15 dgp Exp $ */ #include "tclInt.h" @@ -55,6 +53,7 @@ Tcl_GetInt( if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } + TclFreeIntRep(&obj); return code; } @@ -98,6 +97,7 @@ Tcl_GetDouble( if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } + TclFreeIntRep(&obj); return code; } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index a27179c..da4c3fd 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclGetDate.y,v 1.45 2010/03/04 23:16:56 nijtmans Exp $ */ %parse-param {DateInfo* info} @@ -1013,10 +1011,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -1024,6 +1024,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -1031,26 +1032,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclHash.c b/generic/tclHash.c index 81f9326..90be511 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclHash.c,v 1.46 2010/08/24 06:17:55 nijtmans Exp $ */ #include "tclInt.h" @@ -37,7 +35,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. @@ -48,7 +46,9 @@ 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. + * 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 @@ -362,7 +362,7 @@ CreateHashEntry( if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); } else { - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry)); + hPtr = ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; hPtr->clientData = 0; } @@ -436,7 +436,7 @@ Tcl_DeleteHashEntry( #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, entryPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); } else { index = PTR2UINT(entryPtr->hash) & tablePtr->mask; } @@ -464,7 +464,7 @@ Tcl_DeleteHashEntry( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(entryPtr); } else { - ckfree((char *) entryPtr); + ckfree(entryPtr); } } @@ -515,7 +515,7 @@ Tcl_DeleteHashTable( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(hPtr); } else { - ckfree((char *) hPtr); + ckfree(hPtr); } hPtr = nextPtr; } @@ -529,7 +529,7 @@ Tcl_DeleteHashTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) tablePtr->buckets); } else { - ckfree((char *) tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -674,7 +674,7 @@ Tcl_HashStats( * Print out the histogram and a few other pieces of information. */ - result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300); + result = ckalloc((NUM_COUNTERS * 60) + 300); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); @@ -723,7 +723,7 @@ AllocArrayEntry( if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } - hPtr = (Tcl_HashEntry *) ckalloc(size); + hPtr = ckalloc(size); for (iPtr1 = array, iPtr2 = hPtr->key.words; count > 0; count--, iPtr1++, iPtr2++) { @@ -829,14 +829,14 @@ AllocStringEntry( { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; - unsigned int size; + unsigned int size, allocsize; - size = sizeof(Tcl_HashEntry) + strlen(string) + 1 - sizeof(hPtr->key); - if (size < sizeof(Tcl_HashEntry)) { - size = sizeof(Tcl_HashEntry); + allocsize = size = strlen(string) + 1; + if (size < sizeof(hPtr->key)) { + allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *) ckalloc(size); - strcpy(hPtr->key.string, string); + hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); + memcpy(hPtr->key.string, string, size); hPtr->clientData = 0; return hPtr; } @@ -1044,8 +1044,8 @@ RebuildTable( tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); } else { - tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) - (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + tablePtr->buckets = + ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { @@ -1065,7 +1065,7 @@ RebuildTable( #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); } else { index = PTR2UINT(hPtr->hash) & tablePtr->mask; } @@ -1102,7 +1102,7 @@ RebuildTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { - ckfree((char *) oldBuckets); + ckfree(oldBuckets); } } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 0d6af52..b10d423 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclHistory.c,v 1.14 2009/12/29 16:58:41 dkf Exp $ */ #include "tclInt.h" @@ -140,7 +138,7 @@ Tcl_RecordAndEvalObj( */ if (histObjsPtr == NULL) { - histObjsPtr = (HistoryObjs *) ckalloc(sizeof(HistoryObjs)); + histObjsPtr = ckalloc(sizeof(HistoryObjs)); TclNewLiteralStringObj(histObjsPtr->historyObj, "::history"); TclNewLiteralStringObj(histObjsPtr->addObj, "add"); Tcl_IncrRefCount(histObjsPtr->historyObj); @@ -220,7 +218,7 @@ DeleteHistoryObjs( TclDecrRefCount(histObjsPtr->historyObj); TclDecrRefCount(histObjsPtr->addObj); - ckfree((char *) histObjsPtr); + ckfree(histObjsPtr); } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index 0ed57d0..715c1ef 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIO.c,v 1.175 2010/03/20 17:49:15 dkf Exp $ */ #include "tclInt.h" @@ -81,7 +79,7 @@ static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); -static int DoRead(Channel *chanPtr, char *srcPtr, int slen); +static int DoRead(Channel *chanPtr, char *srcPtr, int slen, int allowShortReads); static int DoWrite(Channel *chanPtr, const char *src, int srcLen); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); @@ -398,6 +396,19 @@ TclFinalizeIOSubsystem(void) Channel *chanPtr = NULL; /* Iterates over open channels. */ ChannelState *statePtr; /* State of channel stack */ int active = 1; /* Flag == 1 while there's still work to do */ + int doflushnb; + + /* Fetch the pre-TIP#398 compatibility flag */ + { + const char *s; + Tcl_DString ds; + + s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds); + doflushnb = ((s != NULL) && strcmp(s, "0")); + if (s != NULL) { + Tcl_DStringFree(&ds); + } + } /* * Walk all channel state structures known to this thread and close @@ -416,25 +427,37 @@ TclFinalizeIOSubsystem(void) statePtr != NULL; statePtr = statePtr->nextCSPtr) { chanPtr = statePtr->topChanPtr; - if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | - CHANNEL_DEAD)) { + if (GotFlag(statePtr, CHANNEL_DEAD)) { + continue; + } + if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED ) + || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + ResetFlag(statePtr, BG_FLUSH_SCHEDULED); active = 1; break; } } /* - * We've found a live channel. Close it. + * We've found a live (or bg-closing) channel. Close it. */ if (active) { + /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. + * 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". */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); + if (doflushnb) { + /* 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"); + } if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || (chanPtr == (Channel *) tsdPtr->stdoutChannel) || @@ -629,7 +652,7 @@ Tcl_CreateCloseHandler( ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; - cbPtr = (CloseCallback *) ckalloc(sizeof(CloseCallback)); + cbPtr = ckalloc(sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; @@ -673,7 +696,7 @@ Tcl_DeleteCloseHandler( if (cbPrevPtr == NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; } - ckfree((char *) cbPtr); + ckfree(cbPtr); break; } cbPrevPtr = cbPtr; @@ -708,7 +731,7 @@ GetChannelTable( hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + hTblPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); @@ -800,7 +823,7 @@ DeleteChannelTable( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - ckfree((char *) sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } @@ -824,7 +847,7 @@ DeleteChannelTable( } Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); + ckfree(hTblPtr); } /* @@ -856,19 +879,25 @@ CheckForStdChannelsBeingClosed( ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) && tsdPtr->stdinInitialized) { + if (tsdPtr->stdinInitialized + && tsdPtr->stdinChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; } - } else if ((chan == tsdPtr->stdoutChannel) && tsdPtr->stdoutInitialized) { + } else if (tsdPtr->stdoutInitialized + && tsdPtr->stdoutChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; } - } else if ((chan == tsdPtr->stderrChannel) && tsdPtr->stderrInitialized) { + } else if (tsdPtr->stderrInitialized + && tsdPtr->stderrChannel != NULL + && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; @@ -1004,8 +1033,9 @@ Tcl_UnregisterChannel( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp != NULL) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -1240,8 +1270,8 @@ Tcl_GetChannel( hTblPtr = GetChannelTable(interp); hPtr = Tcl_FindHashEntry(hTblPtr, name); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find channel named \"", chanName, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find channel named \"%s\"", chanName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); return NULL; } @@ -1357,8 +1387,8 @@ Tcl_CreateChannel( * assignments to 0/NULL below. */ - chanPtr = (Channel *) ckalloc(sizeof(Channel)); - statePtr = (ChannelState *) ckalloc(sizeof(ChannelState)); + chanPtr = ckalloc(sizeof(Channel)); + statePtr = ckalloc(sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; @@ -1438,7 +1468,7 @@ Tcl_CreateChannel( statePtr->outputStage = NULL; if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc((unsigned) statePtr->bufSize + 2); + statePtr->outputStage = ckalloc(statePtr->bufSize + 2); } /* @@ -1561,8 +1591,9 @@ Tcl_StackChannel( if (statePtr == NULL) { if (interp) { - Tcl_AppendResult(interp, "couldn't find state for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find state for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1582,9 +1613,9 @@ Tcl_StackChannel( if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { if (interp) { - Tcl_AppendResult(interp, - "reading and writing both disallowed for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "reading and writing both disallowed for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1607,8 +1638,9 @@ Tcl_StackChannel( statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; if (interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1649,7 +1681,7 @@ Tcl_StackChannel( statePtr->inQueueTail = NULL; } - chanPtr = (Channel *) ckalloc(sizeof(Channel)); + chanPtr = ckalloc(sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the @@ -1761,9 +1793,9 @@ Tcl_UnstackChannel( */ if (!TclChanCaughtErrorBypass(interp, chan) && interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName((Tcl_Channel) chanPtr))); } return TCL_ERROR; } @@ -2097,12 +2129,9 @@ Tcl_GetChannelHandle( chanPtr = ((Channel *) chan)->state->bottomChanPtr; if (!chanPtr->typePtr->getHandleProc) { - Tcl_Obj *err; - - TclNewLiteralStringObj(err, "channel \""); - Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1); - Tcl_AppendToObj(err, "\" does not support OS handles", -1); - Tcl_SetChannelError(chan, err); + Tcl_SetChannelError(chan, Tcl_ObjPrintf( + "channel \"%s\" does not support OS handles", + Tcl_GetChannelName(chan))); return TCL_ERROR; } result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction, @@ -2145,7 +2174,7 @@ AllocChannelBuffer( int n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; - bufPtr = (ChannelBuffer *) ckalloc((unsigned) n); + bufPtr = ckalloc(n); bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; @@ -2184,7 +2213,7 @@ RecycleBuffer( */ if (mustDiscard) { - ckfree((char *) bufPtr); + ckfree(bufPtr); return; } @@ -2195,7 +2224,7 @@ RecycleBuffer( */ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { - ckfree((char *) bufPtr); + ckfree(bufPtr); return; } @@ -2230,7 +2259,7 @@ RecycleBuffer( * If we reached this code we return the buffer to the OS. */ - ckfree((char *) bufPtr); + ckfree(bufPtr); return; keepBuffer: @@ -2298,8 +2327,8 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { - Tcl_AppendResult(interp, "unable to access channel: invalid channel", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to access channel: invalid channel", -1)); } return 1; } @@ -2360,6 +2389,7 @@ FlushChannel( * of the queued output to the channel. */ + Tcl_Preserve(chanPtr); while (1) { /* * If the queue is empty and there is a ready current buffer, OR if @@ -2389,7 +2419,8 @@ FlushChannel( */ if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - return 0; + errorCode = 0; + goto done; } /* @@ -2441,7 +2472,7 @@ FlushChannel( * it's a tty channel (dup'ed underneath) */ - if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) { SetFlag(statePtr, BG_FLUSH_SCHEDULED); UpdateInterest(chanPtr); } @@ -2512,7 +2543,9 @@ FlushChannel( wroteSome = 1; } - bufPtr->nextRemoved += written; + if (!IsBufferEmpty(bufPtr)) { + bufPtr->nextRemoved += written; + } /* * If this buffer is now empty, recycle it. @@ -2536,7 +2569,7 @@ FlushChannel( if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { if (wroteSome) { - return errorCode; + goto done; } else if (statePtr->outQueueHead == NULL) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); ChanWatch(chanPtr, statePtr->interestMask); @@ -2553,7 +2586,8 @@ FlushChannel( (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { - return CloseChannel(interp, chanPtr, errorCode); + errorCode = CloseChannel(interp, chanPtr, errorCode); + goto done; } /* @@ -2566,8 +2600,12 @@ FlushChannel( (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { - return CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE); + errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE); + goto done; } + + done: + Tcl_Release(chanPtr); return errorCode; } @@ -2621,7 +2659,7 @@ CloseChannel( */ if (statePtr->curOutPtr != NULL) { - ckfree((char *) statePtr->curOutPtr); + ckfree(statePtr->curOutPtr); statePtr->curOutPtr = NULL; } @@ -2679,13 +2717,13 @@ CloseChannel( if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != NULL) { - ckfree((char *) statePtr->channelName); + ckfree(statePtr->channelName); statePtr->channelName = NULL; } Tcl_FreeEncoding(statePtr->encoding); if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); + ckfree(statePtr->outputStage); statePtr->outputStage = NULL; } } @@ -3022,8 +3060,9 @@ Tcl_Close( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -3068,7 +3107,7 @@ Tcl_Close( cbPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr->nextPtr; cbPtr->proc(cbPtr->clientData); - ckfree((char *) cbPtr); + ckfree(cbPtr); } ResetFlag(statePtr, CHANNEL_INCLOSE); @@ -3181,8 +3220,9 @@ Tcl_CloseEx( */ if (!chanPtr->typePtr->close2Proc) { - Tcl_AppendResult(interp, "Half-close of channels not supported by ", - chanPtr->typePtr->typeName, "s", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "half-close of channels not supported by %ss", + chanPtr->typePtr->typeName)); return TCL_ERROR; } @@ -3191,9 +3231,8 @@ Tcl_CloseEx( */ if (chanPtr != statePtr->topChanPtr) { - Tcl_AppendResult(interp, - "Half-close not applicable to stack of transformations", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "half-close not applicable to stack of transformations", -1)); return TCL_ERROR; } @@ -3211,9 +3250,9 @@ Tcl_CloseEx( } else { msg = "write"; } - Tcl_AppendResult(interp, "Half-close of ", msg, - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened or" + " already closed", msg)); return TCL_ERROR; } @@ -3224,8 +3263,9 @@ Tcl_CloseEx( if (statePtr->flags & CHANNEL_INCLOSE) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -3294,10 +3334,11 @@ CloseWrite( * interpreter */ { /* Notes: clear-channel-handlers - write side only ? or keep around, just - * not called */ + * not called. */ /* No close cllbacks are run - channel is still open (read side) */ - ChannelState *statePtr = chanPtr->state; /* State of real IO channel */ + ChannelState *statePtr = chanPtr->state; + /* State of real IO channel. */ int flushcode; int result = 0; @@ -3541,7 +3582,7 @@ Tcl_ClearChannelHandlers( for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) { chNext = chPtr->nextPtr; - ckfree((char *) chPtr); + ckfree(chPtr); } statePtr->chPtr = NULL; @@ -3568,7 +3609,7 @@ Tcl_ClearChannelHandlers( for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); - ckfree((char *) ePtr); + ckfree(ePtr); } statePtr->scriptRecordPtr = NULL; } @@ -4404,14 +4445,12 @@ Tcl_Gets( * for managing the storage. */ { Tcl_Obj *objPtr; - int charsStored, length; - const char *string; + int charsStored; TclNewObj(objPtr); charsStored = Tcl_GetsObj(chan, objPtr); if (charsStored > 0) { - string = TclGetStringFromObj(objPtr, &length); - Tcl_DStringAppend(lineRead, string, length); + TclDStringAppendObj(lineRead, objPtr); } TclDecrRefCount(objPtr); return charsStored; @@ -5447,7 +5486,7 @@ Tcl_Read( return -1; } - return DoRead(chanPtr, dst, bytesToRead); + return DoRead(chanPtr, dst, bytesToRead, 0); } /* @@ -6560,7 +6599,7 @@ DiscardInputQueued( */ if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) { - ckfree((char *) statePtr->saveInBufPtr); + ckfree(statePtr->saveInBufPtr); statePtr->saveInBufPtr = NULL; } } @@ -6653,7 +6692,7 @@ GetInput( if ((bufPtr != NULL) && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { - ckfree((char *) bufPtr); + ckfree(bufPtr); bufPtr = NULL; } @@ -7441,11 +7480,11 @@ Tcl_SetChannelBufferSize( statePtr->bufSize = sz; if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); + ckfree(statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc((unsigned) statePtr->bufSize + 2); + statePtr->outputStage = ckalloc(statePtr->bufSize + 2); } } @@ -7519,11 +7558,12 @@ Tcl_BadChannelOption( const char **argv; int argc, i; Tcl_DString ds; + Tcl_Obj *errObj; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { - Tcl_DStringAppend(&ds, " ", 1); + TclDStringAppendLiteral(&ds, " "); Tcl_DStringAppend(&ds, optionList, -1); } if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), @@ -7531,15 +7571,16 @@ Tcl_BadChannelOption( Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be one of ", NULL); + errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", + optionName); argc--; for (i = 0; i < argc; i++) { - Tcl_AppendResult(interp, "-", argv[i], ", ", NULL); + Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); } - Tcl_AppendResult(interp, "or -", argv[i], NULL); + Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); + Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); - ckfree((char *) argv); + ckfree(argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; @@ -7815,8 +7856,9 @@ Tcl_SetChannelOption( if (statePtr->csPtrR || statePtr->csPtrW) { if (interp) { - Tcl_AppendResult(interp, "unable to set channel options: " - "background copy in progress", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to set channel options: background copy in" + " progress", -1)); } return TCL_ERROR; } @@ -7865,8 +7907,9 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_LINEBUFFERED); SetFlag(statePtr, CHANNEL_UNBUFFERED); } else if (interp) { - Tcl_AppendResult(interp, "bad value for -buffering: " - "must be one of full, line, or none", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -buffering: must be one of" + " full, line, or none", -1)); return TCL_ERROR; } return TCL_OK; @@ -7921,10 +7964,11 @@ Tcl_SetChannelOption( if (inValue & 0x80 || outValue & 0x80) { if (interp) { - Tcl_AppendResult(interp, "bad value for -eofchar: ", - "must be non-NUL ASCII character", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -eofchar: must be non-NUL ASCII" + " character", -1)); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } if (GotFlag(statePtr, TCL_READABLE)) { @@ -7935,15 +7979,15 @@ Tcl_SetChannelOption( } } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," - " one, or two elements", NULL); + " one, or two elements", -1)); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } if (argv != NULL) { - ckfree((char *) argv); + ckfree(argv); } /* @@ -7969,11 +8013,11 @@ Tcl_SetChannelOption( writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL; } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", NULL); + " element list", -1)); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } @@ -7999,12 +8043,11 @@ Tcl_SetChannelOption( translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } @@ -8050,16 +8093,15 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } } - ckfree((char *) argv); + ckfree(argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp, @@ -8093,7 +8135,7 @@ Tcl_SetChannelOption( statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2)); + statePtr->outputStage = ckalloc(statePtr->bufSize + 2); } return TCL_OK; } @@ -8145,7 +8187,7 @@ CleanupChannelHandlers( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - ckfree((char *) sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } @@ -8392,8 +8434,8 @@ UpdateInterest( mask &= ~TCL_EXCEPTION; if (!statePtr->timer) { - statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, - chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc, chanPtr); } } } @@ -8434,7 +8476,8 @@ ChannelTimerProc( * before UpdateInterest gets called by Tcl_NotifyChannel. */ - statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* @@ -8516,7 +8559,7 @@ Tcl_CreateChannelHandler( } } if (chPtr == NULL) { - chPtr = (ChannelHandler *) ckalloc(sizeof(ChannelHandler)); + chPtr = ckalloc(sizeof(ChannelHandler)); chPtr->mask = 0; chPtr->proc = proc; chPtr->clientData = clientData; @@ -8620,7 +8663,7 @@ Tcl_DeleteChannelHandler( } else { prevChPtr->nextPtr = chPtr->nextPtr; } - ckfree((char *) chPtr); + ckfree(chPtr); /* * Recompute the interest list for the channel, so that infinite loops @@ -8679,7 +8722,7 @@ DeleteScriptRecord( TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); - ckfree((char *) esPtr); + ckfree(esPtr); break; } @@ -8728,12 +8771,12 @@ CreateScriptRecord( makeCH = (esPtr == NULL); if (makeCH) { - esPtr = (EventScriptRecord *) ckalloc(sizeof(EventScriptRecord)); + esPtr = ckalloc(sizeof(EventScriptRecord)); } /* * Initialize the structure before calling Tcl_CreateChannelHandler, - * because a reflected channel caling 'chan postevent' aka + * because a reflected channel calling 'chan postevent' aka * 'Tcl_NotifyChannel' in its 'watch'Proc will invoke * 'TclChannelEventScriptInvoker' immediately, and we do not wish it to * see uninitialized memory and crash. See [Bug 2918110]. @@ -8796,6 +8839,7 @@ TclChannelEventScriptInvoker( */ Tcl_Preserve(interp); + Tcl_Preserve(chanPtr); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* @@ -8812,6 +8856,7 @@ TclChannelEventScriptInvoker( } Tcl_BackgroundException(interp, result); } + Tcl_Release(chanPtr); Tcl_Release(interp); } @@ -8850,7 +8895,7 @@ Tcl_FileEventObjCmd( int modeIndex; /* Index of mode argument. */ int mask; static const char *const modeOptions[] = {"readable", "writable", NULL}; - static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; + static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); @@ -8870,8 +8915,8 @@ Tcl_FileEventObjCmd( chanPtr = (Channel *) chan; statePtr = chanPtr->state; if ((statePtr->flags & mask) == 0) { - Tcl_AppendResult(interp, "channel is not ", - (mask == TCL_READABLE) ? "readable" : "writable", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", + (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; } @@ -8915,6 +8960,33 @@ Tcl_FileEventObjCmd( /* *---------------------------------------------------------------------- * + * ZeroTransferTimerProc -- + * + * Timer handler scheduled by TclCopyChannel so that -command is + * called asynchronously even when -size is 0. + * + * Results: + * None. + * + * Side effects: + * Calls CopyData for -command invocation. + * + *---------------------------------------------------------------------- + */ + +static void +ZeroTransferTimerProc( + ClientData clientData) +{ + /* calling CopyData with mask==0 still implies immediate invocation of the + * -command callback, and completion of the fcopy. + */ + CopyData(clientData, 0); +} + +/* + *---------------------------------------------------------------------- + * * TclCopyChannel -- * * This routine copies data from one channel to another, either @@ -8965,15 +9037,15 @@ TclCopyChannel( if (BUSY_STATE(inStatePtr, TCL_READABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(inChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(inChan))); } return TCL_ERROR; } if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(outChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(outChan))); } return TCL_ERROR; } @@ -9015,7 +9087,7 @@ TclCopyChannel( * completed. */ - csPtr = (CopyState *) ckalloc(sizeof(CopyState) + inStatePtr->bufSize); + csPtr = ckalloc(sizeof(CopyState) + inStatePtr->bufSize); csPtr->bufSize = inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; @@ -9033,6 +9105,16 @@ TclCopyChannel( outStatePtr->csPtrW = csPtr; /* + * Special handling of -size 0 async transfers, so that the -command is + * still called asynchronously. + */ + + if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) { + Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr); + return 0; + } + + /* * Start copying data between the channels. */ @@ -9135,7 +9217,8 @@ CopyData( } if (inBinary || sameEncoding) { - size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb); + size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, + !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); @@ -9171,8 +9254,8 @@ CopyData( if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) { break; } - if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) && - !(mask & TCL_READABLE)) { + if (cmdPtr && (!Tcl_Eof(inChan) || (mask == 0)) && + !(mask & TCL_READABLE)) { if (mask & TCL_WRITABLE) { Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr); } @@ -9374,7 +9457,8 @@ static int DoRead( Channel *chanPtr, /* The channel from which to read. */ char *bufPtr, /* Where to store input read. */ - int toRead) /* Maximum number of bytes to read. */ + int toRead, /* Maximum number of bytes to read. */ + int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; /* State info for channel */ @@ -9415,7 +9499,10 @@ DoRead( } goto done; } - } + } else if (allowShortReads) { + copied += copiedNow; + break; + } } ResetFlag(statePtr, CHANNEL_BLOCKED); @@ -9991,7 +10078,7 @@ StopCopy( } inStatePtr->csPtrR = NULL; outStatePtr->csPtrW = NULL; - ckfree((char *) csPtr); + ckfree(csPtr); } /* @@ -10084,8 +10171,9 @@ SetBlockMode( */ if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error setting blocking mode: %s", + Tcl_PosixError(interp))); } } else { /* @@ -10960,7 +11048,7 @@ FixLevelCode( lcn += 2; } - lvn = (Tcl_Obj **) ckalloc(lcn * sizeof(Tcl_Obj *)); + lvn = ckalloc(lcn * sizeof(Tcl_Obj *)); /* * New level/code information is spliced into the first occurence of @@ -11013,7 +11101,7 @@ FixLevelCode( msg = Tcl_NewListObj(j, lvn); - ckfree((char *) lvn); + ckfree(lvn); return msg; } @@ -11160,6 +11248,9 @@ SetChannelFromAny( ChannelState *statePtr; Interp *interpPtr; + if (interp == NULL) { + return TCL_ERROR; + } if (objPtr->typePtr == &tclChannelType) { /* * The channel is valid until any call to DetachChannel occurs. diff --git a/generic/tclIO.h b/generic/tclIO.h index 5ff855f..1e89878 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIO.h,v 1.17 2010/03/20 15:39:46 dkf Exp $ */ /* @@ -65,13 +63,13 @@ typedef struct ChannelBuffer { int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ - char buf[4]; /* Placeholder for real buffer. The real - * buffer occuppies this space + bufSize-4 + char buf[1]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; -#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) +#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf) /* * How much extra space to allocate in buffer to hold bytes from previous @@ -425,6 +423,13 @@ typedef struct GetsState { * appended to objPtr so far, just before the * last call to FilterInputBytes(). */ } GetsState; + +/* + * The length of time to wait between synthetic timer events. Must be zero or + * bad things tend to happen. + */ + +#define SYNTHETIC_EVENT_TIME 0 /* * Local Variables: diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 696b3ac..005713d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIOCmd.c,v 1.69 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" @@ -18,8 +16,8 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* @@ -119,12 +117,12 @@ Tcl_PutsObjCmd( ThreadSpecificData *tsdPtr; switch (objc) { - case 2: /* [puts $x] */ + case 2: /* [puts $x] */ string = objv[1]; newline = 1; break; - case 3: /* [puts -nonewline $x] or [puts $chan $x] */ + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 0; } else { @@ -134,35 +132,30 @@ Tcl_PutsObjCmd( string = objv[2]; break; - case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ + case 4: /* [puts -nonewline $chan $x] or + * [puts $chan $x nonewline] */ + newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; - } else { + break; +#if TCL_MAJOR_VERSION < 9 + } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or - * documented. + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. */ - const char *arg; - int length; - - arg = TclGetStringFromObj(objv[3], &length); - if ((length != 9) - || (strncmp(arg, "nonewline", (size_t) length) != 0)) { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; - } chanObjPtr = objv[1]; string = objv[2]; + break; +#endif } - newline = 0; - break; - - default: - /* [puts] or [puts some bad number of arguments...] */ + /* Fall through */ + default: /* [puts] or + * [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } @@ -181,9 +174,10 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -208,9 +202,8 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -252,9 +245,10 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -267,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -314,9 +308,10 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -327,17 +322,16 @@ Tcl_GetsObjCmd( Tcl_DecrRefCount(linePtr); /* - * TIP #219. Capture error messages put by the driver into the - * bypass area and put them into the regular interpreter result. - * Fall back to the regular message if nothing was found in the - * bypass. + * TIP #219. + * Capture error messages put by the driver into the bypass area + * and put them into the regular interpreter result. Fall back to + * the regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -349,7 +343,6 @@ Tcl_GetsObjCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } @@ -420,33 +413,41 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } - i++; /* Consumed channel name. */ + i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final newline - * should be dropped. + * Compute how many bytes to read. */ toRead = -1; if (i < objc) { - const char *arg; + if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) + || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ - arg = TclGetString(objv[i]); - if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ - if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 } - } else if (strcmp(arg, "nonewline") == 0) { newline = 1; - } else { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; +#endif } } @@ -462,10 +463,9 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -523,7 +523,7 @@ Tcl_SeekObjCmd( static const char *const originOptions[] = { "start", "current", "end", NULL }; - static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; + static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); @@ -552,10 +552,11 @@ Tcl_SeekObjCmd( * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ + if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -646,6 +647,10 @@ Tcl_CloseObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ + static const char *const dirOptions[] = { + "read", "write", NULL + }; + static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); @@ -657,21 +662,17 @@ Tcl_CloseObjCmd( } if (objc == 3) { - int optionIndex, dir; - static const char *const dirOptions[] = { - "read", "write", NULL - }; - static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; + int index, dir; /* * Get direction requested to close, and check syntax. */ if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, - &optionIndex) != TCL_OK) { + &index) != TCL_OK) { return TCL_ERROR; } - dir = dirArray[optionIndex]; + dir = dirArray[index]; /* * Check direction against channel mode. It is an error if we try to @@ -680,10 +681,9 @@ Tcl_CloseObjCmd( */ if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_AppendResult(interp, "Half-close of ", - dirOptions[optionIndex], - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); return TCL_ERROR; } @@ -760,8 +760,7 @@ Tcl_FconfigureObjCmd( int i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { - Tcl_WrongNumArgs(interp, 1, objv, - "channelId ?-option value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?"); return TCL_ERROR; } @@ -872,14 +871,9 @@ Tcl_ExecObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - /* - * This function generates an argv array for the string arguments. It - * starts out with stack-allocated space but uses dynamically-allocated - * storage if needed. - */ - Tcl_Obj *resultPtr; - const char **argv; + const char **argv; /* An array for the string arguments. Stored + * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; int argc, background, i, index, keepNewline, result, skip, length; @@ -937,8 +931,7 @@ Tcl_ExecObjCmd( */ argc = objc - skip; - argv = (const char **) - TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -950,7 +943,7 @@ Tcl_ExecObjCmd( } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : - (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); + ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)); /* * Free the argv array. @@ -986,9 +979,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1057,9 +1050,10 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -1110,11 +1104,13 @@ Tcl_OpenObjCmd( int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); - /* Support legacy octal numbers */ + /* + * Support legacy octal numbers. + */ + if ((permString[scanned] == '0') && (permString[scanned+1] >= '0') && (permString[scanned+1] <= '7')) { - Tcl_Obj *permObj; TclNewLiteralStringObj(permObj, "0o"); @@ -1175,13 +1171,13 @@ Tcl_OpenObjCmd( Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree((char *) cmdArgv); + ckfree(cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1224,7 +1220,7 @@ TcpAcceptCallbacksDeleteProc( acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); + ckfree(hTblPtr); } /* @@ -1261,13 +1257,12 @@ RegisterTcpServerInterpCleanup( Tcl_HashEntry *hPtr; /* Entry for this record. */ int isNew; /* Is the entry new? */ - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + hTblPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); } @@ -1308,8 +1303,7 @@ UnregisterTcpServerInterpCleanupProc( Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { return; } @@ -1347,7 +1341,7 @@ AcceptCallbackProc( char *address, /* Address of client that was accepted. */ int port) /* Port of client that was accepted. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; + AcceptCallback *acceptCallbackPtr = callbackData; /* * Check if the callback is still valid; the interpreter may have gone @@ -1392,8 +1386,8 @@ AcceptCallbackProc( Tcl_Release(script); } else { /* - * The interpreter has been deleted, so there is no useful way to - * utilize the client socket - just close it. + * The interpreter has been deleted, so there is no useful way to use + * the client socket - just close it. */ Tcl_Close(NULL, chan); @@ -1426,7 +1420,7 @@ TcpServerCloseProc( ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; + AcceptCallback *acceptCallbackPtr = callbackData; /* The actual data. */ if (acceptCallbackPtr->interp != NULL) { @@ -1434,7 +1428,7 @@ TcpServerCloseProc( acceptCallbackPtr); } Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); - ckfree((char *) acceptCallbackPtr); + ckfree(acceptCallbackPtr); } /* @@ -1488,8 +1482,8 @@ Tcl_SocketObjCmd( switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } async = 1; @@ -1497,8 +1491,8 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myaddr option", -1)); return TCL_ERROR; } myaddr = TclGetString(objv[a]); @@ -1508,8 +1502,8 @@ Tcl_SocketObjCmd( a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1520,15 +1514,15 @@ Tcl_SocketObjCmd( } case SKT_SERVER: if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -server option", -1)); return TCL_ERROR; } script = TclGetString(objv[a]); @@ -1540,8 +1534,8 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -myport is not valid for servers", -1)); return TCL_ERROR; } } else if (a < objc) { @@ -1570,8 +1564,8 @@ Tcl_SocketObjCmd( } if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) - ckalloc((unsigned) sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = + ckalloc(sizeof(AcceptCallback)); unsigned len = strlen(script) + 1; char *copyScript = ckalloc(len); @@ -1582,7 +1576,7 @@ Tcl_SocketObjCmd( acceptCallbackPtr); if (chan == NULL) { ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); + ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1608,9 +1602,9 @@ Tcl_SocketObjCmd( return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_RegisterChannel(interp, chan); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1660,17 +1654,19 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(objv[2]))); return TCL_ERROR; } @@ -1754,14 +1750,14 @@ ChanPendingObjCmd( switch ((enum options) index) { case PENDING_INPUT: - if ((mode & TCL_READABLE) == 0) { + if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if ((mode & TCL_WRITABLE) == 0) { + if (!(mode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); @@ -1815,8 +1811,8 @@ ChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot truncate to negative length of file", -1)); return TCL_ERROR; } } else { @@ -1826,18 +1822,17 @@ ChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not determine current location in \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1898,6 +1893,39 @@ ChanPipeObjCmd( /* *---------------------------------------------------------------------- * + * TclChannelNamesCmd -- + * + * This function is invoked to process the "chan names" and "file + * channels" Tcl commands. See the user documentation for details on + * what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChannelNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 1) ? NULL : TclGetString(objv[1]))); +} + +/* + *---------------------------------------------------------------------- + * * TclInitChanCmd -- * * This function is invoked to create the "chan" Tcl command. See the @@ -1924,29 +1952,29 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL}, - {"close", Tcl_CloseObjCmd, NULL, NULL, NULL}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL}, - {"create", TclChanCreateObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, NULL, NULL, NULL}, - {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL}, - {"pending", ChanPendingObjCmd, NULL, NULL, NULL}, /* TIP #287 */ - {"pop", TclChanPopObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"push", TclChanPushObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL}, - {"pipe", ChanPipeObjCmd, NULL, NULL, NULL}, /* TIP #304 */ - {"tell", Tcl_TellObjCmd, NULL, NULL, NULL}, - {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL} + {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */ + {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0}, + {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */ + {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, NULL, 0} }; static const char *const extras[] = { "configure", "::fconfigure", - "names", "::file channels", NULL }; Tcl_Command ensemble; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 1935a3d..bfe6a10 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * CVS: $Id: tclIOGT.c,v 1.22 2010/01/10 22:58:40 nijtmans Exp $ */ #include "tclInt.h" @@ -261,7 +259,7 @@ TclChannelTransform( * regime of the underlying channel and to use the same for us too. */ - dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); + dataPtr = ckalloc(sizeof(TransformChannelData)); Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); @@ -286,11 +284,11 @@ TclChannelTransform( dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr, mode, chan); if (dataPtr->self == NULL) { - Tcl_AppendResult(interp, "\nfailed to stack channel \"", - Tcl_GetChannelName(chan), "\"", NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), + "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); - ckfree((char *) dataPtr); + ckfree(dataPtr); return TCL_ERROR; } @@ -563,7 +561,7 @@ TransformCloseProc( ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - ckfree((char *) dataPtr); + ckfree(dataPtr); return TCL_OK; } @@ -1229,7 +1227,7 @@ ResultClear( r->used = 0; if (r->allocated) { - ckfree((char *) r->buf); + ckfree(r->buf); r->buf = NULL; r->allocated = 0; } @@ -1373,10 +1371,10 @@ ResultAdd( if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = UCHARP(ckalloc(r->allocated)); + r->buf = ckalloc(r->allocated); } else { r->allocated += toWrite + INCREMENT; - r->buf = UCHARP(ckrealloc((char *) r->buf, r->allocated)); + r->buf = ckrealloc(r->buf, r->allocated); } } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index b8c248b..cb0282a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -14,8 +14,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIORChan.c,v 1.50 2010/08/04 16:49:02 andreas_kupries Exp $ */ #include "tclInt.h" @@ -41,6 +39,9 @@ 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 +static void ReflectThread(ClientData clientData, int action); +#endif static Tcl_WideInt ReflectSeekWide(ClientData clientData, Tcl_WideInt offset, int mode, int *errorCodePtr); static int ReflectSeek(ClientData clientData, long offset, @@ -73,7 +74,11 @@ 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 + ReflectThread, /* thread action, tracking owner */ +#else NULL, /* thread action */ +#endif NULL /* truncate */ }; @@ -91,7 +96,8 @@ typedef struct { * command is gone. */ #ifdef TCL_THREADS - Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ + Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif /* See [==] as well. @@ -123,6 +129,9 @@ typedef struct { int interest; /* Mask of events the channel is interested * in. */ + int dead; /* Boolean signal that some operations + * should no longer be attempted. */ + /* * Note regarding the usage of timers. * @@ -389,31 +398,31 @@ TCL_DECLARE_MUTEX(rcForwardMutex) * leak resources when threads go away. */ -static void ForwardOpToOwnerThread(ReflectedChannel *rcPtr, +static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); @@ -441,6 +450,7 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj); static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); +static void FreeReflectedChannelArgs(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, const char *method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); @@ -607,11 +617,9 @@ TclChanCreateObjCmd( */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); - Tcl_AppendObjToObj(err, resObj); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned non-list: %s", + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -635,42 +643,37 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" does not support all required methods", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" does not support all required methods", + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"read\" method", + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"write\" method", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", + Tcl_GetString(cmdObj))); goto error; } @@ -689,8 +692,7 @@ TclChanCreateObjCmd( * as the actual channel type. */ - Tcl_ChannelType *clonePtr = (Tcl_ChannelType *) - ckalloc(sizeof(Tcl_ChannelType)); + Tcl_ChannelType *clonePtr = ckalloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); @@ -737,7 +739,8 @@ TclChanCreateObjCmd( * Return handle as result of command. */ - Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(chanPtr->state->channelName, -1)); return TCL_OK; error: @@ -771,6 +774,50 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ +typedef struct ReflectEvent { + Tcl_Event header; + ReflectedChannel *rcPtr; + int events; +} ReflectEvent; + +static int +ReflectEventRun( + Tcl_Event *ev, + int flags) +{ + /* OWNER thread + * + * Note: When the channel is closed any pending events of this type are + * deleted. See ReflectClose() for the Tcl_DeleteEvents() calls + * accomplishing that. + */ + + ReflectEvent *e = (ReflectEvent *) ev; + + Tcl_NotifyChannel(e->rcPtr->chan, e->events); + return 1; +} + +static int +ReflectEventDelete( + Tcl_Event *ev, + ClientData cd) +{ + /* OWNER thread + * + * Invoked by DeleteThreadReflectedChannelMap() and ReflectClose(). The + * latter ensures that no pending events of this type are run on an + * invalid channel. + */ + + ReflectEvent *e = (ReflectEvent *) ev; + + if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { + return 0; + } + return 1; +} + int TclChanPostEventObjCmd( ClientData clientData, @@ -779,6 +826,8 @@ TclChanPostEventObjCmd( Tcl_Obj *const *objv) { /* + * Ensure -> HANDLER thread + * * Syntax: chan postevent CHANNEL EVENTSPEC * [0] [1] [2] [3] * @@ -821,8 +870,8 @@ TclChanPostEventObjCmd( hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find reflected channel named \"", - chanId, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find reflected channel named \"%s\"", chanId)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } @@ -879,8 +928,9 @@ TclChanPostEventObjCmd( */ if (events & ~rcPtr->interest) { - Tcl_AppendResult(interp, "tried to post events channel \"", chanId, - "\" is not interested in", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "tried to post events channel \"%s\" is not interested in", + chanId)); return TCL_ERROR; } @@ -888,7 +938,44 @@ TclChanPostEventObjCmd( * We have the channel and the events to post. */ - Tcl_NotifyChannel(chan, events); +#ifdef TCL_THREADS + if (rcPtr->owner == rcPtr->thread) { +#endif + Tcl_NotifyChannel(chan, events); +#ifdef TCL_THREADS + } else { + ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); + + ev->header.proc = ReflectEventRun; + ev->events = events; + ev->rcPtr = rcPtr; + + /* + * We are not preserving the structure here. When the channel is + * closed any pending events are deleted, see ReflectClose(), and + * ReflectEventDelete(). Trying to preserve and later release when the + * event is run may generate a situation where the channel structure + * is deleted but not our structure, crashing in + * FreeReflectedChannel(). + * + * Force creation of the RCM, for proper cleanup on thread teardown. + * The teardown of unprocessed events is currently coupled to the + * thread reflected channel map + */ + + (void) GetThreadReflectedChannelMap(); + + /* 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 ?) + * XXX Actually, in that case the channel should be dead also ! + */ + + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(rcPtr->owner); + } +#endif /* * Squash interp results left by the event script. @@ -1073,22 +1160,22 @@ ReflectClose( if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedChannel is done in the forwarded operation!, in - * the other thread. rcPtr here is gone! - */ + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { FreeReceivedError(&p); } - return EOK; } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1100,7 +1187,7 @@ ReflectClose( */ if (rcPtr->methods == 0) { - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1112,13 +1199,16 @@ ReflectClose( if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedChannel is done in the forwarded operation!, in the - * other thread. rcPtr here is gone! - */ + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1146,7 +1236,7 @@ ReflectClose( * the per-interp DeleteReflectedChannelMap exit-handler. */ - if (rcPtr->interp) { + if (!rcPtr->dead) { rcmPtr = GetReflectedChannelMap(rcPtr->interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); @@ -1163,7 +1253,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } #endif @@ -1222,7 +1312,7 @@ ReflectInput( p.input.buf = buf; p.input.toRead = toRead; - ForwardOpToOwnerThread(rcPtr, ForwardedInput, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { @@ -1271,7 +1361,7 @@ ReflectInput( *errorCodePtr = EOK; if (bytec > 0) { - memcpy(buf, bytev, (size_t)bytec); + memcpy(buf, bytev, (size_t) bytec); } stop: @@ -1337,7 +1427,7 @@ ReflectOutput( p.output.buf = buf; p.output.toWrite = toWrite; - ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { @@ -1453,7 +1543,7 @@ ReflectSeekWide( p.seek.seekMode = seekMode; p.seek.offset = offset; - ForwardOpToOwnerThread(rcPtr, ForwardedSeek, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedSeek, &p); if (p.base.code != TCL_OK) { PassReceivedError(rcPtr->chan, &p); @@ -1472,12 +1562,13 @@ ReflectSeekWide( Tcl_Preserve(rcPtr); offObj = Tcl_NewWideIntObj(offset); - baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : - ((seekMode == SEEK_CUR) ? "current" : "end"), -1); + baseObj = Tcl_NewStringObj( + (seekMode == SEEK_SET) ? "start" : + (seekMode == SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1577,7 +1668,7 @@ ReflectWatch( ForwardParam p; p.watch.mask = mask; - ForwardOpToOwnerThread(rcPtr, ForwardedWatch, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedWatch, &p); /* * Any failure from the forward is ignored. We have no place to put @@ -1635,7 +1726,7 @@ ReflectBlock( p.block.nonblocking = nonblocking; - ForwardOpToOwnerThread(rcPtr, ForwardedBlock, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedBlock, &p); if (p.base.code != TCL_OK) { PassReceivedError(rcPtr->chan, &p); @@ -1665,6 +1756,44 @@ ReflectBlock( return errorNum; } +#ifdef TCL_THREADS +/* + *---------------------------------------------------------------------- + * + * ReflectThread -- + * + * This function is invoked to tell the channel about thread movements. + * + * Results: + * None. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static void +ReflectThread( + ClientData clientData, + int action) +{ + ReflectedChannel *rcPtr = clientData; + + switch (action) { + case TCL_CHANNEL_THREAD_INSERT: + rcPtr->owner = Tcl_GetCurrentThread(); + break; + case TCL_CHANNEL_THREAD_REMOVE: + rcPtr->owner = NULL; + break; + default: + Tcl_Panic("Unknown thread action code."); + break; + } +} + +#endif /* *---------------------------------------------------------------------- * @@ -1704,7 +1833,7 @@ ReflectSetOption( p.setOpt.name = optionName; p.setOpt.value = newValue; - ForwardOpToOwnerThread(rcPtr, ForwardedSetOpt, &p); + ForwardOpToHandlerThread(rcPtr, ForwardedSetOpt, &p); if (p.base.code != TCL_OK) { Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); @@ -1790,7 +1919,7 @@ ReflectGetOption( opcode = ForwardedGetOpt; } - ForwardOpToOwnerThread(rcPtr, opcode, &p); + ForwardOpToHandlerThread(rcPtr, opcode, &p); if (p.base.code != TCL_OK) { Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); @@ -1834,7 +1963,7 @@ ReflectGetOption( */ if (optionObj != NULL) { - Tcl_DStringAppend(dsPtr, TclGetString(resObj), -1); + TclDStringAppendObj(dsPtr, resObj); goto ok; } @@ -1869,7 +1998,7 @@ ReflectGetOption( const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { - Tcl_DStringAppend(dsPtr, " ", 1); + TclDStringAppendLiteral(dsPtr, " "); Tcl_DStringAppend(dsPtr, str, len); } goto ok; @@ -1933,7 +2062,8 @@ EncodeEventMask( } if (listc < 1) { - Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s list: is empty", objName)); return TCL_ERROR; } @@ -2032,7 +2162,7 @@ NewReflectedChannel( int i, listc; Tcl_Obj **listv; - rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel)); + rcPtr = ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ /* rcPtr->methods: Assigned by caller. Dummy data here. */ @@ -2040,6 +2170,7 @@ NewReflectedChannel( rcPtr->chan = NULL; rcPtr->methods = 0; rcPtr->interp = interp; + rcPtr->dead = 0; #ifdef TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif @@ -2065,7 +2196,7 @@ NewReflectedChannel( */ rcPtr->argc = listc + 2; - rcPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4)); + rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4)); /* * Duplicate object references. @@ -2140,21 +2271,14 @@ NextHandle(void) } static void -FreeReflectedChannel( +FreeReflectedChannelArgs( ReflectedChannel *rcPtr) { - Channel *chanPtr = (Channel *) rcPtr->chan; - int i, n; - - if (chanPtr->typePtr != &tclRChannelType) { - /* - * Delete a cloned ChannelType structure. - */ + int i, n = rcPtr->argc - 2; - ckfree((char *) chanPtr->typePtr); + if (n < 0) { + return; } - - n = rcPtr->argc - 2; for (i=0; i<n; i++) { Tcl_DecrRefCount(rcPtr->argv[i]); } @@ -2165,8 +2289,28 @@ FreeReflectedChannel( Tcl_DecrRefCount(rcPtr->argv[n+1]); - ckfree((char *) rcPtr->argv); - ckfree((char *) rcPtr); + rcPtr->argc = 1; +} + +static void +FreeReflectedChannel( + ReflectedChannel *rcPtr) +{ + Channel *chanPtr = (Channel *) rcPtr->chan; + + if (chanPtr->typePtr != &tclRChannelType) { + /* + * Delete a cloned ChannelType structure. + */ + + ckfree(chanPtr->typePtr); + chanPtr->typePtr = NULL; + } + + FreeReflectedChannelArgs(rcPtr); + + ckfree(rcPtr->argv); + ckfree(rcPtr); } /* @@ -2207,7 +2351,7 @@ InvokeTclMethod( int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ - if (!rcPtr->interp) { + if (rcPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. @@ -2371,7 +2515,7 @@ ErrnoReturn( int code; Tcl_InterpState sr; /* State of handler interp */ - if (!rcPtr->interp) { + if (rcPtr->dead) { return 0; } @@ -2383,7 +2527,7 @@ ErrnoReturn( if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { - code = - EAGAIN; + code = -EAGAIN; } else { code = 0; } @@ -2417,7 +2561,7 @@ GetReflectedChannelMap( ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL); if (rcmPtr == NULL) { - rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap)); + rcmPtr = ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RCMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr); @@ -2480,11 +2624,11 @@ DeleteReflectedChannelMap( chan = Tcl_GetHashValue(hPtr); rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->interp = NULL; + rcPtr->dead = 1; Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); - ckfree((char *) &rcmPtr->map); + ckfree(&rcmPtr->map); #ifdef TCL_THREADS /* @@ -2516,6 +2660,11 @@ DeleteReflectedChannelMap( */ evPtr = resultPtr->evPtr; + + /* Basic crash safety until this routine can get revised [3411310] */ + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2526,6 +2675,7 @@ DeleteReflectedChannelMap( Tcl_ConditionNotify(&resultPtr->done); } + Tcl_MutexUnlock(&rcForwardMutex); /* * Get the map of all channels handled by the current thread. This is a @@ -2549,10 +2699,10 @@ DeleteReflectedChannelMap( continue; } + rcPtr->dead = 1; + FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } - - Tcl_MutexUnlock(&rcForwardMutex); #endif } @@ -2580,8 +2730,7 @@ GetThreadReflectedChannelMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rcmPtr) { - tsdPtr->rcmPtr = (ReflectedChannelMap *) - ckalloc(sizeof(ReflectedChannelMap)); + tsdPtr->rcmPtr = ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL); } @@ -2651,6 +2800,11 @@ DeleteThreadReflectedChannelMap( */ evPtr = resultPtr->evPtr; + + /* Basic crash safety until this routine can get revised [3411310] */ + if (evPtr == NULL ) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2661,6 +2815,16 @@ DeleteThreadReflectedChannelMap( Tcl_ConditionNotify(&resultPtr->done); } + Tcl_MutexUnlock(&rcForwardMutex); + + /* + * Run over the event queue of this thread and remove all ReflectEvent's + * still pending. These are inbound events for reflected channels this + * thread owns but doesn't handle. The inverse of the channel map + * actually. + */ + + Tcl_DeleteEvents(ReflectEventDelete, NULL); /* * Get the map of all channels handled by the current thread. This is a @@ -2675,23 +2839,27 @@ DeleteThreadReflectedChannelMap( Tcl_Channel chan = Tcl_GetHashValue(hPtr); ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->interp = NULL; + rcPtr->dead = 1; + FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } - - Tcl_MutexUnlock(&rcForwardMutex); + ckfree(rcmPtr); } static void -ForwardOpToOwnerThread( +ForwardOpToHandlerThread( ReflectedChannel *rcPtr, /* Channel instance */ ForwardedOperation op, /* Forwarded driver operation */ const void *param) /* Arguments */ { + /* + * Core of the communication from OWNER to HANDLER thread. + * The receiver is ForwardProc() below. + */ + Tcl_ThreadId dst = rcPtr->thread; ForwardingEvent *evPtr; ForwardingResult *resultPtr; - int result; /* * We gather the lock early. This allows us to check the liveness of the @@ -2700,7 +2868,7 @@ ForwardOpToOwnerThread( Tcl_MutexLock(&rcForwardMutex); - if (rcPtr->interp == NULL) { + if (rcPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. Do not forget to unlock the mutex on this path. @@ -2715,8 +2883,8 @@ ForwardOpToOwnerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult)); + evPtr = ckalloc(sizeof(ForwardingEvent)); + resultPtr = ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -2741,7 +2909,7 @@ ForwardOpToOwnerThread( /* * Ensure cleanup of the event if the origin thread exits while this event * is pending or in progress. Exit of the destination thread is handled by - * DeleteThreadReflectionChannelMap(), this is set up by + * DeleteThreadReflectedChannelMap(), this is set up by * GetThreadReflectedChannelMap(). This is what we use the 'forwardList' * (see above) for. */ @@ -2756,7 +2924,7 @@ ForwardOpToOwnerThread( Tcl_ThreadAlert(dst); /* - * (*) Block until the other thread has either processed the transfer or + * (*) Block until the handler thread has either processed the transfer or * rejected it. */ @@ -2795,8 +2963,7 @@ ForwardOpToOwnerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - result = resultPtr->result; - ckfree((char *) resultPtr); + ckfree(resultPtr); } static int @@ -2805,6 +2972,11 @@ ForwardProc( int mask) { /* + * HANDLER thread. + + * The receiver part for the operations coming from the OWNER thread. + * See ForwardOpToHandlerThread() for the transmitter. + * * Notes regarding access to the referenced data. * * In principle the data belongs to the originating thread (see @@ -2823,9 +2995,8 @@ ForwardProc( Tcl_Interp *interp = rcPtr->interp; ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedChannelMap *rcmPtr; - /* Map of reflected channels with handlers in - * this interp. */ + ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in + * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ /* @@ -2868,15 +3039,15 @@ ForwardProc( rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + FreeReflectedChannelArgs(rcPtr); break; case ForwardedInput: { @@ -2908,7 +3079,7 @@ ForwardProc( paramPtr->input.toRead = -1; } else { if (bytec > 0) { - memcpy(paramPtr->input.buf, bytev, (size_t)bytec); + memcpy(paramPtr->input.buf, bytev, (size_t) bytec); } paramPtr->input.toRead = bytec; } @@ -2920,7 +3091,7 @@ ForwardProc( case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); + paramPtr->output.buf, paramPtr->output.toWrite); Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); @@ -2941,7 +3112,9 @@ ForwardProc( int written; if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) { - ForwardSetObjError(paramPtr, MarshallError(interp)); + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); paramPtr->output.toWrite = -1; } else if (written==0 || paramPtr->output.toWrite<written) { ForwardSetStaticError(paramPtr, msg_write_toomuch); @@ -2958,8 +3131,8 @@ ForwardProc( case ForwardedSeek: { Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); Tcl_Obj *baseObj = Tcl_NewStringObj( - (paramPtr->seek.seekMode==SEEK_SET) ? "start" : - (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); @@ -2984,7 +3157,9 @@ ForwardProc( paramPtr->seek.offset = newLoc; } } else { - ForwardSetObjError(paramPtr, MarshallError(interp)); + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } } @@ -3007,11 +3182,11 @@ ForwardProc( case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); + Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3027,7 +3202,7 @@ ForwardProc( Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3042,14 +3217,13 @@ ForwardProc( */ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { - Tcl_DStringAppend(paramPtr->getOpt.value, - TclGetString(resObj), -1); + TclDStringAppendObj(paramPtr->getOpt.value, resObj); } Tcl_Release(rcPtr); Tcl_DecrRefCount(optionObj); @@ -3074,8 +3248,10 @@ ForwardProc( Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, resObj, &listc, - &listv) != TCL_OK) { - ForwardSetObjError(paramPtr, MarshallError(interp)); + &listv) != TCL_OK) { + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. @@ -3092,7 +3268,7 @@ ForwardProc( const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { - Tcl_DStringAppend(paramPtr->getOpt.value, " ", 1); + TclDStringAppendLiteral(paramPtr->getOpt.value, " "); Tcl_DStringAppend(paramPtr->getOpt.value, str, len); } } @@ -3191,7 +3367,7 @@ ForwardSetObjError( const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } #endif diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 54b73c0..2b9efb9 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -14,8 +14,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIORTrans.c,v 1.18 2010/08/04 16:49:02 andreas_kupries Exp $ */ #include "tclInt.h" @@ -163,6 +161,8 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int dead; /* Boolean signal that some operations + * should no longer be attempted. */ ResultBuffer result; } ReflectedTransform; @@ -363,33 +363,43 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ - } + do { \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } \ + } while (0) #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ - FreeReceivedError(p) + do { \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ + FreeReceivedError(p); \ + } while (0) #define PassReceivedError(c,p) \ - Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ - FreeReceivedError(p) + do { \ + Tcl_SetChannelError((c), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + FreeReceivedError(p); \ + } while (0) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); - static ReflectedTransformMap * GetThreadReflectedTransformMap(void); -static void DeleteThreadReflectedTransformMap(ClientData clientData); - +static void DeleteThreadReflectedTransformMap( + ClientData clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ @@ -409,6 +419,7 @@ static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp, Tcl_Channel parentChan); static Tcl_Obj * NextHandle(void); static void FreeReflectedTransform(ReflectedTransform *rtPtr); +static void FreeReflectedTransformArgs(ReflectedTransform *rtPtr); static int InvokeTclMethod(ReflectedTransform *rtPtr, const char *method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); @@ -438,13 +449,6 @@ static const char *msg_dstlost = */ /* - * Number of milliseconds to wait before firing an event to try to flush out - * information waiting in buffers (fileevent support). - */ - -#define FLUSH_DELAY (5) - -/* * Helper functions encapsulating some of the thread forwarding to make the * control flow in callers easier. */ @@ -519,7 +523,6 @@ TclChanPushObjCmd( int result; /* Result code for 'initialize' */ Tcl_Obj *resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ - Tcl_Obj *err; /* Error message */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers * in this interp. */ @@ -603,11 +606,9 @@ TclChanPushObjCmd( */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); - Tcl_AppendObjToObj(err, resObj); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned non-list: %s", + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -616,11 +617,10 @@ TclChanPushObjCmd( while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned ", -1); - Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned %s", + Tcl_GetString(cmdObj), + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } @@ -631,10 +631,9 @@ TclChanPushObjCmd( Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" does not support all required methods", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" does not support all required methods", + Tcl_GetString(cmdObj))); goto error; } @@ -654,10 +653,9 @@ TclChanPushObjCmd( } if (!mode) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" makes the channel inacessible", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" makes the channel inaccessible", + Tcl_GetString(cmdObj))); goto error; } @@ -666,18 +664,16 @@ TclChanPushObjCmd( */ if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"drain\" but not \"read\"", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"flush\" but not \"write\"", + Tcl_GetString(cmdObj))); goto error; } @@ -707,13 +703,14 @@ TclChanPushObjCmd( rtmPtr = GetThreadReflectedTransformMap(); hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); -#endif +#endif /* TCL_THREADS */ /* * Return the channel as the result of the command. */ - Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetChannelName(rtPtr->chan), -1)); return TCL_OK; error: @@ -722,7 +719,7 @@ TclChanPushObjCmd( * structure. */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return TCL_ERROR; #undef CHAN @@ -889,7 +886,8 @@ ReflectClose( Tcl_Interp *interp) { ReflectedTransform *rtPtr = clientData; - int result; /* Result code for 'close' */ + int errorCode, errorCodeSet = 0; + int result = TCL_OK; /* Result code for 'close' */ Tcl_Obj *resObj; /* Result data for 'close' */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers @@ -920,19 +918,13 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedTransform is done in the forwarded operation!, in - * the other thread. rtPtr here is gone! - */ - if (result != TCL_OK) { FreeReceivedError(&p); } - return EOK; } -#endif +#endif /* TCL_THREADS */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return EOK; } @@ -945,18 +937,30 @@ ReflectClose( */ if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { - int errorCode; - if (!TransformDrain(rtPtr, &errorCode)) { - return errorCode; +#ifdef TCL_THREADS + if (rtPtr->thread != Tcl_GetCurrentThread()) { + Tcl_EventuallyFree(rtPtr, + (Tcl_FreeProc *) FreeReflectedTransform); + return errorCode; + } +#endif /* TCL_THREADS */ + errorCodeSet = 1; + goto cleanup; } } if (HAS(rtPtr->methods, METH_FLUSH)) { - int errorCode; - if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { - return errorCode; +#ifdef TCL_THREADS + if (rtPtr->thread != Tcl_GetCurrentThread()) { + Tcl_EventuallyFree(rtPtr, + (Tcl_FreeProc *) FreeReflectedTransform); + return errorCode; + } +#endif /* TCL_THREADS */ + errorCodeSet = 1; + goto cleanup; } } @@ -971,10 +975,7 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedTransform is done in the forwarded operation!, in the - * other thread. rtPtr here is gone! - */ + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -982,7 +983,7 @@ ReflectClose( } return EOK; } -#endif +#endif /* TCL_THREADS */ /* * Do the actual invokation of "finalize" now; we're in the right thread. @@ -996,6 +997,8 @@ ReflectClose( Tcl_DecrRefCount(resObj); /* Remove reference we held from the * invoke. */ + cleanup: + /* * Remove the transform from the map before releasing the memory, to * prevent future accesses from finding and dereferencing a dangling @@ -1009,30 +1012,30 @@ ReflectClose( * the per-interp DeleteReflectedTransformMap exit-handler. */ - if (rtPtr->interp) { + if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } - } - /* - * In a threaded interpreter we manage a per-thread map as well, to allow - * us to survive if the script level pulls the rug out under a channel by - * deleting the owning thread. - */ + /* + * In a threaded interpreter we manage a per-thread map as well, + * to allow us to survive if the script level pulls the rug out + * under a channel by deleting the owning thread. + */ #ifdef TCL_THREADS - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } +#endif /* TCL_THREADS */ } -#endif Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); - return (result == TCL_OK) ? EOK : EINVAL; + return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); } /* @@ -1229,7 +1232,7 @@ ReflectInput( * * ReflectOutput -- * - * This function is invoked when data is writen to the channel. + * This function is invoked when data is written to the channel. * * Results: * The number of bytes actually written. @@ -1354,7 +1357,7 @@ ReflectSeekWide( * transformation. */ - if ((rtPtr->methods & FLAG(METH_CLEAR))) { + if (rtPtr->methods & FLAG(METH_CLEAR)) { TransformClear(rtPtr); } @@ -1753,7 +1756,7 @@ NewReflectedTransform( Tcl_Obj **listv; int i; - rtPtr = (ReflectedTransform *) ckalloc(sizeof(ReflectedTransform)); + rtPtr = ckalloc(sizeof(ReflectedTransform)); /* rtPtr->chan: Assigned by caller. Dummy data here. */ /* rtPtr->methods: Assigned by caller. Dummy data here. */ @@ -1772,6 +1775,7 @@ NewReflectedTransform( rtPtr->readIsDrained = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); + rtPtr->dead = 0; /* * Query parent for current blocking mode. @@ -1798,7 +1802,7 @@ NewReflectedTransform( */ rtPtr->argc = listc + 2; - rtPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4)); + rtPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4)); /* * Duplicate object references. @@ -1872,18 +1876,18 @@ NextHandle(void) } static void -FreeReflectedTransform( +FreeReflectedTransformArgs( ReflectedTransform *rtPtr) { - int i, n; + int i, n = rtPtr->argc - 2; - TimerKill(rtPtr); - ResultClear(&rtPtr->result); + if (n < 0) { + return; + } Tcl_DecrRefCount(rtPtr->handle); rtPtr->handle = NULL; - n = rtPtr->argc - 2; for (i=0; i<n; i++) { Tcl_DecrRefCount(rtPtr->argv[i]); } @@ -1894,8 +1898,20 @@ FreeReflectedTransform( */ Tcl_DecrRefCount(rtPtr->argv[n+1]); - ckfree((char*) rtPtr->argv); - ckfree((char*) rtPtr); + rtPtr->argc = 1; +} + +static void +FreeReflectedTransform( + ReflectedTransform *rtPtr) +{ + TimerKill(rtPtr); + ResultClear(&rtPtr->result); + + FreeReflectedTransformArgs(rtPtr); + + ckfree(rtPtr->argv); + ckfree(rtPtr); } /* @@ -1939,7 +1955,7 @@ InvokeTclMethod( int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ - if (!rtPtr->interp) { + if (rtPtr->dead) { /* * The transform is marked as dead. Bail out immediately, with an * appropriate error. @@ -2092,8 +2108,7 @@ GetReflectedTransformMap( ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL); if (rtmPtr == NULL) { - rtmPtr = (ReflectedTransformMap *) - ckalloc(sizeof(ReflectedTransformMap)); + rtmPtr = ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RTMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); @@ -2134,7 +2149,7 @@ DeleteReflectedTransformMap( ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; -#endif +#endif /* TCL_THREADS */ /* * Delete all entries. The channels may have been closed already, or will @@ -2153,11 +2168,12 @@ DeleteReflectedTransformMap( hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { rtPtr = Tcl_GetHashValue(hPtr); - rtPtr->interp = NULL; + + rtPtr->dead = 1; Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); - ckfree((char *) &rtmPtr->map); + ckfree(&rtmPtr->map); #ifdef TCL_THREADS /* @@ -2165,6 +2181,32 @@ DeleteReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels and remove all which were handled by this + * interpreter. They have already been marked as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + rtPtr = Tcl_GetHashValue(hPtr); + + if (rtPtr->interp != interp) { + /* + * Ignore entries for other interpreters. + */ + + continue; + } + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + + /* * Go through the list of pending results and cancel all whose events were * destined for this interpreter. While this is in progress we block any * other access to the list of pending results. @@ -2198,33 +2240,8 @@ DeleteReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } - - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels and remove all which were handled by this - * interpreter. They have already been marked as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - rtPtr = Tcl_GetHashValue(hPtr); - - if (rtPtr->interp != interp) { - /* - * Ignore entries for other interpreters. - */ - - continue; - } - - Tcl_DeleteHashEntry(hPtr); - } - Tcl_MutexUnlock(&rtForwardMutex); -#endif +#endif /* TCL_THREADS */ } #ifdef TCL_THREADS @@ -2251,8 +2268,7 @@ GetThreadReflectedTransformMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rtmPtr) { - tsdPtr->rtmPtr = (ReflectedTransformMap *) - ckalloc(sizeof(ReflectedTransformMap)); + tsdPtr->rtmPtr = ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); } @@ -2295,6 +2311,24 @@ DeleteThreadReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels, remove all, mark them as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { + ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + ckfree(rtmPtr); + + /* * 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. @@ -2331,23 +2365,6 @@ DeleteThreadReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } - - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels, remove all, mark them as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { - ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); - - rtPtr->interp = NULL; - Tcl_DeleteHashEntry(hPtr); - } - Tcl_MutexUnlock(&rtForwardMutex); } @@ -2360,7 +2377,6 @@ ForwardOpToOwnerThread( Tcl_ThreadId dst = rtPtr->thread; ForwardingEvent *evPtr; ForwardingResult *resultPtr; - int result; /* * We gather the lock early. This allows us to check the liveness of the @@ -2369,7 +2385,7 @@ ForwardOpToOwnerThread( Tcl_MutexLock(&rtForwardMutex); - if (rtPtr->interp == NULL) { + if (rtPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. Do not forget to unlock the mutex on this path. @@ -2384,8 +2400,8 @@ ForwardOpToOwnerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult)); + evPtr = ckalloc(sizeof(ForwardingEvent)); + resultPtr = ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -2395,6 +2411,7 @@ ForwardOpToOwnerThread( resultPtr->src = Tcl_GetCurrentThread(); resultPtr->dst = dst; + resultPtr->dsti = rtPtr->interp; resultPtr->done = NULL; resultPtr->result = -1; resultPtr->evPtr = evPtr; @@ -2464,8 +2481,7 @@ ForwardOpToOwnerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - result = resultPtr->result; - ckfree((char*) resultPtr); + ckfree(resultPtr); } static int @@ -2552,7 +2568,7 @@ ForwardProc( hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + FreeReflectedTransformArgs(rtPtr); break; case ForwardedInput: { @@ -2623,7 +2639,7 @@ ForwardProc( break; } - case ForwardedDrain: { + case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2648,9 +2664,8 @@ ForwardProc( } } break; - } - case ForwardedFlush: { + case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2676,12 +2691,10 @@ ForwardProc( } } break; - } - case ForwardedClear: { + case ForwardedClear: (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); break; - } case ForwardedLimit: if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { @@ -2784,10 +2797,10 @@ ForwardSetObjError( const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } -#endif +#endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- @@ -2846,7 +2859,8 @@ TimerSetup( return; } - rtPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TimerRun, rtPtr); + rtPtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRun, rtPtr); } /* @@ -3083,7 +3097,7 @@ TransformRead( ckfree(p.transform.buf); return 1; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ @@ -3144,7 +3158,7 @@ TransformWrite( p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rtPtr->mode & TCL_WRITABLE */ @@ -3206,7 +3220,7 @@ TransformDrain( ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3261,7 +3275,7 @@ TransformFlush( } ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3302,7 +3316,7 @@ TransformClear( ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); return; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 6887b0c..694501f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -7,11 +7,15 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIOSock.c,v 1.11 2007/02/20 23:24:04 nijtmans Exp $ */ #include "tclInt.h" + +#if defined(_WIN32) && defined(UNICODE) +/* On Windows, we always need the ASCII version. */ +# undef gai_strerror +# define gai_strerror gai_strerrorA +#endif /* *--------------------------------------------------------------------------- @@ -60,8 +64,8 @@ TclSockGetPort( return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't open socket: port number too high", -1)); return TCL_ERROR; } return TCL_OK; @@ -83,30 +87,190 @@ TclSockGetPort( *---------------------------------------------------------------------- */ +#if !defined(_WIN32) && !defined(__CYGWIN__) +# define SOCKET int +#endif + int TclSockMinimumBuffers( - int sock, /* Socket file descriptor */ + void *sock, /* Socket file descriptor */ int size) /* Minimum buffer size */ { int current; socklen_t len; len = sizeof(int); - getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) &size, len); } len = sizeof(int); - getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) &size, len); } return TCL_OK; } /* + *---------------------------------------------------------------------- + * + * TclCreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to an IP + * address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + struct addrinfo hints; + struct addrinfo *p; + struct addrinfo *v4head = NULL, *v4ptr = NULL; + struct addrinfo *v6head = NULL, *v6ptr = NULL; + char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring; + const char *family = NULL; + Tcl_DString ds; + int result, i; + + if (host != NULL) { + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + } + + /* + * 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; + } else { + 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] + */ + + 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; + } + } + } + + hints.ai_socktype = SOCK_STREAM; + +#if 0 + /* + * 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, + * we'll leave it out for now. After all, it is just an optimisation. + * + * Missing on: OpenBSD, NetBSD. + * Causes failure when used on AIX 5.1 and HP-UX + */ + +#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) + hints.ai_flags |= AI_ADDRCONFIG; +#endif /* AI_ADDRCONFIG && !_AIX && !__hpux */ +#endif /* 0 */ + + if (willBind) { + hints.ai_flags |= AI_PASSIVE; + } + + result = getaddrinfo(native, portstring, &hints, addrlist); + + if (host != NULL) { + Tcl_DStringFree(&ds); + } + + if (result != 0) { + *errorMsgPtr = +#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ + (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : +#endif /* EAI_SYSTEM */ + gai_strerror(result); + return 0; + } + + /* + * Put IPv4 addresses before IPv6 addresses to maximize backwards + * compatibility of [fconfigure -sockname] output. + * + * 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) { + if (v4head == NULL) { + v4head = p; + } else { + v4ptr->ai_next = p; + } + v4ptr = p; + } else { + if (v6head == NULL) { + v6head = p; + } else { + v6ptr->ai_next = p; + } + v6ptr = p; + } + } + *addrlist = NULL; + if (v6head != NULL) { + *addrlist = v6head; + v6ptr->ai_next = NULL; + } + if (v4head != NULL) { + v4ptr->ai_next = *addrlist; + *addrlist = v4head; + } + } + i = 0; + for (p = *addrlist; p != NULL; p = p->ai_next) { + i++; + } + + return 1; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6683ff9..ab08353 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -16,10 +16,11 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIOUtil.c,v 1.178 2010/09/22 00:57:11 hobbs Exp $ */ +#if defined(HAVE_SYS_STAT_H) && !defined _WIN32 +# include <sys/stat.h> +#endif #include "tclInt.h" #ifdef __WIN32__ # include "tclWinInt.h" @@ -27,6 +28,43 @@ #include "tclFileSystem.h" /* + * struct FilesystemRecord -- + * + * A filesystem record is used to keep track of each filesystem currently + * registered with the core, in a linked list. + */ + +typedef struct FilesystemRecord { + ClientData clientData; /* Client specific data for the new filesystem + * (can be NULL) */ + const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */ + struct FilesystemRecord *nextPtr; + /* The next filesystem registered to Tcl, or + * NULL if no more. */ + struct FilesystemRecord *prevPtr; + /* The previous filesystem registered to Tcl, + * or NULL if no more. */ +} FilesystemRecord; + +/* + * This structure holds per-thread private copy of the current directory + * maintained by the global cwdPathPtr. This structure holds per-thread + * private copies of some global data. This way we avoid most of the + * synchronization calls which boosts performance, at cost of having to update + * this information each time the corresponding epoch counter changes. + */ + +typedef struct ThreadSpecificData { + int initialized; + int cwdPathEpoch; + int filesystemEpoch; + Tcl_Obj *cwdPathPtr; + ClientData cwdClientData; + FilesystemRecord *filesystemList; + int claims; +} ThreadSpecificData; + +/* * Prototypes for functions defined later in this file. */ @@ -39,9 +77,10 @@ static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); -#ifdef TCL_THREADS static void FsRecacheFilesystemList(void); -#endif +static void Claim(void); +static void Disclaim(void); + static void * DivertFindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void DivertUnloadFile(Tcl_LoadHandle loadHandle); @@ -143,8 +182,8 @@ const Tcl_Filesystem tclNativeFilesystem = { TclpObjRenameFile, TclpObjCopyDirectory, TclpObjLstat, - TclpDlopen, - /* Needs a cast since we're using version_2. */ + /* Needs casts since we're using version_2. */ + (Tcl_FSLoadFileProc *) TclpDlopen, (Tcl_FSGetCwdProc *) TclpGetNativeCwd, TclpObjChdir }; @@ -162,7 +201,6 @@ const Tcl_Filesystem tclNativeFilesystem = { static FilesystemRecord nativeFilesystemRecord = { NULL, &tclNativeFilesystem, - 1, NULL, NULL }; @@ -174,7 +212,7 @@ static FilesystemRecord nativeFilesystemRecord = { * trigger cache cleanup in all threads. */ -static int theFilesystemEpoch = 0; +static int theFilesystemEpoch = 1; /* * Stores the linked list of filesystems. A 1:1 copy of this list is also @@ -194,7 +232,7 @@ static int cwdPathEpoch = 0; static ClientData cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) -Tcl_ThreadDataKey tclFsDataKey; +static Tcl_ThreadDataKey fsDataKey; /* * One of these structures is used each time we successfully load a file from @@ -367,7 +405,7 @@ Tcl_GetCwd( return NULL; } Tcl_DStringInit(cwdPtr); - Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } @@ -418,18 +456,18 @@ FsThrExitProc( fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; - if (--fsRecPtr->fileRefCount <= 0) { - ckfree((char *) fsRecPtr); - } + fsRecPtr->fsPtr = NULL; + ckfree(fsRecPtr); fsRecPtr = tmpFsRecPtr; } + tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } int TclFSCwdIsNative(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (tsdPtr->cwdClientData != NULL) { return 1; @@ -463,7 +501,7 @@ int TclFSCwdPointerEquals( Tcl_Obj **pathPtrPtr) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); Tcl_MutexLock(&cwdMutex); if (tsdPtr->cwdPathPtr == NULL @@ -522,12 +560,11 @@ TclFSCwdPointerEquals( } } -#ifdef TCL_THREADS static void FsRecacheFilesystemList(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list; /* * Trash the current cache. @@ -536,20 +573,16 @@ FsRecacheFilesystemList(void) fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; - if (--fsRecPtr->fileRefCount <= 0) { - ckfree((char *) fsRecPtr); - } + fsRecPtr->nextPtr = toFree; + toFree = fsRecPtr; fsRecPtr = tmpFsRecPtr; } - tsdPtr->filesystemList = NULL; /* - * Code below operates on shared data. We are already called under mutex - * lock so we can safely proceed. - * * Locate tail of the global filesystem list. */ + Tcl_MutexLock(&filesystemMutex); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; @@ -560,18 +593,26 @@ FsRecacheFilesystemList(void) * Refill the cache honouring the order. */ + list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; - tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; + tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; - if (tsdPtr->filesystemList) { - tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; - } - tsdPtr->filesystemList = tmpFsRecPtr; + list = tmpFsRecPtr; fsRecPtr = fsRecPtr->prevPtr; } + tsdPtr->filesystemList = list; + tsdPtr->filesystemEpoch = theFilesystemEpoch; + Tcl_MutexUnlock(&filesystemMutex); + + while (toFree) { + FilesystemRecord *next = toFree->nextPtr; + toFree->fsPtr = NULL; + ckfree(toFree); + toFree = next; + } /* * Make sure the above gets released on thread exit. @@ -582,28 +623,16 @@ FsRecacheFilesystemList(void) tsdPtr->initialized = 1; } } -#endif /* TCL_THREADS */ static FilesystemRecord * FsGetFirstFilesystem(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - FilesystemRecord *fsRecPtr; - -#ifndef TCL_THREADS - tsdPtr->filesystemEpoch = theFilesystemEpoch; - fsRecPtr = filesystemList; -#else - Tcl_MutexLock(&filesystemMutex); - if (tsdPtr->filesystemList == NULL - || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + if (tsdPtr->filesystemList == NULL || ((tsdPtr->claims == 0) + && (tsdPtr->filesystemEpoch != theFilesystemEpoch))) { FsRecacheFilesystemList(); - tsdPtr->filesystemEpoch = theFilesystemEpoch; } - Tcl_MutexUnlock(&filesystemMutex); - fsRecPtr = tsdPtr->filesystemList; -#endif - return fsRecPtr; + return tsdPtr->filesystemList; } /* @@ -615,11 +644,33 @@ int TclFSEpochOk( int filesystemEpoch) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); +} + +static void +Claim(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + tsdPtr->claims++; +} + +static void +Disclaim(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + tsdPtr->claims--; +} + +int +TclFSEpoch(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - (void) FsGetFirstFilesystem(); - return (filesystemEpoch == tsdPtr->filesystemEpoch); + return tsdPtr->filesystemEpoch; } + /* * If non-NULL, clientData is owned by us and must be freed later. @@ -632,7 +683,7 @@ FsUpdateCwd( { int len; const char *str = NULL; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { str = Tcl_GetStringFromObj(cwdObj, &len); @@ -729,17 +780,14 @@ TclFinalizeFilesystem(void) while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - if (fsRecPtr->fileRefCount <= 0) { - /* - * The native filesystem is static, so we don't free it. - */ + /* The native filesystem is static, so we don't free it. */ - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - ckfree((char *) fsRecPtr); - } + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } + theFilesystemEpoch++; filesystemList = NULL; /* @@ -772,11 +820,7 @@ void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; - - /* - * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount - * should equal 1 and if not, we should try to track down the cause. - */ + theFilesystemEpoch++; #ifdef __WIN32__ /* @@ -829,19 +873,12 @@ Tcl_FSRegister( return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); + newFilesystemPtr = ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; /* - * We start with a refCount of 1. If this drops to zero, then anyone is - * welcome to ckfree us. - */ - - newFilesystemPtr->fileRefCount = 1; - - /* * Is this lock and wait strictly speaking necessary? Since any iterators * out there will have grabbed a copy of the head of the list and be * iterating away from that, if we add a new element to the head of the @@ -914,7 +951,7 @@ Tcl_FSUnregister( */ fsRecPtr = filesystemList; - while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) { + while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) { if (fsRecPtr->fsPtr == fsPtr) { if (fsRecPtr->prevPtr) { fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; @@ -935,10 +972,7 @@ Tcl_FSUnregister( theFilesystemEpoch++; - fsRecPtr->fileRefCount--; - if (fsRecPtr->fileRefCount <= 0) { - ckfree((char *) fsRecPtr); - } + ckfree(fsRecPtr); retVal = TCL_OK; } else { @@ -1064,8 +1098,9 @@ Tcl_FSMatchInDirectory( cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine " - "the current working directory", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "glob couldn't determine the current working directory", + -1)); } return TCL_ERROR; } @@ -1346,14 +1381,9 @@ int TclFSNormalizeToUniquePath( Tcl_Interp *interp, /* Used for error messages. */ Tcl_Obj *pathPtr, /* The path to normalize in place. */ - int startAt, /* Start at this char-offset. */ - ClientData *clientDataPtr) /* If we generated a complete normalized path - * for a given filesystem, we can optionally - * return an fs-specific clientdata here. */ + int startAt) /* Start at this char-offset. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - /* Ignore this variable */ - (void) clientDataPtr; /* * Call each of the "normalise path" functions in succession. This is a @@ -1364,6 +1394,7 @@ TclFSNormalizeToUniquePath( firstFsRecPtr = FsGetFirstFilesystem(); + Claim(); for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { if (fsRecPtr->fsPtr != &tclNativeFilesystem) { continue; @@ -1401,6 +1432,7 @@ TclFSNormalizeToUniquePath( * but there's not much benefit. */ } + Disclaim(); return startAt; } @@ -1545,8 +1577,8 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); } return -1; } @@ -1595,10 +1627,11 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; #endif @@ -1607,10 +1640,11 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; #endif @@ -1621,21 +1655,23 @@ TclGetOpenModeEx( } else { if (interp != NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; } } - ckfree((char *) modeArgv); + ckfree(modeArgv); if (!gotRW) { if (interp != NULL) { - Tcl_AppendResult(interp, "access mode must include either" - " RDONLY, WRONLY, or RDWR", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); } return -1; } @@ -1694,15 +1730,16 @@ Tcl_FSEvalFileEx( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1728,10 +1765,32 @@ Tcl_FSEvalFileEx( objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); - if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { + + /* + * Try to read first character of stream, so we can check for utf-8 BOM to + * be handled especially. + */ + + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + goto end; + } + string = Tcl_GetString(objPtr); + + /* + * If first character is not a BOM, append the remaining characters, + * otherwise replace them. [Bug 3466099] + */ + + if (Tcl_ReadChars(chan, objPtr, -1, + memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + Tcl_Close(interp, chan); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1750,7 +1809,7 @@ Tcl_FSEvalFileEx( */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = Tcl_EvalEx(interp, string, length, 0); + result = TclEvalEx(interp, string, length, 0, 1, NULL, string); /* * Now we have to be careful; the script may have changed the @@ -1797,6 +1856,7 @@ TclNREvalFile( Tcl_Obj *oldScriptFile, *objPtr; Interp *iPtr; Tcl_Channel chan; + const char *string; if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return TCL_ERROR; @@ -1804,15 +1864,16 @@ TclNREvalFile( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1838,10 +1899,33 @@ TclNREvalFile( objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); - if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { + + /* + * Try to read first character of stream, so we can check for utf-8 BOM to + * be handled especially. + */ + + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + string = Tcl_GetString(objPtr); + + /* + * If first character is not a BOM, append the remaining characters, + * otherwise replace them. [Bug 3466099] + */ + + if (Tcl_ReadChars(chan, objPtr, -1, + memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + Tcl_Close(interp, chan); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2177,9 +2261,9 @@ Tcl_FSOpenFileChannel( if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not seek to end of file " - "while opening \"", Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not seek to end of file while opening \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2196,8 +2280,9 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2553,7 +2638,7 @@ Tcl_Obj * Tcl_FSGetCwd( Tcl_Interp *interp) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (TclFSCwdPointerEquals(NULL)) { FilesystemRecord *fsRecPtr; @@ -2565,8 +2650,9 @@ Tcl_FSGetCwd( * indicates the particular function has succeeded. */ - for (fsRecPtr = FsGetFirstFilesystem(); - (retVal == NULL) && (fsRecPtr != NULL); + fsRecPtr = FsGetFirstFilesystem(); + Claim(); + for (; (retVal == NULL) && (fsRecPtr != NULL); fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; @@ -2590,7 +2676,7 @@ Tcl_FSGetCwd( retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); + norm = TclFSNormalizeAbsolutePath(interp,retVal); if (norm != NULL) { /* * We found a cwd, which is now in our global storage. We @@ -2611,13 +2697,15 @@ Tcl_FSGetCwd( } Tcl_DecrRefCount(retVal); retVal = NULL; + Disclaim(); goto cdDidNotChange; } else if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } } + Disclaim(); /* * Now the 'cwd' may NOT be normalized, at least on some platforms. @@ -2629,7 +2717,7 @@ Tcl_FSGetCwd( */ if (retVal != NULL) { - Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); if (norm != NULL) { /* @@ -2688,9 +2776,9 @@ Tcl_FSGetCwd( retCd = proc2(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } if (retCd == tsdPtr->cwdClientData) { @@ -2719,7 +2807,7 @@ Tcl_FSGetCwd( * Normalize the path. */ - norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + norm = TclFSNormalizeAbsolutePath(interp, retVal); /* * Check whether cwd has changed from the value previously stored in @@ -2901,7 +2989,7 @@ Tcl_FSChdir( * instead. This should be examined by someone on Unix. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); ClientData cd; ClientData oldcd = tsdPtr->cwdClientData; @@ -3032,7 +3120,7 @@ Tcl_LoadFile( * code. */ const char *const symbols[],/* Names of functions to look up in the file's * symbol table. */ - int flags, /* Flags (unused) */ + int flags, /* Flags */ void *procVPtrs, /* Where to return the addresses corresponding * to symbols[]. */ Tcl_LoadHandle *handlePtr) /* Filled with token for shared library @@ -3057,8 +3145,8 @@ Tcl_LoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr, - &unloadProcPtr); + int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { if (*handlePtr == NULL) { @@ -3080,8 +3168,9 @@ Tcl_LoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3123,7 +3212,7 @@ Tcl_LoadFile( ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - &unloadProcPtr); + &unloadProcPtr, flags); if (ret == TCL_OK && *handlePtr != NULL) { goto resolveSymbols; } @@ -3131,7 +3220,7 @@ Tcl_LoadFile( mustCopyToTempAnyway: Tcl_ResetResult(interp); -#endif +#endif /* TCL_LOAD_FROM_MEMORY */ /* * Get a temporary filename to use, first to copy the file into, and then @@ -3151,8 +3240,8 @@ Tcl_LoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); return TCL_ERROR; } @@ -3194,7 +3283,7 @@ Tcl_LoadFile( Tcl_ResetResult(interp); - retVal = Tcl_LoadFile(interp, copyToPtr, symbols, 0, procPtrs, + retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, &newLoadHandle); if (retVal != TCL_OK) { /* @@ -3231,7 +3320,7 @@ Tcl_LoadFile( * unload and cleanup the temporary file correctly. */ - tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); + tvdlPtr = ckalloc(sizeof(FsDivertLoad)); /* * Remember three pieces of information. This allows us to cleanup the @@ -3277,10 +3366,8 @@ Tcl_LoadFile( copyToPtr = NULL; - - divertedLoadHandle = (Tcl_LoadHandle) - ckalloc(sizeof (struct Tcl_LoadHandle_)); - divertedLoadHandle->clientData = (ClientData) tvdlPtr; + divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle->clientData = tvdlPtr; divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; *handlePtr = divertedLoadHandle; @@ -3423,52 +3510,8 @@ DivertUnloadFile( Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree((void *) tvdlPtr); - ckfree((void *) loadHandle); -} - -/* - * This function used to be in the platform specific directories, but it has - * now been made to work cross-platform. - */ - -int -TclpLoadFile( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Name of the file containing the desired - * code (UTF-8). */ - const char *sym1, const char *sym2, - /* Names of two functions to look up in the - * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr, /* Filled with token for dynamically loaded - * file which will be passed back to - * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for this - * file. */ -{ - Tcl_LoadHandle handle = NULL; - int res; - - res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); - - if (res != TCL_OK) { - return res; - } - - if (handle == NULL) { - return TCL_ERROR; - } - - *clientDataPtr = handle; - - *proc1Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym1); - *proc2Ptr = (Tcl_PackageInitProc*) Tcl_FindSymbol(interp, handle, sym2); - return TCL_OK; + ckfree(tvdlPtr); + ckfree(loadHandle); } /* @@ -3637,7 +3680,7 @@ TclFSUnloadTempFile( Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree((char *) tvdlPtr); + ckfree(tvdlPtr); } /* @@ -3740,6 +3783,7 @@ Tcl_FSListVolumes(void) */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { if (fsRecPtr->fsPtr->listVolumesProc != NULL) { Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); @@ -3751,6 +3795,7 @@ Tcl_FSListVolumes(void) } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return resultPtr; } @@ -3790,6 +3835,7 @@ FsListMounts( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { if (fsRecPtr->fsPtr != &tclNativeFilesystem && fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { @@ -3801,6 +3847,7 @@ FsListMounts( } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return resultPtr; } @@ -3912,31 +3959,6 @@ Tcl_FSSplitPath( } return result; } - -/* Simple helper function. */ -Tcl_Obj * -TclFSInternalToNormalized( - const Tcl_Filesystem *fromFilesystem, - ClientData clientData, - FilesystemRecord **fsRecPtrPtr) -{ - FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); - - while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr == fromFilesystem) { - *fsRecPtrPtr = fsRecPtr; - break; - } - fsRecPtr = fsRecPtr->nextPtr; - } - - if ((fsRecPtr == NULL) - || (fromFilesystem->internalToNormalizedProc == NULL)) { - return NULL; - } - return fromFilesystem->internalToNormalizedProc(clientData); -} - /* *---------------------------------------------------------------------- * @@ -4038,6 +4060,7 @@ TclFSNonnativePathType( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { /* * We want to skip the native filesystem in this loop because @@ -4115,6 +4138,7 @@ TclFSNonnativePathType( } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return type; } @@ -4502,10 +4526,14 @@ Tcl_FSGetFileSystemForPath( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); + if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { + Disclaim(); return NULL; } else if (retVal != NULL) { /* TODO: Can this happen? */ + Disclaim(); return retVal; } @@ -4527,10 +4555,12 @@ Tcl_FSGetFileSystemForPath( * call to the pathInFilesystemProc. */ - TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + Disclaim(); return fsRecPtr->fsPtr; } } + Disclaim(); return NULL; } @@ -4591,7 +4621,7 @@ static void NativeFreeInternalRep( ClientData clientData) { - ckfree((char *) clientData); + ckfree(clientData); } /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 9eef11a..cb345e2 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIndexObj.c,v 1.59 2010/03/30 13:17:18 nijtmans Exp $ */ #include "tclInt.h" @@ -195,14 +193,14 @@ GetIndexFromObjList( * Build a string table from the list. */ - tablePtr = (const char **) ckalloc((objc + 1) * sizeof(char *)); + tablePtr = ckalloc((objc + 1) * sizeof(char *)); for (t = 0; t < objc; t++) { if (objv[t] == objPtr) { /* * An exact match is always chosen, so we can stop here. */ - ckfree((char *) tablePtr); + ckfree(tablePtr); *indexPtr = t; return TCL_OK; } @@ -219,8 +217,7 @@ GetIndexFromObjList( */ TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; - ckfree((char *) tablePtr); + ckfree(tablePtr); return result; } @@ -342,7 +339,7 @@ Tcl_GetIndexFromObjStruct( indexRep = objPtr->internalRep.otherValuePtr; } else { TclFreeIntRep(objPtr); - indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + indexRep = ckalloc(sizeof(IndexRep)); objPtr->internalRep.otherValuePtr = indexRep; objPtr->typePtr = &indexType; } @@ -359,29 +356,34 @@ Tcl_GetIndexFromObjStruct( * Produce a fancy error message. */ - int count; + int count = 0; TclNewObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); + entryPtr = tablePtr; + while ((*entryPtr != NULL) && !**entryPtr) { + entryPtr = NEXT_ENTRY(entryPtr, offset); + } Tcl_AppendStringsToObj(resultPtr, (numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "), msg, " \"", key, NULL); - if (STRING_AT(tablePtr, offset, 0) == NULL) { + if (*entryPtr == NULL) { Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL); } else { Tcl_AppendStringsToObj(resultPtr, "\": must be ", - STRING_AT(tablePtr, offset, 0), NULL); - for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; - *entryPtr != NULL; - entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { + *entryPtr, NULL); + entryPtr = NEXT_ENTRY(entryPtr, offset); + while (*entryPtr != NULL) { if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); - } else { + } else if (**entryPtr) { Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); + count++; } + entryPtr = NEXT_ENTRY(entryPtr, offset); } } + Tcl_SetObjResult(interp, resultPtr); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); } return TCL_ERROR; @@ -412,9 +414,11 @@ SetIndexFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't convert value to index except via Tcl_GetIndexFromObj API", -1)); + } return TCL_ERROR; } @@ -445,7 +449,7 @@ UpdateStringOfIndex( register const char *indexStr = EXPAND_OF(indexRep); len = strlen(indexStr); - buf = (char *) ckalloc(len + 1); + buf = ckalloc(len + 1); memcpy(buf, indexStr, len+1); objPtr->bytes = buf; objPtr->length = len; @@ -475,7 +479,7 @@ DupIndex( Tcl_Obj *dupPtr) { IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr; - IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.otherValuePtr = dupIndexRep; @@ -503,7 +507,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree((char *) objPtr->internalRep.otherValuePtr); + ckfree(objPtr->internalRep.otherValuePtr); objPtr->typePtr = NULL; } @@ -529,10 +533,10 @@ TclInitPrefixCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, NULL, NULL, NULL}, - {"longest", PrefixLongestObjCmd, NULL, NULL, NULL}, - {"match", PrefixMatchObjCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0}, + {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0}, + {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command prefixCmd; @@ -592,16 +596,20 @@ PrefixMatchObjCmd( flags |= TCL_EXACT; break; case PRFMATCH_MESSAGE: - if (i > (objc - 4)) { - Tcl_AppendResult(interp, "missing message", NULL); + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -message", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } i++; message = Tcl_GetString(objv[i]); break; case PRFMATCH_ERROR: - if (i > (objc - 4)) { - Tcl_AppendResult(interp, "missing error options", NULL); + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing value for -error", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } i++; @@ -610,8 +618,10 @@ PrefixMatchObjCmd( return TCL_ERROR; } if ((errorLength % 2) != 0) { - Tcl_AppendResult(interp, "error options must have an even" - " number of elements", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error options must have an even number of elements", + -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); return TCL_ERROR; } errorPtr = objv[i]; @@ -951,12 +961,14 @@ Tcl_WrongNumArgs( } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } - len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + flags = 0; + len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, (unsigned)len); + char *quotedElementStr = TclStackAlloc(interp, + (unsigned)len + 1); - len = Tcl_ConvertCountedElement(elementStr, elemLen, + len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); TclStackFree(interp, quotedElementStr); @@ -1005,12 +1017,14 @@ Tcl_WrongNumArgs( */ elementStr = TclGetStringFromObj(objv[i], &elemLen); - len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + flags = 0; + len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp,(unsigned) len); + char *quotedElementStr = TclStackAlloc(interp, + (unsigned) len + 1); - len = Tcl_ConvertCountedElement(elementStr, elemLen, + len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); TclStackFree(interp, quotedElementStr); @@ -1090,7 +1104,7 @@ Tcl_ParseArgsObjv( /* Pointer to the current entry in the table * of argument descriptions. */ const Tcl_ArgvInfo *matchPtr; - /* Descriptor that matches current argument. */ + /* Descriptor that matches current argument */ Tcl_Obj *curArg; /* Current argument */ const char *str = NULL; register char c; /* Second character of current arg (used for @@ -1103,17 +1117,19 @@ Tcl_ParseArgsObjv( * being processed, primarily for error * reporting. */ int objc; /* # arguments in objv still to process. */ - int length; /* Number of characters in current argument. */ + int length; /* Number of characters in current argument */ if (remObjv != NULL) { /* - * Then we should copy the name of the command (0th argument). + * Then we should copy the name of the command (0th argument). The + * upper bound on the number of elements is known, and (undocumented, + * but historically true) there should be a NULL argument after the + * last result. [Bug 3413857] */ nrem = 1; - leftovers = (Tcl_Obj **) ckalloc((nrem+1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = objv[0]; - leftovers[nrem] = NULL; + leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; @@ -1144,8 +1160,7 @@ Tcl_ParseArgsObjv( matchPtr = NULL; infoPtr = argTable; - for (; (infoPtr != NULL) && (infoPtr->type != TCL_ARGV_END); - infoPtr++) { + for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) { if (infoPtr->keyStr == NULL) { continue; } @@ -1158,8 +1173,8 @@ Tcl_ParseArgsObjv( goto gotMatch; } if (matchPtr != NULL) { - Tcl_AppendResult(interp, "ambiguous option \"", str, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "ambiguous option \"%s\"", str)); goto error; } matchPtr = infoPtr; @@ -1171,21 +1186,13 @@ Tcl_ParseArgsObjv( */ if (remObjv == NULL) { - Tcl_AppendResult(interp, "unrecognized argument \"", str, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unrecognized argument \"%s\"", str)); goto error; } dstIndex++; /* This argument is now handled */ - nrem++; - - /* - * Allocate nrem (+1 extra for NULL terminator) pointers. - */ - - leftovers = (Tcl_Obj **) ckrealloc((void *) leftovers, - (nrem+1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = curArg; + leftovers[nrem++] = curArg; continue; } @@ -1205,9 +1212,9 @@ Tcl_ParseArgsObjv( } if (Tcl_GetIntFromObj(interp, objv[srcIndex], (int *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected integer argument for \"", - infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1223,7 +1230,14 @@ Tcl_ParseArgsObjv( objc--; break; case TCL_ARGV_REST: - *((int *) infoPtr->dstPtr) = dstIndex; + /* + * Only store the point where we got to if it's not to be written + * to NULL, so that TCL_ARGV_AUTO_REST works. + */ + + if (infoPtr->dstPtr != NULL) { + *((int *) infoPtr->dstPtr) = dstIndex; + } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { @@ -1231,16 +1245,17 @@ Tcl_ParseArgsObjv( } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], (double *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_AppendResult(interp, "expected floating-point argument ", - "for \"", infoPtr->keyStr, "\" but got \"", - Tcl_GetString(objv[srcIndex]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected floating-point argument for \"%s\" but got \"%s\"", + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; objc--; break; case TCL_ARGV_FUNC: { - Tcl_ArgvFuncProc *handlerProc; + Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *) + infoPtr->srcPtr; Tcl_Obj *argObj; if (objc == 0) { @@ -1248,7 +1263,6 @@ Tcl_ParseArgsObjv( } else { argObj = objv[srcIndex]; } - handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr; if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) { srcIndex++; objc--; @@ -1256,9 +1270,9 @@ Tcl_ParseArgsObjv( break; } case TCL_ARGV_GENFUNC: { - Tcl_ArgvGenFuncProc *handlerProc; + Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) + infoPtr->srcPtr; - handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr; objc = handlerProc(infoPtr->clientData, interp, objc, &objv[srcIndex], infoPtr->dstPtr); if (objc < 0) { @@ -1269,20 +1283,18 @@ Tcl_ParseArgsObjv( case TCL_ARGV_HELP: PrintUsage(interp, argTable); goto error; - default: { - char buf[64 + TCL_INTEGER_SPACE]; - - sprintf(buf, "bad argument type %d in Tcl_ArgvInfo", - infoPtr->type); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); + default: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument type %d in Tcl_ArgvInfo", infoPtr->type)); goto error; } - } } /* * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. + * remaining arguments down. Note that there is always at least one + * argument left over - the command name - so we always have a result if + * our caller is willing to receive it. [Bug 3413857] */ argsDone: @@ -1295,20 +1307,12 @@ Tcl_ParseArgsObjv( } if (objc > 0) { - leftovers = (Tcl_Obj **) ckrealloc((void *) leftovers, - (nrem+objc+1) * sizeof(Tcl_Obj *)); - while (objc) { - leftovers[nrem] = objv[srcIndex]; - nrem++; - srcIndex++; - objc--; - } - } else if (leftovers != NULL) { - ckfree((char *) leftovers); + memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); + nrem += objc; } leftovers[nrem] = NULL; - *objcPtr = nrem; - *remObjv = leftovers; + *objcPtr = nrem++; + *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* @@ -1317,11 +1321,11 @@ Tcl_ParseArgsObjv( */ missingArg: - Tcl_AppendResult(interp, "\"", str, - "\" option requires an additional argument", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { - ckfree((char *) leftovers); + ckfree(leftovers); } return TCL_ERROR; } @@ -1354,8 +1358,9 @@ PrintUsage( register const Tcl_ArgvInfo *infoPtr; int width, numSpaces; #define NUM_SPACES 20 - static char spaces[] = " "; + static const char spaces[] = " "; char tmp[TCL_DOUBLE_SPACE]; + Tcl_Obj *msg; /* * First, compute the width of the widest option key, so that we can make @@ -1379,39 +1384,39 @@ PrintUsage( * Now add the option information, with pretty-printing. */ - Tcl_AppendResult(interp, "Command-specific options:", NULL); + msg = Tcl_NewStringObj("Command-specific options:", -1); for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) { - Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL); + Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr); continue; } - Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL); + Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr); numSpaces = width + 1 - strlen(infoPtr->keyStr); while (numSpaces > 0) { if (numSpaces >= NUM_SPACES) { - Tcl_AppendResult(interp, spaces, NULL); + Tcl_AppendToObj(msg, spaces, NUM_SPACES); } else { - Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL); + Tcl_AppendToObj(msg, spaces, numSpaces); } numSpaces -= NUM_SPACES; } - Tcl_AppendResult(interp, infoPtr->helpStr, NULL); + Tcl_AppendToObj(msg, infoPtr->helpStr, -1); switch (infoPtr->type) { case TCL_ARGV_INT: - sprintf(tmp, "%d", *((int *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d", + *((int *) infoPtr->dstPtr)); break; case TCL_ARGV_FLOAT: + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", + *((double *) infoPtr->dstPtr)); sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); - Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL); break; case TCL_ARGV_STRING: { - char *string; + char *string = *((char **) infoPtr->dstPtr); - string = *((char **) infoPtr->dstPtr); if (string != NULL) { - Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string, - "\"", NULL); + Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"", + string); } break; } @@ -1419,6 +1424,7 @@ PrintUsage( break; } } + Tcl_SetObjResult(interp, msg); } /* @@ -1430,8 +1436,8 @@ PrintUsage( * * Results: * Returns TCL_ERROR if the value is an invalid completion code. - * Otherwise, returns TCL_OK, and writes the completion code to - * the pointer provided. + * Otherwise, returns TCL_OK, and writes the completion code to the + * pointer provided. * * Side effects: * None. @@ -1443,35 +1449,35 @@ int TclGetCompletionCodeFromObj( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *value, - int *code) /* Argument objects. */ + int *codePtr) /* Argument objects. */ { static const char *const returnCodes[] = { - "ok", "error", "return", "break", "continue", NULL + "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) - && (TCL_OK == TclGetIntFromObj(NULL, value, code))) { + && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } - if (TCL_OK == Tcl_GetIndexFromObj( - NULL, value, returnCodes, NULL, TCL_EXACT, code)) { + if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, + codePtr) == TCL_OK) { return TCL_OK; } + /* * Value is not a legal completion code. */ if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - TclGetString(value), - "\": must be ok, error, return, break, " - "continue, or an integer", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad completion code \"%s\": must be" + " ok, error, return, break, continue, or an integer", + TclGetString(value))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); } return TCL_ERROR; } - + /* * Local Variables: * mode: c diff --git a/generic/tclInt.decls b/generic/tclInt.decls index fe08bd5..f215d32 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,15 +12,12 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tclInt.decls,v 1.149 2010/09/27 19:42:38 msofer Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt -scspec EXTERN # Declare each of the functions in the unsupported internal Tcl # interface. These interfaces are allowed to changed between versions. @@ -83,7 +80,7 @@ declare 12 { # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { - void TclDumpMemoryInfo(FILE *outFile) + int TclDumpMemoryInfo(ClientData clientData, int flags) } # Removed in 8.1: # declare 15 { @@ -116,10 +113,10 @@ declare 22 { declare 23 { Proc *TclFindProc(Interp *iPtr, const char *procName) } -# Replaced with macro (see tclInt.h) in Tcl 8.5 -#declare 24 { -# int TclFormatInt(char *buffer, long n) -#} +# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 +declare 24 { + int TclFormatInt(char *buffer, long n) +} declare 25 { void TclFreePackageInfo(Interp *iPtr) } @@ -191,7 +188,7 @@ declare 42 { } # Removed in Tcl 8.5a2 #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 44 { @@ -226,7 +223,7 @@ declare 51 { } # Removed in Tcl 8.5a2 #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 53 { @@ -322,9 +319,10 @@ declare 76 { declare 77 { void TclpGetTime(Tcl_Time *time) } -declare 78 { - int TclpGetTimeZone(unsigned long time) -} +# Removed in 8.6: +#declare 78 { +# int TclpGetTimeZone(unsigned long time) +#} # Replaced by Tcl_FSListVolumes in 8.4: #declare 79 { # int TclpListVolumes(Tcl_Interp *interp) @@ -423,7 +421,7 @@ declare 103 { int *portPtr) } declare 104 { - int TclSockMinimumBuffers(int sock, int size) + int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { @@ -441,6 +439,9 @@ declare 108 { declare 109 { int TclUpdateReturnInfo(Interp *iPtr) } +declare 110 { + int TclSockMinimumBuffers(void *sock, int size) +} # Removed in 8.1: # declare 110 { # char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) @@ -691,12 +692,12 @@ declare 169 { } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, - int numChars, Command *cmdPtr, int result, int traceFlags, + int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, - int numChars, Command *cmdPtr, int result, int traceFlags, + int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 172 { @@ -748,7 +749,7 @@ declare 177 { # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the interface from unix +# TclpGmtime and TclpLocaltime promoted to the generic interface from unix declare 182 { struct tm *TclpLocaltime(const time_t *clock) @@ -961,7 +962,7 @@ declare 239 { } declare 240 { int TclNRRunCallbacks(Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr) + struct NRE_callback *rootPtr) } declare 241 { int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, @@ -996,6 +997,15 @@ declare 248 { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr) } + +declare 249 { + char *TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr) +} +# TIP #285: Script cancellation support. +declare 250 { + void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) +} ############################################################################## @@ -1008,39 +1018,47 @@ interface tclIntPlat # Windows specific functions declare 0 win { - void TclWinConvertError(unsigned long errCode) + void TclWinConvertError(DWORD errCode) } declare 1 win { - void TclWinConvertWSAError(unsigned long errCode) + void TclWinConvertWSAError(DWORD errCode) } declare 2 win { struct servent *TclWinGetServByName(const char *nm, const char *proto) } declare 3 win { - int TclWinGetSockOpt(int s, int level, int optname, - char FAR *optval, int FAR *optlen) + int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) } declare 4 win { HINSTANCE TclWinGetTclInstance(void) } +# new for 8.4.20+/8.5.12+ Cygwin only +declare 5 win { + int TclUnixWaitForFile(int fd, int mask, int timeout) +} # Removed in 8.1: # declare 5 win { # HINSTANCE TclWinLoadLibrary(char *name) # } declare 6 win { - u_short TclWinNToHS(u_short ns) + unsigned short TclWinNToHS(unsigned short ns) } declare 7 win { - int TclWinSetSockOpt(int s, int level, int optname, - const char FAR *optval, int optlen) + int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) } declare 8 win { - unsigned long TclpGetPid(Tcl_Pid pid) + int TclpGetPid(Tcl_Pid pid) } declare 9 win { int TclWinGetPlatformId(void) } +# new for 8.4.20+/8.5.12+ Cygwin only +declare 10 win { + Tcl_DirEntry *TclpReaddir(DIR *dir) +} # Removed in 8.3.1 (for Win32s only) #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) @@ -1062,9 +1080,13 @@ declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 15 win { - int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, - TclFile inputFile, TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr) + int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid *pidPtr) +} +# new for 8.4.20+/8.5.12+ Cygwin only +declare 16 win { + int TclpIsAtty(int fd) } # Signature changed in 8.1: # declare 16 win { @@ -1073,6 +1095,11 @@ declare 15 win { # declare 17 win { # char *TclpGetTZName(void) # } +# new for 8.5.12+ Cygwin only +declare 17 win { + int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +} declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } @@ -1080,9 +1107,12 @@ declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { - void TclWinAddProcess(void *hProcess, unsigned long id) + void TclWinAddProcess(HANDLE hProcess, DWORD id) +} +# new for 8.4.20+/8.5.12+ +declare 21 win { + char *TclpInetNtoa(struct in_addr addr) } - # removed permanently for 8.4 #declare 21 win { # void TclpAsyncMark(Tcl_AsyncHandler async) @@ -1092,13 +1122,14 @@ declare 20 win { declare 22 win { TclFile TclpCreateTempFile(const char *contents) } -declare 23 win { - char *TclpGetTZName(int isdst) -} +# Removed in 8.6: +#declare 23 win { +# char *TclpGetTZName(int isdst) +#} declare 24 win { char *TclWinNoBackslash(char *path) } -# replaced by TclGetPlatform +# replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} @@ -1117,9 +1148,6 @@ declare 27 win { declare 28 win { void TclWinResetInterfaces(void) } -declare 29 win { - int TclWinCPUID(unsigned int index, unsigned int *regs) -} ################################ # Unix specific functions @@ -1140,9 +1168,9 @@ declare 3 unix { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, - TclFile inputFile, TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr) + int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid *pidPtr) } # Signature changed in 8.1: # declare 5 unix { @@ -1170,7 +1198,7 @@ declare 10 unix { Tcl_DirEntry *TclpReaddir(DIR *dir) } # Slots 11 and 12 are forwarders for functions that were promoted to -# Stubs +# generic Stubs declare 11 unix { struct tm *TclpLocaltime_unix(const time_t *clock) } @@ -1212,6 +1240,16 @@ declare 19 macosx { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } +declare 29 {win unix} { + int TclWinCPUID(unsigned int index, unsigned int *regs) +} +# Added in 8.6; core of TclpOpenTemporaryFile +declare 30 {win unix} { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) +} + + # Local Variables: # mode: tcl diff --git a/generic/tclInt.h b/generic/tclInt.h index f5b0666..1d04c82 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -14,8 +14,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclInt.h,v 1.483 2010/09/27 19:42:38 msofer Exp $ */ #ifndef _TCLINT @@ -803,13 +801,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* @@ -954,7 +956,7 @@ typedef struct CompiledLocal { * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[4]; /* Name of the local variable starts here. If + char name[1]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST @@ -1152,7 +1154,7 @@ typedef struct CallFrame { * meaning of the value is, which we do not * specify. */ LocalCache *localCachePtr; - struct TEOV_callback *tailcallPtr; + struct NRE_callback *tailcallPtr; /* NULL if no tailcall is scheduled */ } CallFrame; @@ -1493,8 +1495,8 @@ typedef struct ExecEnv { * stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ struct Tcl_Interp *interp; - struct TEOV_callback *callbackPtr; - /* Top callback in TEOV's stack. */ + struct NRE_callback *callbackPtr; + /* Top callback in NRE's stack. */ struct CoroutineData *corPtr; int rewind; } ExecEnv; @@ -1601,6 +1603,8 @@ typedef struct { CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ ClientData clientData; /* Any clientData to give the command. */ + int unsafe; /* Whether this command is to be hidden by + * default in a safe interpreter. */ } EnsembleImplMap; /* @@ -2133,7 +2137,7 @@ typedef struct Interp { * tclOOInt.h and tclOO.c for real definition * and setup. */ - struct TEOV_callback *deferredCallbacks; + struct NRE_callback *deferredCallbacks; /* Callbacks that are set previous to a call * to some Eval function but that actually * belong to the command that is about to be @@ -2159,6 +2163,8 @@ typedef struct Interp { Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */ Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */ Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */ + Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */ + Tcl_Obj *innerContext; /* cached list for fast reallocation */ int resetErrorStack; /* controls cleaning up of ::errorStack */ #ifdef TCL_COMPILE_STATS @@ -2180,6 +2186,22 @@ typedef struct Interp { *((iPtr)->asyncReadyPtr) /* + * Macros for script cancellation support (TIP #285). + */ + +#define TclCanceled(iPtr) \ + (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) + +#define TclSetCancelFlags(iPtr, cancelFlags) \ + (iPtr)->flags |= CANCELED; \ + if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ + (iPtr)->flags |= TCL_CANCEL_UNWIND; \ + } + +#define TclUnsetCancelFlags(iPtr) \ + (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) + +/* * General list of interpreters. Doubly linked for easier removal of items * deep in the list. */ @@ -2251,6 +2273,9 @@ typedef struct InterpList { * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, * less priviledge than a regular interp). + * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter + * debug/info mechanisms (e.g. info frame eval/uplevel + * tracing) which are performance intensive. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. @@ -2276,6 +2301,7 @@ typedef struct InterpList { #define DELETED 1 #define ERR_ALREADY_LOGGED 4 +#define INTERP_DEBUG_FRAME 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 @@ -2419,6 +2445,11 @@ typedef struct List { * accomodate all elements. */ } List; +#define LIST_MAX \ + (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) +#define LIST_SIZE(numElems) \ + (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + /* * Macro used to get the elements of a list object. */ @@ -2426,6 +2457,12 @@ 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) @@ -2433,6 +2470,9 @@ typedef struct List { #define ListObjLength(listPtr, len) \ ((len) = ListRepPtr(listPtr)->elemCount) +#define ListObjIsCanonical(listPtr) \ + (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) + #define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ (((listPtr)->typePtr == &tclListType) \ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ @@ -2443,6 +2483,17 @@ typedef struct List { ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) +#define TclListObjIsCanonical(listPtr) \ + (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) + +/* + * Modes for collecting (or not) in the implementations of TclNRForeachCmd, + * TclNRLmapCmd and their compilations. + */ + +#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ +#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ + /* * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. @@ -2513,6 +2564,8 @@ typedef struct List { #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); +typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file @@ -2728,29 +2781,32 @@ MODULE_SCOPE char tclEmptyString; *---------------------------------------------------------------- */ -MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; +MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, - struct TEOV_callback *tailcallPtr); + struct NRE_callback *tailcallPtr); /* * This structure holds the data for the various iteration callbacks used to @@ -2789,6 +2845,32 @@ struct Tcl_LoadHandle_ { /* Procedure that unloads a loaded module */ }; +/* Flags for conversion of doubles to digit strings */ + +#define TCL_DD_SHORTEST 0x4 + /* Use the shortest possible string */ +#define TCL_DD_STEELE 0x5 + /* Use the original Steele&White algorithm */ +#define TCL_DD_E_FORMAT 0x2 + /* Use a fixed-length string of digits, + * suitable for E format*/ +#define TCL_DD_F_FORMAT 0x3 + /* Use a fixed number of digits after the + * decimal point, suitable for F format */ + +#define TCL_DD_SHORTEN_FLAG 0x4 + /* Allow return of a shorter digit string + * if it converts losslessly */ +#define TCL_DD_NO_QUICK 0x8 + /* Debug flag: forbid quick FP conversion */ + +#define TCL_DD_CONVERSION_TYPE_MASK 0x3 + /* Mask to isolate the conversion type */ +#define TCL_DD_STEELE0 0x1 + /* 'Steele&White' after masking */ +#define TCL_DD_SHORTEST0 0x0 + /* 'Shortest possible' after masking */ + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: @@ -2826,10 +2908,9 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); +MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], Tcl_Interp *interp, int result); -MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, - LiteralTable *tablePtr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, @@ -2837,26 +2918,30 @@ MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); +MODULE_SCOPE int TclConvertElement(const char *src, int length, + char *dst, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); +MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, + Tcl_Obj *objPtr); +MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, + Tcl_DString *toAppendPtr); +MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -2931,6 +3016,8 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsLocalScalar(const char *src, int len); +MODULE_SCOPE int TclIsSpaceProc(char byte); +MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, @@ -2948,12 +3035,12 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); -MODULE_SCOPE int TclMarkList(Tcl_Interp *interp, const char *list, - const char *end, int *argcPtr, - const int **argszPtr, const char ***argvPtr); +MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, + const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); +MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, @@ -2967,7 +3054,7 @@ MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, MODULE_SCOPE int TclParseBackslash(const char *src, int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseHex(const char *src, int numBytes, - Tcl_UniChar *resultPtr); + int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, int numBytes, const char **endPtrPtr, int flags); @@ -2986,6 +3073,10 @@ MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, + struct addrinfo **addrlist, + const char *host, int port, int willBind, + const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); @@ -2995,12 +3086,6 @@ MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); -MODULE_SCOPE int TclpLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - const char *sym1, const char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, - ClientData *clientDataPtr, - Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); MODULE_SCOPE void TclpMasterUnlock(void); @@ -3041,6 +3126,8 @@ MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); +MODULE_SCOPE int TclScanElement(const char *string, int length, + int *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, @@ -3069,17 +3156,21 @@ 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 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 Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr); + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr); + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); @@ -3095,6 +3186,8 @@ 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); + /* *---------------------------------------------------------------- * Command procedures in the generic core: @@ -3155,9 +3248,24 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int index, int pathc, + Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); +MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +/* Assemble command function */ +MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3188,9 +3296,8 @@ MODULE_SCOPE int Tcl_FconfigureObjCmd( MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FileObjCmd(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[]); @@ -3246,6 +3353,9 @@ MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3270,9 +3380,7 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_NamespaceObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3383,6 +3491,15 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3395,6 +3512,12 @@ MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3407,12 +3530,24 @@ MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3428,15 +3563,36 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3455,18 +3611,48 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceCmd(Tcl_Interp *interp, +MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3479,21 +3665,36 @@ MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3512,6 +3713,9 @@ MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -3651,6 +3855,10 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData, MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); + +MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); /* * Functions defined in generic/tclVar.c and currenttly exported only for use @@ -3702,6 +3910,8 @@ 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 int TclFullFinalizationRequested(void); + /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. @@ -3860,6 +4070,13 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); #else /* not PURIFY or USE_THREAD_ALLOC */ +#if defined(USE_TCLALLOC) && USE_TCLALLOC + MODULE_SCOPE void TclFinalizeAllocSubsystem(); + MODULE_SCOPE void TclInitAlloc(); +#else +# define USE_TCLALLOC 0 +#endif + #ifdef TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; @@ -3968,9 +4185,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclFreeIntRep(objPtr) \ - if ((objPtr)->typePtr != NULL && \ - (objPtr)->typePtr->freeIntRepProc != NULL) { \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ + if ((objPtr)->typePtr != NULL) { \ + if ((objPtr)->typePtr->freeIntRepProc != NULL) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ (objPtr)->typePtr = NULL; \ } @@ -4005,8 +4223,22 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ +/* General tuning for minimum growth in Tcl growth algorithms */ +#ifndef TCL_MIN_GROWTH +# ifdef TCL_GROWTH_MIN_ALLOC + /* Support for any legacy tuners */ +# define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC +# else +# define TCL_MIN_GROWTH 1024 +# endif +#endif + +/* Token growth tuning, default to the general value. */ +#ifndef TCL_MIN_TOKEN_GROWTH +#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) +#endif + #define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) -#define TCL_MIN_TOKEN_GROWTH 50 #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ int needed = (used) + (append); \ @@ -4061,8 +4293,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ - ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \ + ((((unsigned char) *(str)) < 0xC0) ? \ + ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* @@ -4135,8 +4367,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateNsCmdLookup(nsPtr) \ - if ((nsPtr)->numExportPatterns) { \ - (nsPtr)->exportLookupEpoch++; \ + if ((nsPtr)->numExportPatterns) { \ + (nsPtr)->exportLookupEpoch++; \ + } \ + if ((nsPtr)->commandPathLength) { \ + (nsPtr)->cmdRefEpoch++; \ } /* @@ -4184,18 +4419,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- - * Macro used by the Tcl core to write the string rep of a long integer to a - * character buffer. The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclFormatInt(char *buf, long n); - *---------------------------------------------------------------- - */ - -#define TclFormatInt(buf, n) \ - sprintf((buf), "%ld", (long)(n)) - -/* - *---------------------------------------------------------------- * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C @@ -4334,6 +4557,21 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- + * Convenience macros for DStrings. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr, + * const char *sLiteral); + * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr); + */ + +#define TclDStringAppendLiteral(dsPtr, sLiteral) \ + Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) +#define TclDStringClear(dsPtr) \ + Tcl_DStringSetLength((dsPtr), 0) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to test for some special double values. * The ANSI C "prototypes" for these macros are: * @@ -4508,11 +4746,11 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); * available. */ -typedef struct TEOV_callback { +typedef struct NRE_callback { Tcl_NRPostProc *procPtr; ClientData data[4]; - struct TEOV_callback *nextPtr; -} TEOV_callback; + struct NRE_callback *nextPtr; +} NRE_callback; #define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr) @@ -4522,7 +4760,7 @@ typedef struct TEOV_callback { #define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ do { \ - TEOV_callback *callbackPtr; \ + NRE_callback *callbackPtr; \ TCLNR_ALLOC((interp), (callbackPtr)); \ callbackPtr->procPtr = (postProcPtr); \ callbackPtr->data[0] = (ClientData)(data0); \ @@ -4535,7 +4773,7 @@ typedef struct TEOV_callback { #define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \ do { \ - TEOV_callback *callbackPtr; \ + NRE_callback *callbackPtr; \ TCLNR_ALLOC((interp), (callbackPtr)); \ callbackPtr->procPtr = (postProcPtr); \ callbackPtr->data[0] = (ClientData)(data0); \ @@ -4548,7 +4786,7 @@ typedef struct TEOV_callback { #define TclNRSpliceCallbacks(interp, topPtr) \ do { \ - TEOV_callback *bottomPtr = topPtr; \ + NRE_callback *bottomPtr = topPtr; \ while (bottomPtr->nextPtr) { \ bottomPtr = bottomPtr->nextPtr; \ } \ @@ -4564,11 +4802,11 @@ typedef struct TEOV_callback { #if NRE_USE_SMALL_ALLOC #define TCLNR_ALLOC(interp, ptr) \ - TclSmallAllocEx(interp, sizeof(TEOV_callback), (ptr)) + TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr)) #define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) #else #define TCLNR_ALLOC(interp, ptr) \ - (ptr = ((ClientData) ckalloc(sizeof(TEOV_callback)))) + (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) #define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif @@ -4582,6 +4820,12 @@ typedef struct TEOV_callback { #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" +#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) +#define Tcl_AttemptAlloc(size) TclpAlloc(size) +#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) +#define Tcl_Free(ptr) TclpFree(ptr) +#endif + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index bd4cdda..df5ac97 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIntDecls.h,v 1.143 2010/09/27 19:42:38 msofer Exp $ */ #ifndef _TCLINTDECLS @@ -92,7 +90,7 @@ EXTERN void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr); /* Slot 13 is reserved */ /* 14 */ -EXTERN void TclDumpMemoryInfo(FILE *outFile); +EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags); /* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); @@ -109,7 +107,8 @@ EXTERN int TclFindElement(Tcl_Interp *interp, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); -/* Slot 24 is reserved */ +/* 24 */ +EXTERN int TclFormatInt(char *buffer, long n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -215,8 +214,7 @@ EXTERN unsigned long TclpGetClicks(void); EXTERN unsigned long TclpGetSeconds(void); /* 77 */ EXTERN void TclpGetTime(Tcl_Time *time); -/* 78 */ -EXTERN int TclpGetTimeZone(unsigned long time); +/* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ @@ -264,7 +262,7 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffers(int sock, int size); +EXTERN int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -272,7 +270,8 @@ EXTERN int TclSockMinimumBuffers(int sock, int size); EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); -/* Slot 110 is reserved */ +/* 110 */ +EXTERN int TclSockMinimumBuffers(void *sock, int size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -571,7 +570,7 @@ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, ProcErrorProc *errorProc); /* 240 */ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr); + struct NRE_callback *rootPtr); /* 241 */ EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); @@ -596,10 +595,16 @@ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); +/* 249 */ +EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr); +/* 250 */ +EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, + int force); typedef struct TclIntStubs { int magic; - const struct TclIntStubHooks *hooks; + void *hooks; void (*reserved0)(void); void (*reserved1)(void); @@ -615,7 +620,7 @@ typedef struct TclIntStubs { void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); - void (*tclDumpMemoryInfo) (FILE *outFile); /* 14 */ + int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ void (*reserved15)(void); void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ void (*reserved17)(void); @@ -625,7 +630,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 */ - void (*reserved24)(void); + int (*tclFormatInt) (char *buffer, long n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); @@ -679,7 +684,7 @@ typedef struct TclIntStubs { unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ void (*tclpGetTime) (Tcl_Time *time); /* 77 */ - int (*tclpGetTimeZone) (unsigned long time); /* 78 */ + void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ @@ -705,13 +710,13 @@ 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 (*tclSockMinimumBuffers) (int sock, int size); /* 104 */ + int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - void (*reserved110)(void); + 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 */ @@ -841,7 +846,7 @@ typedef struct TclIntStubs { 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 */ - int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct TEOV_callback *rootPtr); /* 240 */ + int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ @@ -850,6 +855,8 @@ typedef struct TclIntStubs { int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ + 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 */ } TclIntStubs; #ifdef __cplusplus @@ -903,7 +910,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclFindElement) /* 22 */ #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ -/* Slot 24 is reserved */ +#define TclFormatInt \ + (tclIntStubsPtr->tclFormatInt) /* 24 */ #define TclFreePackageInfo \ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ /* Slot 26 is reserved */ @@ -987,8 +995,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #define TclpGetTime \ (tclIntStubsPtr->tclpGetTime) /* 77 */ -#define TclpGetTimeZone \ - (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ +/* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ #define TclpRealloc \ @@ -1026,8 +1033,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -#define TclSockMinimumBuffers \ - (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -1035,7 +1042,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ -/* Slot 110 is reserved */ +#define TclSockMinimumBuffers \ + (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #define Tcl_AppendExportList \ @@ -1269,6 +1277,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ +#define TclDoubleDigits \ + (tclIntStubsPtr->tclDoubleDigits) /* 249 */ +#define TclSetSlaveCancelFlags \ + (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 95a6016..dcf1753 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -8,13 +8,16 @@ * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. - * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.44 2010/08/21 16:30:26 nijtmans Exp $ */ #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 @@ -38,7 +41,7 @@ * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -76,31 +79,53 @@ EXTERN char * TclpInetNtoa(struct in_addr addr); EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +/* 29 */ +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ -EXTERN void TclWinConvertError(unsigned long errCode); +EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ -EXTERN void TclWinConvertWSAError(unsigned long errCode); +EXTERN void TclWinConvertWSAError(DWORD errCode); /* 2 */ EXTERN struct servent * TclWinGetServByName(const char *nm, const char *proto); /* 3 */ -EXTERN int TclWinGetSockOpt(int s, int level, int optname, - char FAR *optval, int FAR *optlen); +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); -/* Slot 5 is reserved */ +/* 5 */ +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ -EXTERN u_short TclWinNToHS(u_short ns); +EXTERN unsigned short TclWinNToHS(unsigned short ns); /* 7 */ -EXTERN int TclWinSetSockOpt(int s, int level, int optname, - const char FAR *optval, int optlen); +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen); /* 8 */ -EXTERN unsigned long TclpGetPid(Tcl_Pid pid); +EXTERN int TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN int TclWinGetPlatformId(void); -/* Slot 10 is reserved */ +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -117,19 +142,23 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ +EXTERN int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, + int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, unsigned long id); -/* Slot 21 is reserved */ +EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); +/* 21 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 23 */ -EXTERN char * TclpGetTZName(int isdst); +/* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ @@ -141,6 +170,10 @@ EXTERN void TclWinFlushDirtyChannels(void); EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -200,13 +233,28 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +/* 29 */ +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* MACOSX */ typedef struct TclIntPlatStubs { int magic; - const struct TclIntPlatStubHooks *hooks; + void *hooks; -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ @@ -222,38 +270,55 @@ typedef struct TclIntPlatStubs { struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ + void (*reserved15)(void); + void (*reserved16)(void); + void (*reserved17)(void); + void (*reserved18)(void); + void (*reserved19)(void); + void (*reserved20)(void); + void (*reserved21)(void); + void (*reserved22)(void); + void (*reserved23)(void); + void (*reserved24)(void); + void (*reserved25)(void); + void (*reserved26)(void); + void (*reserved27)(void); + void (*reserved28)(void); + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ - void (*tclWinConvertError) (unsigned long errCode); /* 0 */ - void (*tclWinConvertWSAError) (unsigned long errCode); /* 1 */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ + void (*tclWinConvertError) (DWORD errCode); /* 0 */ + void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ - int (*tclWinGetSockOpt) (int s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ - void (*reserved5)(void); - u_short (*tclWinNToHS) (u_short ns); /* 6 */ - int (*tclWinSetSockOpt) (int s, int level, int optname, const char FAR *optval, int optlen); /* 7 */ - unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ + unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ + int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ - void (*reserved10)(void); + Tcl_DirEntry * (*tclpReaddir) (DIR *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 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ - void (*reserved16)(void); - void (*reserved17)(void); + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ - void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */ - void (*reserved21)(void); + void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - char * (*tclpGetTZName) (int isdst); /* 23 */ + void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ @@ -276,6 +341,17 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ + void (*reserved20)(void); + void (*reserved21)(void); + void (*reserved22)(void); + void (*reserved23)(void); + void (*reserved24)(void); + void (*reserved25)(void); + void (*reserved26)(void); + void (*reserved27)(void); + void (*reserved28)(void); + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; @@ -293,7 +369,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ @@ -323,8 +399,26 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ @@ -335,7 +429,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ -/* Slot 5 is reserved */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclWinNToHS \ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ #define TclWinSetSockOpt \ @@ -344,7 +439,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ #define TclWinGetPlatformId \ (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ -/* Slot 10 is reserved */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ @@ -355,19 +451,21 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ +#define TclUnixCopyFile \ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -#define TclpGetTZName \ - (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +/* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ @@ -379,6 +477,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ @@ -420,6 +520,19 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ @@ -428,5 +541,17 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclpLocaltime_unix +#undef TclpGmtime_unix +#undef TclWinConvertWSAError +#define TclWinConvertWSAError TclWinConvertError + +#if defined(__WIN32__) || defined(__CYGWIN__) +# undef TclWinNToHS +# define TclWinNToHS ntohs +#else +# undef TclpGetPid +# define TclpGetPid(pid) ((unsigned long) (pid)) +#endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e22133a..0b0f652 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclInterp.c,v 1.113 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" @@ -210,6 +208,9 @@ static int SlaveBgerror(Tcl_Interp *interp, Tcl_Obj *const objv[]); static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); +static int SlaveDebugCmd(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, + int objc, Tcl_Obj *const objv[]); static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveExpose(Tcl_Interp *interp, @@ -299,8 +300,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -435,7 +436,7 @@ TclInterpInit( Master *masterPtr; Slave *slavePtr; - interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + interpInfoPtr = ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; masterPtr = &interpInfoPtr->master; @@ -531,7 +532,7 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree(interpInfoPtr); } /* @@ -558,19 +559,22 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Interp *slaveInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "delete", "eval", "exists", - "expose", "hide", "hidden", "issafe", + "create", "debug", "delete", + "eval", "exists", "expose", + "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", "slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; @@ -585,7 +589,7 @@ Tcl_InterpObjCmd( } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + Tcl_Interp *masterInterp; if (objc < 4) { aliasArgs: @@ -619,18 +623,13 @@ Tcl_InterpObjCmd( } goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - + case OPT_ALIASES: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - + case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; @@ -640,10 +639,8 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_CANCEL: { int i, flags; - Tcl_Interp *slaveInterp; Tcl_Obj *resultObjPtr; static const char *const cancelOptions[] = { "-unwind", "--", NULL @@ -677,8 +674,7 @@ Tcl_InterpObjCmd( } } - endOfForLoop: - + endOfForLoop: if ((i + 2) < objc) { Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?"); @@ -686,35 +682,34 @@ Tcl_InterpObjCmd( } /* - * Did they specify a slave interp to cancel the script in - * progress in? If not, use the current interp. + * Did they specify a slave interp to cancel the script in progress + * in? If not, use the current interp. */ if (i < objc) { slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } i++; } else { slaveInterp = interp; } - if (slaveInterp != NULL) { - if (i < objc) { - resultObjPtr = objv[i]; - - /* - * Tcl_CancelEval removes this reference. - */ + if (i < objc) { + resultObjPtr = objv[i]; - Tcl_IncrRefCount(resultObjPtr); - i++; - } else { - resultObjPtr = NULL; - } + /* + * Tcl_CancelEval removes this reference. + */ - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + Tcl_IncrRefCount(resultObjPtr); + i++; } else { - return TCL_ERROR; + resultObjPtr = NULL; } + + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; @@ -784,10 +779,23 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } + case OPT_DEBUG: /* TIP #378 */ + /* + * Currently only -frame supported, otherwise ?-option ?value?? + */ + + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); case OPT_DELETE: { int i; InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); @@ -796,6 +804,8 @@ Tcl_InterpObjCmd( } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "DELETESELF", NULL); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; @@ -804,9 +814,7 @@ Tcl_InterpObjCmd( } return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - + case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; @@ -816,12 +824,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + int exists = 1; - exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { @@ -833,9 +838,7 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - + case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; @@ -845,10 +848,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; @@ -858,30 +858,22 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDDEN: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; - + case OPT_ISSAFE: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; - } case OPT_INVOKEHID: { int i; const char *namespaceName; - Tcl_Interp *slaveInterp; static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL }; @@ -924,7 +916,6 @@ Tcl_InterpObjCmd( objv + i); } case OPT_LIMIT: { - Tcl_Interp *slaveInterp; static const char *const limitTypes[] = { "commands", "time", NULL }; @@ -953,9 +944,7 @@ Tcl_InterpObjCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - + case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; @@ -965,10 +954,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - + case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; @@ -978,9 +964,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_SLAVES: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -1004,8 +988,7 @@ Tcl_InterpObjCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Interp *masterInterp; /* The master of the slave. */ Tcl_Channel chan; if (objc != 5) { @@ -1040,7 +1023,6 @@ Tcl_InterpObjCmd( return TCL_OK; } case OPT_TARGET: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; @@ -1061,18 +1043,20 @@ Tcl_InterpObjCmd( iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[2]), "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" in path \"%s\" not found", + aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "target interpreter for alias \"%s\" in path \"%s\" is " + "not my descendant", aliasName, Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; @@ -1250,7 +1234,8 @@ Tcl_GetAlias( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1269,7 +1254,7 @@ Tcl_GetAlias( } if (argvPtr != NULL) { *argvPtr = (const char **) - ckalloc((unsigned) sizeof(const char *) * (objc - 1)); + ckalloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } @@ -1311,7 +1296,8 @@ Tcl_GetAliasObj( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1399,9 +1385,9 @@ TclPreventAliasLoop( * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": interpreter deleted", + Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; @@ -1414,9 +1400,11 @@ TclPreventAliasLoop( } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": would create a loop", + Tcl_GetCommandName(cmdInterp, cmd))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "ALIASLOOP", NULL); return TCL_ERROR; } @@ -1472,8 +1460,7 @@ AliasCreate( Tcl_Obj **prefv; int isNew, i; - aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) - + objc * sizeof(Tcl_Obj *))); + aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; @@ -1524,7 +1511,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - ckfree((char *) aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1581,11 +1568,11 @@ AliasCreate( * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr = ckalloc(sizeof(Target)); targetPtr->slaveCmd = aliasPtr->slaveCmd; targetPtr->slaveInterp = slaveInterp; - masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master; + masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; targetPtr->nextPtr = masterPtr->targetsPtr; targetPtr->prevPtr = NULL; if (masterPtr->targetsPtr != NULL) { @@ -1636,8 +1623,8 @@ AliasDelete( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), - "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; @@ -1968,8 +1955,8 @@ AliasObjCmdDeleteProc( targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - ckfree((char *) targetPtr); - ckfree((char *) aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* @@ -2074,6 +2061,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * TclSetSlaveCancelFlags -- + * + * This function marks all slave interpreters belonging to a given + * interpreter as being canceled or not canceled, depending on the + * provided flags. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclSetSlaveCancelFlags( + Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ + int flags, /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ + int force) /* Non-zero to ignore numLevels for the purpose + * of resetting the cancellation flags. */ +{ + Master *masterPtr; /* Master record of given interpreter. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hashSearch; /* Search variable. */ + Slave *slavePtr; /* Slave record of interpreter. */ + Interp *iPtr; + + if (interp == NULL) { + return; + } + + flags &= (CANCELED | TCL_CANCEL_UNWIND); + + masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + + hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + slavePtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) slavePtr->slaveInterp; + + if (iPtr == NULL) { + continue; + } + + if (flags == 0) { + TclResetCancellation((Tcl_Interp *) iPtr, force); + } else { + TclSetCancelFlags(iPtr, flags); + } + + /* + * Now, recursively handle this for the slaves of this slave + * interpreter. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list @@ -2103,17 +2156,19 @@ Tcl_GetInterpPath( InterpInfo *iiPtr; if (targetInterp == askingInterp) { + Tcl_SetObjResult(askingInterp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; } @@ -2167,8 +2222,8 @@ GetInterp( } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - TclGetString(pathPtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } @@ -2205,8 +2260,10 @@ SlaveBgerror( if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cmdPrefix must be list of length >= 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BGERRORFORMAT", NULL); return TCL_ERROR; } TclSetBgErrorHandler(slaveInterp, objv[0]); @@ -2273,8 +2330,9 @@ SlaveCreate( hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "interpreter named \"%s\" already exists, cannot create", + path)); return NULL; } @@ -2376,14 +2434,16 @@ SlaveObjCmd( Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { - "alias", "aliases", "bgerror", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + "alias", "aliases", "bgerror", "debug", + "eval", "expose", "hide", "hidden", + "issafe", "invokehidden", "limit", "marktrusted", + "recursionlimit", NULL }; enum options { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, + OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, + OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, + OPT_RECLIMIT }; if (slaveInterp == NULL) { @@ -2428,6 +2488,16 @@ SlaveObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + case OPT_DEBUG: + /* + * TIP #378 + * Currently only -frame supported, otherwise ?-option ?value? ...? + */ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); @@ -2591,6 +2661,77 @@ SlaveObjCmdDeleteProc( /* *---------------------------------------------------------------------- * + * SlaveDebugCmd -- TIP #378 + * + * Helper function to handle 'debug' command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify INTERP_DEBUG_FRAME flag in the slave. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveDebugCmd( + Tcl_Interp *interp, /* Interp for error return. */ + Tcl_Interp *slaveInterp, /* The slave interpreter in which command + * will be evaluated. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const debugTypes[] = { + "-frame", NULL + }; + enum DebugTypes { + DEBUG_TYPE_FRAME + }; + int debugType; + Interp *iPtr; + Tcl_Obj *resultPtr; + + iPtr = (Interp *) slaveInterp; + if (objc == 0) { + resultPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj("-frame", -1)); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + Tcl_SetObjResult(interp, resultPtr); + } else { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option", + 0, &debugType) != TCL_OK) { + return TCL_ERROR; + } + if (debugType == DEBUG_TYPE_FRAME) { + if (objc == 2) { /* set */ + if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Quietly ignore attempts to disable interp debugging. This + * is a one-way switch as frame debug info is maintained in a + * stack that must be consistent once turned on. + */ + + if (debugType) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } + } + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. @@ -2614,6 +2755,16 @@ SlaveEval( { int result; + /* + * TIP #285: If necessary, reset the cancellation flags for the slave + * interpreter now; otherwise, canceling a script in a master interpreter + * can result in a situation where a slave interpreter can no longer + * evaluate any scripts unless somebody calls the TclResetCancellation + * function for that particular Tcl_Interp. + */ + + TclSetSlaveCancelFlags(slaveInterp, 0, 0); + Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); @@ -2671,6 +2822,8 @@ SlaveExpose( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2712,8 +2865,10 @@ SlaveRecursionLimit( if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_AppendResult(interp, "permission denied: " - "safe interpreters cannot change recursion limit", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " + "safe interpreters cannot change recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -2722,6 +2877,8 @@ SlaveRecursionLimit( if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", + NULL); return TCL_ERROR; } Tcl_SetRecursionLimit(slaveInterp, limit); @@ -2729,6 +2886,7 @@ SlaveRecursionLimit( if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); @@ -2770,6 +2928,8 @@ SlaveHide( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2852,6 +3012,8 @@ SlaveInvokeHidden( Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2906,6 +3068,8 @@ SlaveMarkTrusted( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; @@ -3161,8 +3325,9 @@ Tcl_LimitCheck( if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command count limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3186,8 +3351,9 @@ Tcl_LimitCheck( iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3263,7 +3429,7 @@ RunLimitHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } } @@ -3310,7 +3476,7 @@ Tcl_LimitAddHandler( * Allocate a handler record. */ - handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + handlerPtr = ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3429,7 +3595,7 @@ Tcl_LimitRemoveHandler( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } return; } @@ -3489,7 +3655,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3522,7 +3688,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3917,7 +4083,7 @@ DeleteScriptLimitCallback( if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - ckfree((char *) limitCBPtr); + ckfree(limitCBPtr); } /* @@ -4017,7 +4183,7 @@ SetScriptLimitCallback( limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4184,6 +4350,20 @@ SlaveCommandLimitCmd( ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; + /* + * First, ensure that we are not reading or writing the calling + * interpreter's limits; it may only manipulate its children. Note that + * the low level API enforces this with Tcl_Panic, which we want to + * avoid. [Bug 3398794] + */ + + if (interp == slaveInterp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + return TCL_ERROR; + } + if (objc == consumedObjc) { Tcl_Obj *dictPtr; @@ -4253,8 +4433,7 @@ SlaveCommandLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4277,8 +4456,10 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4292,8 +4473,10 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (limit < 0) { - Tcl_AppendResult(interp, "command limit value must be at " - "least 0", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command limit value must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4355,6 +4538,20 @@ SlaveTimeLimitCmd( ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; + /* + * First, ensure that we are not reading or writing the calling + * interpreter's limits; it may only manipulate its children. Note that + * the low level API enforces this with Tcl_Panic, which we want to + * avoid. [Bug 3398794] + */ + + if (interp == slaveInterp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + return TCL_ERROR; + } + if (objc == consumedObjc) { Tcl_Obj *dictPtr; @@ -4441,8 +4638,7 @@ SlaveTimeLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4469,8 +4665,10 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4484,11 +4682,13 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "milliseconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "milliseconds must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long)tmp)*1000; + limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4500,8 +4700,10 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "seconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "seconds must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.sec = tmp; @@ -4516,13 +4718,19 @@ SlaveTimeLimitCmd( */ if (secObj != NULL && secLen == 0 && milliLen > 0) { - Tcl_AppendResult(interp, "may only set -milliseconds " - "if -seconds is not also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only set -milliseconds if -seconds is not " + "also being reset", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { - Tcl_AppendResult(interp, "may only reset -milliseconds " - "if -seconds is also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only reset -milliseconds if -seconds is " + "also being reset", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } } diff --git a/generic/tclLink.c b/generic/tclLink.c index b2d236b..a3b42bd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLink.c,v 1.26 2008/10/28 23:29:54 nijtmans Exp $ */ #include "tclInt.h" @@ -114,7 +112,15 @@ Tcl_LinkVar( Link *linkPtr; int code; - linkPtr = (Link *) ckalloc(sizeof(Link)); + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable '%s' is already linked", varName)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); @@ -129,14 +135,14 @@ Tcl_LinkVar( if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); return TCL_ERROR; } code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); } return code; } @@ -174,7 +180,7 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); } /* @@ -268,7 +274,7 @@ LinkTraceProc( if (flags & TCL_TRACE_UNSETS) { if (Tcl_InterpDeleted(interp)) { Tcl_DecrRefCount(linkPtr->varName); - ckfree((char *) linkPtr); + ckfree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 6745f62..3668b45 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclListObj.c,v 1.60 2010/03/18 20:34:48 dgp Exp $ */ #include "tclInt.h" @@ -19,7 +17,9 @@ * Prototypes for functions defined later in this file: */ -static List * NewListIntRep(int objc, Tcl_Obj *const objv[]); +static List * AttemptNewList(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static List * NewListIntRep(int objc, Tcl_Obj *const objv[], int p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -45,22 +45,26 @@ const Tcl_ObjType tclListType = { UpdateStringOfList, /* updateStringProc */ SetListFromAny /* setFromAnyProc */ }; + +#ifndef TCL_MIN_ELEMENT_GROWTH +#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) +#endif /* *---------------------------------------------------------------------- * * NewListIntRep -- * - * If objc>0 and objv!=NULL, this function creates a list internal rep - * with objc elements given in the array objv. If objc>0 and objv==NULL - * it creates the list internal rep of a list with 0 elements, where - * enough space has been preallocated to store objc elements. If objc<=0, - * it returns NULL. + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. Flag value "p" indicates + * how to behave on failure. * * Results: - * A new List struct is returned. If objc<=0 or if the allocation fails - * for lack of memory, NULL is returned. The list returned has refCount - * 0. + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. * * Side effects: * The ref counts of the elements in objv are incremented since the @@ -72,12 +76,13 @@ const Tcl_ObjType tclListType = { static List * NewListIntRep( int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *const objv[], + int p) { List *listRepPtr; if (objc <= 0) { - return NULL; + Tcl_Panic("NewListIntRep: expects postive element count"); } /* @@ -87,13 +92,20 @@ NewListIntRep( * requires API changes to fix. See [Bug 219196] for a discussion. */ - if ((size_t)objc > INT_MAX/sizeof(Tcl_Obj *)) { + if ((size_t)objc > LIST_MAX) { + if (p) { + Tcl_Panic("max length of a Tcl list (%d elements) exceeded", + LIST_MAX); + } return NULL; } - listRepPtr = (List *) - attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); + listRepPtr = attemptckalloc(LIST_SIZE(objc)); if (listRepPtr == NULL) { + if (p) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", + LIST_SIZE(objc)); + } return NULL; } @@ -120,6 +132,51 @@ NewListIntRep( /* *---------------------------------------------------------------------- * + * AttemptNewList -- + * + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +static List * +AttemptNewList( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + List *listRepPtr = NewListIntRep(objc, objv, 0); + + if (interp != NULL && listRepPtr == NULL) { + if (objc > LIST_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list creation failed: unable to alloc %u bytes", + LIST_SIZE(objc))); + } + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return listRepPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewListObj -- * * This function is normally called when not debugging: i.e., when @@ -174,21 +231,14 @@ Tcl_NewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; - + ListSetIntRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -246,20 +296,14 @@ Tcl_DbNewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; + ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -318,7 +362,6 @@ Tcl_SetListObj( */ TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; Tcl_InvalidateStringRep(objPtr); /* @@ -328,14 +371,8 @@ Tcl_SetListObj( */ if (objc > 0) { - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); - } - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; - listRepPtr->refCount++; + listRepPtr = NewListIntRep(objc, objv, 1); + ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; @@ -426,30 +463,19 @@ Tcl_ListObjGetElements( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; - - /* - * Don't get the string version of a dictionary; that transformation - * is not lossy, but is expensive. - */ + int result; - if (listPtr->typePtr == &tclDictType) { - (void) Tcl_DictObjSize(NULL, listPtr, &length); - } else { - (void) TclGetStringFromObj(listPtr, &length); - } - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -460,16 +486,13 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the objects in the list referenced by - * elemListPtr to the list object referenced by listPtr. If listPtr is - * not already a list object, an attempt will be made to convert it to - * one. + * This function appends the elements in the list value referenced by + * elemListPtr to the list value referenced by listPtr. * * Results: * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list objects and they can not be converted to one, TCL_ERROR - * is returned and an error message is left in the interpreter's result - * if interp is not NULL. + * refer to list values, TCL_ERROR is returned and an error message is + * left in the interpreter's result if interp is not NULL. * * Side effects: * The reference counts of the elements in elemListPtr are incremented @@ -487,29 +510,27 @@ Tcl_ListObjAppendList( register Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { - int listLen, objc, result; + int objc; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - result = TclListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - return result; - } + /* + * Pull the elements to append from elemListPtr. + */ - result = TclListObjGetElements(interp, elemListPtr, &objc, &objv); - if (result != TCL_OK) { - return result; + if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { + return TCL_ERROR; } /* - * Insert objc new elements starting after the lists's last element. + * Insert the new elements starting after the lists's last element. * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); + return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); } /* @@ -545,77 +566,129 @@ Tcl_ListObjAppendElement( Tcl_Obj *listPtr, /* List object to append objPtr to. */ Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { - register List *listRepPtr; - register Tcl_Obj **elemPtrs; - int numElems, numRequired, newMax, newSize, i; + register List *listRepPtr, *newPtr = NULL; + int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; + needGrow = (numRequired > listRepPtr->maxElemCount); + isShared = (listRepPtr->refCount > 1); - /* - * If there is no room in the current array of element pointers, allocate - * a new, larger array and copy the pointers to it. If the List struct is - * shared, allocate a new one. - */ + if (numRequired > LIST_MAX) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } - if (numRequired > listRepPtr->maxElemCount){ - newMax = 2 * numRequired; - newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *)); - } else { - newMax = listRepPtr->maxElemCount; - newSize = 0; + if (needGrow && !isShared) { + /* + * Need to grow + unshared intrep => try to realloc + */ + + attempt = 2 * numRequired; + if (attempt <= LIST_MAX) { + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired; + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr) { + listRepPtr = newPtr; + listRepPtr->maxElemCount = attempt; + needGrow = 0; + } } + if (isShared || needGrow) { + Tcl_Obj **dst, **src = &listRepPtr->elements; - if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElems; + /* + * Either we have a shared intrep and we must copy to write, or we + * need to grow and realloc attempts failed. Attempt intrep copy. + */ - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + attempt = 2 * numRequired; + newPtr = AttemptNewList(NULL, attempt, NULL); + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = AttemptNewList(NULL, attempt, NULL); } - oldElems = &oldListRepPtr->elements; - elemPtrs = &listRepPtr->elements; - for (i=0; i<numElems; i++) { - elemPtrs[i] = oldElems[i]; - Tcl_IncrRefCount(elemPtrs[i]); + if (newPtr == NULL) { + attempt = numRequired; + newPtr = AttemptNewList(interp, attempt, NULL); } - listRepPtr->elemCount = numElems; - listRepPtr->refCount++; - oldListRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - } else if (newSize) { - listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize); - listRepPtr->maxElemCount = newMax; - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + if (newPtr == NULL) { + /* + * All growth attempts failed; throw the error. + */ + + return TCL_ERROR; + } + + dst = &newPtr->elements; + newPtr->refCount++; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + newPtr->elemCount = listRepPtr->elemCount; + + if (isShared) { + /* + * The original intrep must remain undisturbed. Copy into the new + * one and bump refcounts + */ + while (numElems--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); + } + listRepPtr->refCount--; + } else { + /* + * Old intrep to be freed, re-use refCounts. + */ + + memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *)); + ckfree(listRepPtr); + } + listRepPtr = newPtr; } + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ - elemPtrs = &listRepPtr->elements; - elemPtrs[numElems] = objPtr; + *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -664,21 +737,19 @@ Tcl_ListObjIndex( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -719,21 +790,19 @@ Tcl_ListObjLength( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -794,15 +863,11 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - int length; - - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { - if (objc) { - Tcl_SetListObj(listPtr, objc, NULL); - } else { + if (listPtr->bytes == tclEmptyStringRep) { + if (!objc) { return TCL_OK; } + Tcl_SetListObj(listPtr, objc, NULL); } else { int result = SetListFromAny(interp, listPtr); @@ -820,7 +885,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -835,8 +900,9 @@ Tcl_ListObjReplace( } else if (numElems < first+count || first+count < 0) { /* * The 'first+count < 0' condition here guards agains integer - * overflow in determining 'first+count' + * overflow in determining 'first+count'. */ + count = numElems - first; } @@ -886,12 +952,23 @@ Tcl_ListObjReplace( newMax = listRepPtr->maxElemCount; } - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + listRepPtr = AttemptNewList(NULL, newMax, NULL); + if (listRepPtr == NULL) { + unsigned int limit = LIST_MAX - numRequired; + unsigned int extra = numRequired - numElems + + TCL_MIN_ELEMENT_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL); + if (listRepPtr == NULL) { + listRepPtr = AttemptNewList(interp, numRequired, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; + } + } } - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -945,7 +1022,7 @@ Tcl_ListObjReplace( (size_t) numAfterLast * sizeof(Tcl_Obj *)); } - ckfree((char *) oldListRepPtr); + ckfree(oldListRepPtr); } } @@ -1008,8 +1085,6 @@ TclLindexList( { int index; /* Index into the list. */ - Tcl_Obj **indices; /* Array of list indices. */ - int indexCount; /* Size of the array of list indices. */ Tcl_Obj *indexListCopy; /* @@ -1049,8 +1124,19 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); - listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); + if (indexListCopy->typePtr == &tclListType) { + List *listRepPtr = ListRepPtr(indexListCopy); + + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); + } else { + int indexCount = -1; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; + /* Array of list indices. */ + + Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); + } Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1232,8 +1318,8 @@ TclLsetList( * * Results: * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for - * the pointer returned. + * occurred. The returned object includes one reference count for the + * pointer returned. * * Side effects: * On entry, the reference count of the variable value does not reflect @@ -1279,8 +1365,8 @@ TclLsetFlat( Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; /* - * If there are no indices, simply return the new value. - * (Without indices, [lset] is a synonym for [set]. + * If there are no indices, simply return the new value. (Without + * indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { @@ -1289,14 +1375,14 @@ TclLsetFlat( } /* - * If the list is shared, make a copy we can modify (copy-on-write). - * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few - * reasons: 1) we have not yet confirmed listPtr is actually a list; - * 2) We make a verbatim copy of any existing string rep, and when - * we combine that with the delayed invalidation of string reps of - * modified Tcl_Obj's implemented below, the outcome is that any - * error condition that causes this routine to return NULL, will - * leave the string rep of listPtr and all elements to be unchanged. + * If the list is shared, make a copy we can modify (copy-on-write). We + * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: + * 1) we have not yet confirmed listPtr is actually a list; 2) We make a + * verbatim copy of any existing string rep, and when we combine that with + * the delayed invalidation of string reps of modified Tcl_Obj's + * implemented below, the outcome is that any error condition that causes + * this routine to return NULL, will leave the string rep of listPtr and + * all elements to be unchanged. */ subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; @@ -1308,21 +1394,25 @@ TclLsetFlat( retValuePtr = subListPtr; chainPtr = NULL; + result = TCL_OK; /* - * Loop through all the index arguments, and for each one dive - * into the appropriate sublist. + * Loop through all the index arguments, and for each one dive into the + * appropriate sublist. */ do { int elemCount; Tcl_Obj *parentList, **elemPtrs; - /* Check for the possible error conditions... */ - result = TCL_ERROR; + /* + * Check for the possible error conditions... + */ + if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ + result = TCL_ERROR; break; } @@ -1334,6 +1424,7 @@ TclLsetFlat( if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) != TCL_OK) { /* ...the index we're trying to use isn't an index at all. */ + result = TCL_ERROR; indexArray++; break; } @@ -1341,19 +1432,23 @@ TclLsetFlat( if (index < 0 || index > elemCount) { /* ...the index points outside the sublist. */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + "BADINDEX", NULL); + } + result = TCL_ERROR; break; } /* - * No error conditions. As long as we're not yet on the last - * index, determine the next sublist for the next pass through - * the loop, and take steps to make sure it is an unshared copy, - * as we intend to modify it. + * No error conditions. As long as we're not yet on the last index, + * determine the next sublist for the next pass through the loop, and + * take steps to make sure it is an unshared copy, as we intend to + * modify it. */ - result = TCL_OK; if (--indexCount) { parentList = subListPtr; if (index == elemCount) { @@ -1370,8 +1465,8 @@ TclLsetFlat( * we know to be unshared. This call will also deal with the * situation where parentList shares its intrep with other * Tcl_Obj's. Dealing with the shared intrep case can cause - * subListPtr to become shared again, so detect that case and - * make and store another copy. + * subListPtr to become shared again, so detect that case and make + * and store another copy. */ if (index == elemCount) { @@ -1385,62 +1480,71 @@ TclLsetFlat( } /* - * The TclListObjSetElement() calls do not spoil the string - * rep of parentList, and that's fine for now, since all we've - * done so far is replace a list element with an unshared copy. - * The list value remains the same, so the string rep. is still - * valid, and unchanged, which is good because if this whole - * routine returns NULL, we'd like to leave no change to the - * value of the lset variable. Later on, when we set valuePtr - * in its proper place, then all containing lists will have - * their values changed, and will need their string reps spoiled. - * We maintain a list of all those Tcl_Obj's (via a little intrep - * surgery) so we can spoil them at that time. + * The TclListObjSetElement() calls do not spoil the string rep of + * parentList, and that's fine for now, since all we've done so + * far is replace a list element with an unshared copy. The list + * value remains the same, so the string rep. is still valid, and + * unchanged, which is good because if this whole routine returns + * NULL, we'd like to leave no change to the value of the lset + * variable. Later on, when we set valuePtr in its proper place, + * then all containing lists will have their values changed, and + * will need their string reps spoiled. We maintain a list of all + * those Tcl_Obj's (via a little intrep surgery) so we can spoil + * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; + parentList->internalRep.twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* - * Either we've detected and error condition, and exited the loop - * with result == TCL_ERROR, or we've successfully reached the last - * index, and we're ready to store valuePtr. In either case, we - * need to clean up our string spoiling list of Tcl_Obj's. + * Either we've detected and error condition, and exited the loop with + * result == TCL_ERROR, or we've successfully reached the last index, and + * we're ready to store valuePtr. In either case, we need to clean up our + * string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; if (result == TCL_OK) { - /* - * We're going to store valuePtr, so spoil string reps - * of all containing lists. + * We're going to store valuePtr, so spoil string reps of all + * containing lists. */ Tcl_InvalidateStringRep(objPtr); } - /* Clear away our intrep surgery mess */ - chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + /* + * Clear away our intrep surgery mess. + */ + + chainPtr = objPtr->internalRep.twoPtrValue.ptr2; objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { /* - * Error return; message is already in interp. Clean up - * any excess memory. + * Error return; message is already in interp. Clean up any excess + * memory. */ + if (retValuePtr != listPtr) { Tcl_DecrRefCount(retValuePtr); } return NULL; } - /* Store valuePtr in proper sublist and return */ - Tcl_ListObjLength(NULL, subListPtr, &len); + /* + * Store valuePtr in proper sublist and return. The -1 is to avoid a + * compiler warning (not a problem because we checked that we have a + * proper list - or something convertible to one - above). + */ + + len = -1; + TclListObjLength(NULL, subListPtr, &len); if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { @@ -1503,12 +1607,15 @@ TclListObjSetElement( Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } if (listPtr->typePtr != &tclListType) { - int length, result; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + if (listPtr->bytes == tclEmptyStringRep) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + "BADINDEX", NULL); + } return TCL_ERROR; } result = SetListFromAny(interp, listPtr); @@ -1517,9 +1624,8 @@ TclListObjSetElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; - elemPtrs = &listRepPtr->elements; /* * Ensure that the index is in bounds. @@ -1529,6 +1635,8 @@ TclListObjSetElement( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); } return TCL_ERROR; } @@ -1538,25 +1646,30 @@ TclListObjSetElement( */ if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElemPtrs = elemPtrs; - int i; + Tcl_Obj **dst, **src = &listRepPtr->elements; + List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); - if (listRepPtr == NULL) { - Tcl_Panic("Not enough memory to allocate list"); + if (newPtr == NULL) { + newPtr = AttemptNewList(interp, elemCount, NULL); + if (newPtr == NULL) { + return TCL_ERROR; + } } - listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; - elemPtrs = &listRepPtr->elements; - for (i=0; i < elemCount; i++) { - elemPtrs[i] = oldElemPtrs[i]; - Tcl_IncrRefCount(elemPtrs[i]); + newPtr->refCount++; + newPtr->elemCount = elemCount; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + + dst = &newPtr->elements; + while (elemCount--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); } - listRepPtr->refCount++; - listRepPtr->elemCount = elemCount; - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - oldListRepPtr->refCount--; + + listRepPtr->refCount--; + + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; } + elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. @@ -1602,18 +1715,16 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj **elemPtrs = &listRepPtr->elements; - register Tcl_Obj *objPtr; - int numElems = listRepPtr->elemCount; - int i; + List *listRepPtr = ListRepPtr(listPtr); if (--listRepPtr->refCount <= 0) { + Tcl_Obj **elemPtrs = &listRepPtr->elements; + int i, numElems = listRepPtr->elemCount; + for (i = 0; i < numElems; i++) { - objPtr = elemPtrs[i]; - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtrs[i]); } - ckfree((char *) listRepPtr); + ckfree(listRepPtr); } listPtr->internalRep.twoPtrValue.ptr1 = NULL; @@ -1643,12 +1754,9 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(srcPtr); - listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclListType; + ListSetIntRep(copyPtr, listRepPtr); } /* @@ -1675,15 +1783,8 @@ SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - const char *string; - char *s; - const char *elemStart, *nextElem; - int lenRemain, length, estCount, elemSize, hasBrace, i, j, result; - const char *limit; /* Points just after string's last byte. */ - register const char *p; - register Tcl_Obj **elemPtrs; - register Tcl_Obj *elemPtr; List *listRepPtr; + Tcl_Obj **elemPtrs; /* * Dictionaries are a special case; they have a string representation such @@ -1708,12 +1809,8 @@ SetListFromAny( */ Tcl_DictObjSize(NULL, objPtr, &size); - listRepPtr = NewListIntRep(size > 0 ? 2*size : 1, NULL); + listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); if (!listRepPtr) { - Tcl_SetResult(interp, - "insufficient memory to allocate list working space", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } listRepPtr->elemCount = 2 * size; @@ -1724,117 +1821,75 @@ SetListFromAny( elemPtrs = &listRepPtr->elements; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); - i = 0; while (!done) { - elemPtrs[i++] = keyPtr; - elemPtrs[i++] = valuePtr; + *elemPtrs++ = keyPtr; + *elemPtrs++ = valuePtr; Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } + } else { + int estCount, length; + const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* - * Swap the representations. + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) list element. */ - goto commitRepresentation; - } - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetStringFromObj(objPtr, &length); - - /* - * Parse the string into separate string objects, and create a List - * structure that points to the element string objects. We use a modified - * version of Tcl_SplitList's implementation to avoid one malloc and a - * string copy for each list element. First, estimate the number of - * elements by counting the number of space characters in the list. - */ - - limit = string + length; - estCount = 1; - for (p = string; p < limit; p++) { - if (isspace(UCHAR(*p))) { /* INTL: ISO space. */ - estCount++; + estCount = TclMaxListLength(nextElem, length, &limit); + estCount += (estCount == 0); /* Smallest list struct holds 1 + * element. */ + listRepPtr = AttemptNewList(interp, estCount, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } - } + elemPtrs = &listRepPtr->elements; - /* - * Allocate a new List structure with enough room for "estCount" elements. - * Each element is a pointer to a Tcl_Obj with the appropriate string rep. - * The initial "estCount" elements are set using the corresponding "argv" - * strings. - */ + /* + * Each iteration, parse and store a list element. + */ - listRepPtr = NewListIntRep(estCount, NULL); - if (!listRepPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Not enough memory to allocate the list internal rep", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - elemPtrs = &listRepPtr->elements; + while (nextElem < limit) { + const char *elemStart; + int elemSize, literal; - for (p=string, lenRemain=length, i=0; - lenRemain > 0; - p=nextElem, lenRemain=limit-nextElem, i++) { - result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, - &elemSize, &hasBrace); - if (result != TCL_OK) { - for (j = 0; j < i; j++) { - elemPtr = elemPtrs[j]; - Tcl_DecrRefCount(elemPtr); + if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + while (--elemPtrs >= &listRepPtr->elements) { + Tcl_DecrRefCount(*elemPtrs); + } + ckfree((char *) listRepPtr); + return TCL_ERROR; } - ckfree((char *) listRepPtr); - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL); + if (elemStart == limit) { + break; } - return result; - } - if (elemStart >= limit) { - break; - } - if (i > estCount) { - Tcl_Panic("SetListFromAny: bad size estimate for list"); - } - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ + /* 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); + } - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy(s, elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - TclNewObj(elemPtr); - elemPtr->bytes = s; - elemPtr->length = elemSize; - elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* Since list now holds ref to it. */ + listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } - listRepPtr->elemCount = i; - /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - commitRepresentation: - listRepPtr->refCount++; TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1864,20 +1919,32 @@ UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { # define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; - register int i; + int i, length, bytesNeeded = 0; const char *elem; char *dst; - int length; Tcl_Obj **elemPtrs; /* - * Convert each element of the list to string form and then convert it to - * proper list element form, adding it to the result buffer. + * Mark the list as being canonical; although it will now have a string + * rep, it is one we derived through proper "canonical" quoting and so + * it's known to be free from nasties relating to [concat] and [eval]. */ + listRepPtr->canonicalFlag = 1; + + /* + * Handle empty list case first, so rest of the routine is simpler. + */ + + if (numElems == 0) { + listPtr->bytes = tclEmptyStringRep; + listPtr->length = 0; + return; + } + /* * Pass 1: estimate space, gather flags. */ @@ -1885,54 +1952,44 @@ UpdateStringOfList( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int)); + /* + * We know numElems <= LIST_MAX, so this is safe. + */ + + flagPtr = ckalloc(numElems * sizeof(int)); } - listPtr->length = 1; elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { + flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); - listPtr->length += Tcl_ScanCountedElement(elem, length, flagPtr+i)+1; - - /* - * Check for continued sanity. [Bug 1267380] - */ - - if (listPtr->length < 1) { - Tcl_Panic("string representation size exceeds sane bounds"); + bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - listPtr->bytes = ckalloc((unsigned) listPtr->length); + listPtr->length = bytesNeeded - 1; + listPtr->bytes = ckalloc(bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { + flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); - *dst = ' '; - dst++; + dst += TclConvertElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; } + listPtr->bytes[listPtr->length] = '\0'; + if (flagPtr != localFlags) { - ckfree((char *) flagPtr); + ckfree(flagPtr); } - if (dst == listPtr->bytes) { - *dst = 0; - } else { - dst--; - *dst = 0; - } - listPtr->length = dst - listPtr->bytes; - - /* - * Mark the list as being canonical; although it has a string rep, it is - * one we derived through proper "canonical" quoting and so it's known to - * be free from nasties relating to [concat] and [eval]. - */ - - listRepPtr->canonicalFlag = 1; } /* diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index b991ef3..441ea91 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLiteral.c,v 1.43 2010/04/29 23:39:32 msofer Exp $ */ #include "tclInt.h" @@ -77,78 +75,6 @@ TclInitLiteralTable( /* *---------------------------------------------------------------------- * - * TclCleanupLiteralTable -- - * - * This function frees the internal representation of every literal in a - * literal table. It is called prior to deleting an interp, so that - * variable refs will be cleaned up properly. - * - * Results: - * None. - * - * Side effects: - * Each literal in the table has its internal representation freed. - * - *---------------------------------------------------------------------- - */ - -void -TclCleanupLiteralTable( - Tcl_Interp *interp, /* Interpreter containing literals to purge */ - LiteralTable *tablePtr) /* Points to the literal table being - * cleaned. */ -{ - int i; - LiteralEntry *entryPtr; /* Pointer to the current entry in the hash - * table of literals. */ - LiteralEntry *nextPtr; /* Pointer to the next entry in the bucket. */ - Tcl_Obj *objPtr; /* Pointer to a literal object whose internal - * rep is being freed. */ - const Tcl_ObjType *typePtr; /* Pointer to the object's type. */ - int didOne; /* Flag for whether we've removed a literal in - * the current bucket. */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable((Interp *) interp); -#endif /* TCL_COMPILE_DEBUG */ - - for (i=0 ; i<tablePtr->numBuckets ; i++) { - /* - * It is tempting simply to walk each hash bucket once and delete the - * internal representations of each literal in turn. It's also wrong. - * The problem is that freeing a literal's internal representation can - * delete other literals to which it refers, making nextPtr invalid. - * So each time we free an internal rep, we start its bucket over - * again. - */ - - do { - didOne = 0; - entryPtr = tablePtr->buckets[i]; - while (entryPtr != NULL) { - objPtr = entryPtr->objPtr; - nextPtr = entryPtr->nextPtr; - typePtr = objPtr->typePtr; - if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - if (objPtr->bytes == NULL) { - Tcl_Panic("%s: literal without a string rep", - "TclCleanupLiteralTable"); - } - objPtr->typePtr = NULL; - typePtr->freeIntRepProc(objPtr); - didOne = 1; - break; - } else { - entryPtr = nextPtr; - } - } - } while (didOne); - } -} - -/* - *---------------------------------------------------------------------- - * * TclDeleteLiteralTable -- * * This function frees up everything associated with a literal table @@ -201,7 +127,7 @@ TclDeleteLiteralTable( objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - ckfree((char *) entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } @@ -211,7 +137,7 @@ TclDeleteLiteralTable( */ if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree((char *) tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -285,7 +211,7 @@ TclCreateLiteral( *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } globalPtr->refCount++; return objPtr; @@ -293,7 +219,7 @@ TclCreateLiteral( } if (!newPtr) { if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } return NULL; } @@ -319,7 +245,7 @@ TclCreateLiteral( } #endif - globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; @@ -441,7 +367,7 @@ TclRegisterLiteral( || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG @@ -759,15 +685,14 @@ ExpandLocalLiteralArray( int i; if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *) - ckrealloc((char *)currArrayPtr, 2 * currBytes); + newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes); } else { /* * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes); + newArrayPtr = ckalloc(2 * currBytes); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -856,7 +781,7 @@ TclReleaseLiteral( } else { prevPtr->nextPtr = entryPtr->nextPtr; } - ckfree((char *) entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -978,8 +903,7 @@ RebuildLiteralTable( */ tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) - (tablePtr->numBuckets * sizeof(LiteralEntry *))); + tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; @@ -1008,7 +932,47 @@ RebuildLiteralTable( */ if (oldBuckets != tablePtr->staticBuckets) { - ckfree((char *) oldBuckets); + ckfree(oldBuckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateCmdLiteral -- + * + * Invalidate a command literal entry, if present in the literal hash + * tables, by resetting its internal representation. This invalidation + * leaves it in the literal tables and in existing literal arrays. As a + * result, existing references continue to work but we force a fresh + * command look-up upon the next use (see, in particular, + * TclSetCmdNameObj()). + * + * Results: + * None. + * + * Side effects: + * Resets the internal representation of the CmdName Tcl_Obj + * using TclFreeIntRep(). + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateCmdLiteral( + Tcl_Interp *interp, /* Interpreter for which to invalidate a + * command literal. */ + const char *name, /* Points to the start of the cmd literal + * name. */ + Namespace *nsPtr) /* The namespace for which to lookup and + * invalidate a cmd literal. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + strlen(name), -1, NULL, nsPtr, 0, NULL); + + if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); } } @@ -1070,7 +1034,7 @@ TclLiteralStats( * Print out the histogram and a few other pieces of information. */ - result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + result = ckalloc(NUM_COUNTERS*60 + 300); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 22f1c86..5cacab1 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoad.c,v 1.26 2010/05/19 08:23:09 nijtmans Exp $ */ #include "tclInt.h" @@ -133,9 +131,35 @@ Tcl_LoadObjCmd( const char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_UniChar ch; + unsigned len; + int index, flags = 0; + Tcl_Obj *const *savedobjv = objv; + static const char *const options[] = { + "-global", "-lazy", "--", NULL + }; + enum options { + LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST + }; + while (objc > 2) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (LOAD_GLOBAL == (enum options) index) { + flags |= TCL_LOAD_GLOBAL; + } else if (LOAD_LAZY == (enum options) index) { + flags |= TCL_LOAD_LAZY; + } else { + break; + } + } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -158,9 +182,10 @@ Tcl_LoadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -197,9 +222,9 @@ Tcl_LoadObjCmd( if (packageName == NULL) { namesMatch = 0; } else { - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); Tcl_DStringAppend(&pkgName, packageName, -1); - Tcl_DStringSetLength(&tmp, 0); + TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); @@ -210,7 +235,7 @@ Tcl_LoadObjCmd( namesMatch = 0; } } - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -224,9 +249,11 @@ Tcl_LoadObjCmd( * Can't have two different packages loaded from the same file. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" is already loaded for package \"", - pkgPtr->packageName, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" is already loaded for package \"%s\"", + fullFileName, pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "SPLITPERSONALITY", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -260,8 +287,10 @@ Tcl_LoadObjCmd( */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", packageName, - "\" isn't loaded statically", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" isn't loaded statically", packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", + NULL); code = TCL_ERROR; goto done; } @@ -281,8 +310,7 @@ Tcl_LoadObjCmd( retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { - Tcl_Obj *splitPtr; - Tcl_Obj *pkgGuessPtr; + Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; const char *pkgGuess; @@ -301,6 +329,12 @@ Tcl_LoadObjCmd( && (pkgGuess[2] == 'b')) { pkgGuess += 3; } +#ifdef __CYGWIN__ + if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y') + && (pkgGuess[2] == 'g')) { + pkgGuess += 3; + } +#endif /* __CYGWIN__ */ for (p = pkgGuess; *p != 0; p += offset) { offset = Tcl_UtfToUniChar(p, &ch); if ((ch > 0x100) @@ -311,13 +345,15 @@ Tcl_LoadObjCmd( } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); - Tcl_AppendResult(interp, - "couldn't figure out package name for ", - fullFileName, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't figure out package name for %s", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "WHATPACKAGE", NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } } @@ -336,14 +372,14 @@ Tcl_LoadObjCmd( * package name. */ - Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&initName, "_Init", 5); - Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&unloadName, "_Unload", 7); - Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); + TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendLiteral(&initName, "_Init"); + TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendLiteral(&safeInitName, "_SafeInit"); + TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendLiteral(&unloadName, "_Unload"); + TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* * Call platform-specific code to load the package and find the two @@ -354,7 +390,8 @@ Tcl_LoadObjCmd( symbols[1] = NULL; Tcl_MutexLock(&packageMutex); - code = Tcl_LoadFile(interp, objv[1], symbols, 0, &initProc, &loadHandle); + code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, + &loadHandle); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; @@ -364,22 +401,24 @@ Tcl_LoadObjCmd( * Create a new record to describe this package. */ - pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = - ckalloc((unsigned) (strlen(fullFileName) + 1)); - strcpy(pkgPtr->fileName, fullFileName); - pkgPtr->packageName = - ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); - strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); + pkgPtr = ckalloc(sizeof(LoadedPackage)); + len = strlen(fullFileName) + 1; + pkgPtr->fileName = ckalloc(len); + memcpy(pkgPtr->fileName, fullFileName, len); + len = (unsigned) Tcl_DStringLength(&pkgName) + 1; + pkgPtr->packageName = ckalloc(len); + memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc*) - Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) - Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeUnloadName)); + pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + Tcl_FindSymbol(interp, loadHandle, + Tcl_DStringValue(&safeInitName)); + pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) + Tcl_FindSymbol(interp, loadHandle, + Tcl_DStringValue(&unloadName)); + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + Tcl_FindSymbol(interp, loadHandle, + Tcl_DStringValue(&safeUnloadName)); pkgPtr->interpRefCount = 0; pkgPtr->safeInterpRefCount = 0; @@ -387,10 +426,12 @@ Tcl_LoadObjCmd( pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); + /* - * The Tcl_FindSymbol calls may have left a spurious error message - * in the interpreter result. + * The Tcl_FindSymbol calls may have left a spurious error message in + * the interpreter result. */ + Tcl_ResetResult(interp); } @@ -400,50 +441,64 @@ Tcl_LoadObjCmd( */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc != NULL) { - code = pkgPtr->safeInitProc(target); - } else { - Tcl_AppendResult(interp, - "can't use package in a safe interpreter: no ", - pkgPtr->packageName, "_SafeInit procedure", NULL); + if (pkgPtr->safeInitProc == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't use package in a safe interpreter: no" + " %s_SafeInit procedure", pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", + NULL); code = TCL_ERROR; goto done; } + code = pkgPtr->safeInitProc(target); } else { + if (pkgPtr->initProc == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't attach package to interpreter: no %s_Init procedure", + pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", + NULL); + code = TCL_ERROR; + goto done; + } code = pkgPtr->initProc(target); } /* - * Record the fact that the package has been loaded in the target - * interpreter. + * Test for whether the initialization failed. If so, transfer the error + * from the target interpreter to the originating one. */ - if (code == TCL_OK) { - /* - * Update the proper reference count. - */ - - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; - } else { - pkgPtr->interpRefCount++; - } - Tcl_MutexUnlock(&packageMutex); + if (code != TCL_OK) { + Tcl_TransferResult(target, code, interp); + goto done; + } - /* - * Refetch ipFirstPtr: loading the package may have introduced - * additional static packages at the head of the linked list! - */ + /* + * Record the fact that the package has been loaded in the target + * interpreter. + * + * Update the proper reference count. + */ - ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; - ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + pkgPtr->safeInterpRefCount++; } else { - Tcl_TransferResult(target, code, interp); + pkgPtr->interpRefCount++; } + Tcl_MutexUnlock(&packageMutex); + + /* + * Refetch ipFirstPtr: loading the package may have introduced additional + * static packages at the head of the linked list! + */ + + ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: Tcl_DStringFree(&pkgName); @@ -550,9 +605,10 @@ Tcl_UnloadObjCmd( } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -590,9 +646,9 @@ Tcl_UnloadObjCmd( if (packageName == NULL) { namesMatch = 0; } else { - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); Tcl_DStringAppend(&pkgName, packageName, -1); - Tcl_DStringSetLength(&tmp, 0); + TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); @@ -603,7 +659,7 @@ Tcl_UnloadObjCmd( namesMatch = 0; } } - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -622,8 +678,11 @@ Tcl_UnloadObjCmd( * It's an error to try unload a static package. */ - Tcl_AppendResult(interp, "package \"", packageName, - "\" is loaded statically and cannot be unloaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" is loaded statically and cannot be unloaded", + packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", + NULL); code = TCL_ERROR; goto done; } @@ -632,8 +691,10 @@ Tcl_UnloadObjCmd( * The DLL pointed by the provided filename has never been loaded. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded", fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -659,8 +720,11 @@ Tcl_UnloadObjCmd( * The package has not been loaded in this interpreter. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded in this interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded in this interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -673,16 +737,22 @@ Tcl_UnloadObjCmd( if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a safe interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a trusted interpreter", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -769,8 +839,7 @@ Tcl_UnloadObjCmd( */ if (pkgPtr->fileName[0] != '\0') { - - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&packageMutex); if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. @@ -812,16 +881,19 @@ Tcl_UnloadObjCmd( ipFirstPtr); ckfree(defaultPtr->fileName); ckfree(defaultPtr->packageName); - ckfree((char *) defaultPtr); - ckfree((char *) ipPtr); + ckfree(defaultPtr); + ckfree(ipPtr); Tcl_MutexUnlock(&packageMutex); } else { code = TCL_ERROR; } } #else - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: unloading disabled", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded: unloading disabled", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", + NULL); code = TCL_ERROR; #endif } @@ -829,40 +901,10 @@ Tcl_UnloadObjCmd( done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); - if (!complain && code!=TCL_OK) { + if (!complain && (code != TCL_OK)) { code = TCL_OK; Tcl_ResetResult(interp); } - if (code == TCL_OK) { -#if 0 - /* - * Result of [unload] was not documented in TIP#100, so force to be - * the empty string by commenting this out. DKF. - */ - - Tcl_Obj *resultObjPtr, *objPtr[2]; - - /* - * Our result is the two reference counts. - */ - - TclNewIntObj(objPtr[0], trustedRefCount); - TclNewIntObj(objPtr[1], safeRefCount); - if (objPtr[0] == NULL || objPtr[1] == NULL) { - if (objPtr[0]) { - Tcl_DecrRefCount(objPtr[0]); - } - if (objPtr[1]) { - Tcl_DecrRefCount(objPtr[1]); - } - } else { - TclNewListObj(resultObjPtr, 2, objPtr); - if (resultObjPtr != NULL) { - Tcl_SetObjResult(interp, resultObjPtr); - } - } -#endif - } return code; } @@ -927,10 +969,10 @@ Tcl_StaticPackage( */ if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = ckalloc((unsigned) 1); + pkgPtr = ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = ckalloc(1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = ckalloc((unsigned) (strlen(pkgName) + 1)); + pkgPtr->packageName = ckalloc(strlen(pkgName) + 1); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; @@ -960,7 +1002,7 @@ Tcl_StaticPackage( * loaded. */ - ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr = ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); @@ -997,28 +1039,27 @@ TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { - /* TODO: Use Tcl_Obj APIs to generate this info for cleanliness. */ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; - const char *prefix; + Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { /* * Return information about all of the available packages. */ - prefix = "{"; + resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - Tcl_AppendResult(interp, prefix, NULL); - Tcl_AppendElement(interp, pkgPtr->fileName); - Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", NULL); - prefix = " {"; + pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewListObj(2, pkgDesc)); } Tcl_MutexUnlock(&packageMutex); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1032,15 +1073,14 @@ TclGetLoadedPackages( return TCL_ERROR; } ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); - prefix = "{"; + resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; - Tcl_AppendResult(interp, prefix, NULL); - Tcl_AppendElement(interp, pkgPtr->fileName); - Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", NULL); - prefix = " {"; + pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1073,7 +1113,7 @@ LoadCleanupProc( ipPtr = clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; - ckfree((char *) ipPtr); + ckfree(ipPtr); ipPtr = nextPtr; } } @@ -1126,7 +1166,7 @@ TclFinalizeLoad(void) ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } } diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index dbb0a25..f030d89 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoadNone.c,v 1.14 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -41,14 +39,15 @@ TclpDlopen( Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ + int flags) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "dynamic loading is not currently available on this system", - TCL_STATIC); + -1)); return TCL_ERROR; } diff --git a/generic/tclMain.c b/generic/tclMain.c index b274f41..f445383 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -2,6 +2,11 @@ * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. + * This file contains a generic main program for Tcl shells and other + * Tcl-based applications. It can be used as-is for many applications, + * just by supplying a different appInitProc function for each specific + * application. Or, it can be used as a template for creating new main + * programs for Tcl applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -9,10 +14,24 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclMain.c,v 1.51 2010/09/23 18:08:35 dgp Exp $ */ +/* + * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN + * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing + * the same source code. + */ + +#if defined(TCL_ASCII_MAIN) +# ifdef UNICODE +# undef UNICODE +# undef _UNICODE +# else +# define UNICODE +# define _UNICODE +# endif +#endif + #include "tclInt.h" /* @@ -22,6 +41,40 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* + * This file can be compiled on Windows in UNICODE mode, as well as on all + * other platforms using the native encoding. This is done by using the normal + * Windows functions like _tcscmp, but on platforms which don't have <tchar.h> + * we have to translate that to strcmp here. + */ + +#ifndef __WIN32__ +# define TCHAR char +# define TEXT(arg) arg +# define _tcscmp strcmp +#endif + +/* + * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise + * NewNativeObj is needed (which provides proper conversion from native + * encoding to UTF-8). + */ + +#ifdef UNICODE +# define NewNativeObj Tcl_NewUnicodeObj +#else /* !UNICODE */ +static inline Tcl_Obj * +NewNativeObj( + char *string, + int length) +{ + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, string, length, &ds); + return TclDStringToObj(&ds); +} +#endif /* !UNICODE */ + +/* * Declarations for various library functions and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl * source directory to make their own modified versions). @@ -43,7 +96,6 @@ typedef struct { /* Any installed main loop handler. The main * extension that installs these is Tk. */ } ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; /* * Structure definition for information used to keep the state of an @@ -74,10 +126,14 @@ typedef struct InteractiveState { * Forward declarations for functions defined later in this file. */ -static Tcl_MainLoopProc * GetMainLoop(void); -static void Prompt(Tcl_Interp *interp, PromptType *promptPtr); +MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); +static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); +static void FreeMainInterp(ClientData clientData); +#ifndef TCL_ASCII_MAIN +static Tcl_ThreadDataKey dataKey; + /* *---------------------------------------------------------------------- * @@ -185,7 +241,7 @@ Tcl_SourceRCFile( { Tcl_DString temp; const char *fileName; - Tcl_Channel errChannel; + Tcl_Channel chan; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { @@ -209,10 +265,10 @@ Tcl_SourceRCFile( if (c != NULL) { Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } } @@ -220,10 +276,11 @@ Tcl_SourceRCFile( Tcl_DStringFree(&temp); } } +#endif /* !TCL_ASCII_MAIN */ /*---------------------------------------------------------------------- * - * Tcl_Main -- + * Tcl_Main, Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -240,28 +297,28 @@ Tcl_SourceRCFile( */ void -Tcl_Main( +Tcl_MainEx( int argc, /* Number of arguments. */ - char **argv, /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc) + TCHAR **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ + Tcl_Interp *interp) { - Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; + Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; - PromptType prompt = PROMPT_START; - int code, length, tty, exitCode = 0; + int code, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; - Tcl_Channel inChannel, outChannel, errChannel; - Tcl_Interp *interp; - Tcl_DString appName; - - Tcl_FindExecutable(argv[0]); + Tcl_Channel chan; + InteractiveState is; - interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); + is.interp = interp; + is.prompt = PROMPT_START; + is.commandPtr = Tcl_NewObj(); + /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and @@ -271,18 +328,21 @@ Tcl_Main( if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like - * -encoding ENCODING FILENAME + * -encoding ENCODING FILENAME * or like - * FILENAME + * FILENAME */ - if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) + if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { - Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); + Tcl_Obj *value = NewNativeObj(argv[2], -1); + Tcl_SetStartupScript(NewNativeObj(argv[3], -1), + Tcl_GetString(value)); + Tcl_DecrRefCount(value); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { - Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); + Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } @@ -290,16 +350,11 @@ Tcl_Main( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); + appName = NewNativeObj(argv[0], -1); } else { - const char *pathName = Tcl_GetStringFromObj(path, &length); - - Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); - path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); - Tcl_SetStartupScript(path, encodingName); + appName = path; } - Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); - Tcl_DStringFree(&appName); + Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; @@ -307,12 +362,7 @@ Tcl_Main( argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_DString ds; - - Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); - Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( - Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); @@ -320,9 +370,9 @@ Tcl_Main( * Set the "tcl_interactive" variable. */ - tty = isatty(0); - Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", - TCL_GLOBAL_ONLY); + is.tty = isatty(0); + Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, + Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. @@ -330,12 +380,12 @@ Tcl_Main( Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteChars(errChannel, + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteChars(chan, "application-specific initialization failed: ", -1); - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { @@ -344,18 +394,27 @@ Tcl_Main( if (Tcl_LimitExceeded(interp)) { goto done; } + if (TclFullFinalizationRequested()) { + /* + * Arrange for final deletion of the main interp + */ + + /* ARGH Munchhausen effect */ + Tcl_CreateExitHandler(FreeMainInterp, interp); + } /* - * If a script file was specified then just source that file and quit. - * Must fetch it again, as the appInitProc might have reset it. + * Invoke the script specified on the command line, if any. Must fetch it + * again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { + Tcl_ResetResult(interp); code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; @@ -365,9 +424,9 @@ Tcl_Main( Tcl_DecrRefCount(keyPtr); if (valuePtr) { - Tcl_WriteObj(errChannel, valuePtr); + Tcl_WriteObj(chan, valuePtr); } - Tcl_WriteChars(errChannel, "\n", 1); + Tcl_WriteChars(chan, "\n", 1); Tcl_DecrRefCount(options); } exitCode = 1; @@ -391,40 +450,40 @@ Tcl_Main( * may have been changed. */ - commandPtr = Tcl_NewObj(); - Tcl_IncrRefCount(commandPtr); + Tcl_IncrRefCount(is.commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ - Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) { - mainLoopProc = GetMainLoop(); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN); + is.input = Tcl_GetStdChannel(TCL_STDIN); + while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { + mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { - if (tty) { - Prompt(interp, &prompt); + int length; + + if (is.tty) { + Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } - inChannel = Tcl_GetStdChannel(TCL_STDIN); - if (inChannel == NULL) { + is.input = Tcl_GetStdChannel(TCL_STDIN); + if (is.input == NULL) { break; } } - if (Tcl_IsShared(commandPtr)) { - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_DuplicateObj(commandPtr); - Tcl_IncrRefCount(commandPtr); + if (Tcl_IsShared(is.commandPtr)) { + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_DuplicateObj(is.commandPtr); + Tcl_IncrRefCount(is.commandPtr); } - length = Tcl_GetsObj(inChannel, commandPtr); + length = Tcl_GetsObj(is.input, is.commandPtr); if (length < 0) { - if (Tcl_InputBlocked(inChannel)) { + if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. @@ -449,45 +508,46 @@ Tcl_Main( * a difference. [Bug 1775878] */ - if (Tcl_IsShared(commandPtr)) { - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_DuplicateObj(commandPtr); - Tcl_IncrRefCount(commandPtr); + if (Tcl_IsShared(is.commandPtr)) { + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_DuplicateObj(is.commandPtr); + Tcl_IncrRefCount(is.commandPtr); } - Tcl_AppendToObj(commandPtr, "\n", 1); - if (!TclObjCommandComplete(commandPtr)) { - prompt = PROMPT_CONTINUE; + Tcl_AppendToObj(is.commandPtr, "\n", 1); + if (!TclObjCommandComplete(is.commandPtr)) { + is.prompt = PROMPT_CONTINUE; continue; } - prompt = PROMPT_START; + is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(commandPtr, &length); - Tcl_SetObjLength(commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - errChannel = Tcl_GetStdChannel(TCL_STDERR); - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_NewObj(); - Tcl_IncrRefCount(commandPtr); + Tcl_GetStringFromObj(is.commandPtr, &length); + Tcl_SetObjLength(is.commandPtr, --length); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, + TCL_EVAL_GLOBAL); + is.input = Tcl_GetStdChannel(TCL_STDIN); + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } - } else if (tty) { + } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); - if ((length > 0) && outChannel) { - Tcl_WriteObj(outChannel, resultPtr); - Tcl_WriteChars(outChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDOUT); + if ((length > 0) && chan) { + Tcl_WriteObj(chan, resultPtr); + Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } @@ -498,65 +558,40 @@ Tcl_Main( * channel handler for stdin. */ - InteractiveState *isPtr = NULL; - - if (inChannel) { - if (tty) { - Prompt(interp, &prompt); + if (is.input) { + if (is.tty) { + Prompt(interp, &is); } - isPtr = (InteractiveState *) - ckalloc(sizeof(InteractiveState)); - isPtr->input = inChannel; - isPtr->tty = tty; - isPtr->commandPtr = commandPtr; - isPtr->prompt = prompt; - isPtr->interp = interp; - - Tcl_UnlinkVar(interp, "tcl_interactive"); - Tcl_LinkVar(interp, "tcl_interactive", (char *) &isPtr->tty, - TCL_LINK_BOOLEAN); - - Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, - isPtr); + + Tcl_CreateChannelHandler(is.input, TCL_READABLE, + StdinProc, &is); } mainLoopProc(); Tcl_SetMainLoop(NULL); - if (inChannel) { - tty = isPtr->tty; - Tcl_UnlinkVar(interp, "tcl_interactive"); - Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, - TCL_LINK_BOOLEAN); - prompt = isPtr->prompt; - commandPtr = isPtr->commandPtr; - if (isPtr->input != NULL) { - Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr); - } - ckfree((char *) isPtr); + if (is.input) { + Tcl_DeleteChannelHandler(is.input, StdinProc, &is); } - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - errChannel = Tcl_GetStdChannel(TCL_STDERR); + is.input = Tcl_GetStdChannel(TCL_STDIN); } -#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ +#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } -#endif +#endif /* TCL_MEM_DEBUG */ } done: - mainLoopProc = GetMainLoop(); - if ((exitCode == 0) && (mainLoopProc != NULL) - && !Tcl_LimitExceeded(interp)) { + mainLoopProc = TclGetMainLoop(); + if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at @@ -566,8 +601,8 @@ Tcl_Main( mainLoopProc(); Tcl_SetMainLoop(NULL); } - if (commandPtr != NULL) { - Tcl_DecrRefCount(commandPtr); + if (is.commandPtr != NULL) { + Tcl_DecrRefCount(is.commandPtr); } /* @@ -576,37 +611,42 @@ Tcl_Main( * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp)) { - if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); - } - - /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual - * is happening. Maybe interp has been deleted; maybe [exit] was - * redefined, maybe we've blown up because of an exceeded limit. We - * still want to cleanup and exit. - */ - - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); } - Tcl_SetStartupScript(NULL, NULL); /* - * If we get here, the master interp has been deleted. Allow its - * destruction with the last matching Tcl_Release. + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is + * happening. Maybe interp has been deleted; maybe [exit] was redefined, + * maybe we've blown up because of an exceeded limit. We still want to + * cleanup and exit. */ - Tcl_Release(interp); 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_FindExecutable(argv[0]); + Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); +} +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ +#ifndef TCL_ASCII_MAIN + /* *--------------------------------------------------------------- * @@ -636,7 +676,7 @@ Tcl_SetMainLoop( /* *--------------------------------------------------------------- * - * GetMainLoop -- + * TclGetMainLoop -- * * Returns the current alternative main loop function. * @@ -652,8 +692,8 @@ Tcl_SetMainLoop( *--------------------------------------------------------------- */ -static Tcl_MainLoopProc * -GetMainLoop(void) +Tcl_MainLoopProc * +TclGetMainLoop(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -663,6 +703,44 @@ GetMainLoop(void) /* *---------------------------------------------------------------------- * + * TclFullFinalizationRequested -- + * + * This function returns true when either -DPURIFY is specified, or the + * environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This + * predicate is called at places affecting the exit sequence, so that the + * default behavior is a fast and deadlock-free exit, and the modified + * behavior is a more thorough finalization for debugging purposes (leak + * hunting etc). + * + * Results: + * A boolean. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclFullFinalizationRequested(void) +{ +#ifdef PURIFY + return 1; +#else + const char *fin; + Tcl_DString ds; + int finalize = 0; + + fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds); + finalize = ((fin != NULL) && strcmp(fin, "0")); + if (fin != NULL) { + Tcl_DStringFree(&ds); + } + return finalize; +#endif /* PURIFY */ +} +#endif /* !TCL_ASCII_MAIN */ + +/* + *---------------------------------------------------------------------- + * * StdinProc -- * * This function is invoked by the event dispatcher whenever standard @@ -685,11 +763,11 @@ StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { + int code, length; InteractiveState *isPtr = clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; - int code, length; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); @@ -745,21 +823,21 @@ StdinProc( Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); } if (code != TCL_OK) { - Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + chan = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + if (chan != NULL) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); + chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); - if ((length >0) && (outChannel != NULL)) { - Tcl_WriteObj(outChannel, resultPtr); - Tcl_WriteChars(outChannel, "\n", 1); + if ((length > 0) && (chan != NULL)) { + Tcl_WriteObj(chan, resultPtr); + Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } @@ -770,7 +848,7 @@ StdinProc( prompt: if (isPtr->tty && (isPtr->input != NULL)) { - Prompt(interp, &isPtr->prompt); + Prompt(interp, isPtr); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } } @@ -795,20 +873,19 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - PromptType *promptPtr) /* Points to type of prompt to print. Filled - * with PROMPT_NONE after a prompt is - * printed. */ + InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE + * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; - Tcl_Channel outChannel, errChannel; + Tcl_Channel chan; - if (*promptPtr == PROMPT_NONE) { + if (isPtr->prompt == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -816,30 +893,58 @@ Prompt( } if (promptCmdPtr == NULL) { defaultPrompt: - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - if ((*promptPtr == PROMPT_START) && (outChannel != NULL)) { - Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, - strlen(DEFAULT_PRIMARY_PROMPT)); + if (isPtr->prompt == PROMPT_START) { + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != NULL) { + Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, + strlen(DEFAULT_PRIMARY_PROMPT)); + } } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != NULL) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } goto defaultPrompt; } } - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - if (outChannel != NULL) { - Tcl_Flush(outChannel); + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != NULL) { + Tcl_Flush(chan); } - *promptPtr = PROMPT_NONE; + isPtr->prompt = PROMPT_NONE; +} + +/* + *---------------------------------------------------------------------- + * + * FreeMainInterp -- + * + * Exit handler used to cleanup the main interpreter and ancillary + * startup script storage at exit. + * + *---------------------------------------------------------------------- + */ + +static void +FreeMainInterp( + ClientData clientData) +{ + Tcl_Interp *interp = clientData; + + /*if (TclInExit()) return;*/ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } + Tcl_SetStartupScript(NULL, NULL); + Tcl_Release(interp); } /* diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6961fd5..02d517f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,12 +21,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclNamesp.c,v 1.212 2010/08/30 14:02:10 msofer Exp $ */ #include "tclInt.h" -#include "tclCompile.h" /* just for NRCommand */ +#include "tclCompile.h" /* for TclLogCommandInfo visibility */ /* * Thread-local storage used to avoid having a global lock on data that is not @@ -105,6 +103,8 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int NRNamespaceEvalCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, @@ -116,6 +116,8 @@ static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NRNamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, @@ -129,8 +131,7 @@ static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceUnknownCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -152,6 +153,34 @@ static const Tcl_ObjType nsNameType = { NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; + +/* + * Array of values describing how to implement each standard subcommand of the + * "namespace" command. + */ + +static const EnsembleImplMap defaultNamespaceMap[] = { + {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} +}; /* *---------------------------------------------------------------------- @@ -368,7 +397,7 @@ Tcl_PopCallFrame( if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - ckfree((char *) framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { @@ -394,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSpliceTailcall(interp, framePtr->tailcallPtr); } } @@ -658,9 +687,10 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": " - "only global namespace can have empty name", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -694,8 +724,10 @@ Tcl_CreateNamespace( Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } @@ -705,9 +737,10 @@ Tcl_CreateNamespace( * of namespaces created. */ - nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); - nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); - strcpy(nsPtr->name, simpleName); + nsPtr = ckalloc(sizeof(Namespace)); + nameLen = strlen(simpleName) + 1; + nsPtr->name = ckalloc(nameLen); + memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; @@ -769,10 +802,9 @@ Tcl_CreateNamespace( if (ancestorPtr != globalNsPtr) { register Tcl_DString *tempPtr = namePtr; - Tcl_DStringAppend(buffPtr, "::", 2); + TclDStringAppendLiteral(buffPtr, "::"); Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); - Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr), - Tcl_DStringLength(namePtr)); + TclDStringAppendDString(buffPtr, namePtr); /* * Clear the unwanted buffer or we end up appending to previous @@ -780,7 +812,7 @@ Tcl_CreateNamespace( * very wrong (and strange). */ - Tcl_DStringSetLength(namePtr, 0); + TclDStringClear(namePtr); /* * Now swap the buffer pointers so that we build in the other @@ -795,7 +827,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); + nsPtr->fullName = ckalloc(nameLen + 1); memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); Tcl_DStringFree(&buffer1); @@ -881,13 +913,13 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); - if (cmdPtr->nreProc == NRInterpCoroutine) { + cmdPtr = Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == TclNRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); } else { - entryPtr = entryPtr->nextPtr; + entryPtr = Tcl_NextHashEntry(&search); } } @@ -976,7 +1008,7 @@ Tcl_DeleteNamespace( #else if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); - ckfree((char *) nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); @@ -1140,7 +1172,7 @@ TclTeardownNamespace( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -1194,8 +1226,7 @@ NamespaceFree( ckfree(nsPtr->name); ckfree(nsPtr->fullName); - - ckfree((char *) nsPtr); + ckfree(nsPtr); } /* @@ -1287,7 +1318,7 @@ Tcl_Export( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; @@ -1304,8 +1335,9 @@ Tcl_Export( &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1334,8 +1366,7 @@ Tcl_Export( if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = (char **) - ckrealloc((char *) nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } @@ -1344,7 +1375,7 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = ckalloc((unsigned) (len + 1)); + patternCpy = ckalloc(len + 1); memcpy(patternCpy, pattern, (unsigned) len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; @@ -1511,6 +1542,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1518,20 +1550,22 @@ Tcl_Import( &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, - "no namespace specified in import pattern \"", pattern, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1631,7 +1665,7 @@ DoImport( Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, cmdName, -1); @@ -1649,16 +1683,18 @@ DoImport( dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } - dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); @@ -1672,7 +1708,7 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr = ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; @@ -1690,8 +1726,9 @@ DoImport( return TCL_OK; } } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -1759,9 +1796,9 @@ Tcl_ForgetImport( &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, - "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } @@ -1969,8 +2006,8 @@ DeleteImportedCmd( } else { prevPtr->nextPtr = refPtr->nextPtr; } - ckfree((char *) refPtr); - ckfree((char *) dataPtr); + ckfree(refPtr); + ckfree(dataPtr); return; } prevPtr = refPtr; @@ -2203,7 +2240,7 @@ TclGetNamespaceForQualName( * qualName since it may be a string constant. */ - Tcl_DStringSetLength(&buffer, 0); + TclDStringClear(&buffer); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } @@ -2365,8 +2402,8 @@ Tcl_FindNamespace( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; @@ -2552,8 +2589,8 @@ Tcl_FindCommand( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; @@ -2743,7 +2780,7 @@ TclGetNamespaceFromObj( * Get the current namespace name. */ - NamespaceCurrentCmd(NULL, interp, 2, NULL); + NamespaceCurrentCmd(NULL, interp, 1, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "namespace \"%s\" not found in \"%s\"", name, Tcl_GetStringResult(interp))); @@ -2770,18 +2807,18 @@ GetNamespaceFromObj( * cross interps. */ - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + 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))))) { + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } @@ -2791,132 +2828,25 @@ GetNamespaceFromObj( /* *---------------------------------------------------------------------- * - * Tcl_NamespaceObjCmd -- + * TclInitNamespaceCmd -- * - * Invoked to implement the "namespace" command that creates, deletes, or - * manipulates Tcl namespaces. Handles the following syntax: - * - * namespace children ?name? ?pattern? - * namespace code arg - * namespace current - * namespace delete ?name name...? - * namespace ensemble subcommand ?arg...? - * namespace eval name arg ?arg...? - * namespace exists name - * namespace export ?-clear? ?pattern pattern...? - * namespace forget ?pattern pattern...? - * namespace import ?-force? ?pattern pattern...? - * namespace inscope name arg ?arg...? - * namespace origin name - * namespace parent ?name? - * namespace qualifiers string - * namespace tail string - * namespace which ?-command? ?-variable? name + * This function is called to create the "namespace" Tcl command. See the + * user documentation for details on what it does. * * Results: - * Returns TCL_OK if the command is successful. Returns TCL_ERROR if - * anything goes wrong. + * Handle for the namespace command, or NULL on failure. * * Side effects: - * Based on the subcommand name (e.g., "import"), this function - * dispatches to a corresponding function NamespaceXXXCmd defined - * statically in this file. This function's side effects depend on - * whatever that subcommand function does. If there is an error, this - * function returns an error message in the interpreter's result object. - * Otherwise it may return a result in the interpreter's result object. + * none * *---------------------------------------------------------------------- */ -int -Tcl_NamespaceObjCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, - objv); -} - -int -TclNRNamespaceObjCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_Command +TclInitNamespaceCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static const char *const subCmds[] = { - "children", "code", "current", "delete", "ensemble", - "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "path", "qualifiers", - "tail", "unknown", "upvar", "which", NULL - }; - enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, - NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, - NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx - }; - int index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; - } - - /* - * Return an index reflecting the particular subcommand. - */ - - if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", /*flags*/ 0, - (int *) &index) != TCL_OK) { - return TCL_ERROR; - } - - switch (index) { - case NSChildrenIdx: - return NamespaceChildrenCmd(clientData, interp, objc, objv); - case NSCodeIdx: - return NamespaceCodeCmd(clientData, interp, objc, objv); - case NSCurrentIdx: - return NamespaceCurrentCmd(clientData, interp, objc, objv); - case NSDeleteIdx: - return NamespaceDeleteCmd(clientData, interp, objc, objv); - case NSEnsembleIdx: - return TclNamespaceEnsembleCmd(clientData, interp, objc, objv); - case NSEvalIdx: - return NamespaceEvalCmd(clientData, interp, objc, objv); - case NSExistsIdx: - return NamespaceExistsCmd(clientData, interp, objc, objv); - case NSExportIdx: - return NamespaceExportCmd(clientData, interp, objc, objv); - case NSForgetIdx: - return NamespaceForgetCmd(clientData, interp, objc, objv); - case NSImportIdx: - return NamespaceImportCmd(clientData, interp, objc, objv); - case NSInscopeIdx: - return NamespaceInscopeCmd(clientData, interp, objc, objv); - case NSOriginIdx: - return NamespaceOriginCmd(clientData, interp, objc, objv); - case NSParentIdx: - return NamespaceParentCmd(clientData, interp, objc, objv); - case NSPathIdx: - return NamespacePathCmd(clientData, interp, objc, objv); - case NSQualifiersIdx: - return NamespaceQualifiersCmd(clientData, interp, objc, objv); - case NSTailIdx: - return NamespaceTailCmd(clientData, interp, objc, objv); - case NSUpvarIdx: - return NamespaceUpvarCmd(clientData, interp, objc, objv); - case NSUnknownIdx: - return NamespaceUnknownCmd(clientData, interp, objc, objv); - case NSWhichIdx: - return NamespaceWhichCmd(clientData, interp, objc, objv); - default: - Tcl_Panic("unhandled namespace subcommand"); - } - return TCL_ERROR; + return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap); } /* @@ -2960,15 +2890,15 @@ NamespaceChildrenCmd( * Get a pointer to the specified namespace, or the current namespace. */ - if (objc == 2) { + if (objc == 1) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } else if ((objc == 3) || (objc == 4)) { - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK){ + } else if ((objc == 2) || (objc == 3)) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){ return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?"); return TCL_ERROR; } @@ -2977,15 +2907,15 @@ NamespaceChildrenCmd( */ Tcl_DStringInit(&buffer); - if (objc == 4) { - const char *name = TclGetString(objv[3]); + if (objc == 3) { + const char *name = TclGetString(objv[2]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer, "::", 2); + TclDStringAppendLiteral(&buffer, "::"); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); @@ -3078,31 +3008,27 @@ NamespaceCodeCmd( { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register const char *arg, *p; + register const char *arg; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. + * Take care to only check for scoping in precisely the style that + * [::namespace code] generates it. Anything more forgiving can have + * the effect of failing in namespaces that contain their own custom + " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[2], &length); - while (*arg == ':') { - arg++; - length--; - } - if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { - for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { - /* empty body: skip over whitespace */ - } - if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { - Tcl_SetObjResult(interp, objv[2]); - return TCL_OK; - } + arg = TclGetStringFromObj(objv[1], &length); + if (*arg==':' && length > 20 + && strncmp(arg, "::namespace inscope ", 20) == 0) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } /* @@ -3127,7 +3053,7 @@ NamespaceCodeCmd( } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objv[2]); + Tcl_ListObjAppendElement(interp, listPtr, objv[1]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -3163,8 +3089,8 @@ NamespaceCurrentCmd( { register Namespace *currNsPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -3228,8 +3154,8 @@ NamespaceDeleteCmd( const char *name; register int i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); return TCL_ERROR; } @@ -3239,14 +3165,14 @@ NamespaceDeleteCmd( * command line are valid, and report any errors. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[i]), - "\" in namespace delete command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; @@ -3257,7 +3183,7 @@ NamespaceDeleteCmd( * Okay, now delete each namespace. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); if (namespacePtr) { @@ -3296,6 +3222,17 @@ NamespaceDeleteCmd( static int NamespaceEvalCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, + objv); +} + +static int +NRNamespaceEvalCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3309,8 +3246,8 @@ NamespaceEvalCmd( Tcl_Obj *objPtr; int result; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3319,14 +3256,14 @@ NamespaceEvalCmd( * namespace object along the way. */ - result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + result = GetNamespaceFromObj(interp, objv[1], &namespacePtr); /* * If the namespace wasn't found, try to create it. */ if (result == TCL_ERROR) { - const char *name = TclGetString(objv[2]); + const char *name = TclGetString(objv[1]); namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); if (namespacePtr == NULL) { @@ -3347,15 +3284,21 @@ NamespaceEvalCmd( return TCL_ERROR; } - framePtr->objc = objc; - framePtr->objv = objv; + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } - if (objc == 4) { + if (objc == 3) { /* * TIP #280: Make actual argument location available to eval'd script. */ - objPtr = objv[3]; + objPtr = objv[2]; invoker = iPtr->cmdFramePtr; word = 3; TclArgumentGet(interp, objPtr, &invoker, &word); @@ -3366,7 +3309,7 @@ NamespaceEvalCmd( * object when it decrements its refcount after eval'ing it. */ - objPtr = Tcl_ConcatObj(objc-3, objv+3); + objPtr = Tcl_ConcatObj(objc-2, objv+2); invoker = NULL; word = 0; } @@ -3439,13 +3382,13 @@ NamespaceExistsCmd( { Tcl_Namespace *namespacePtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); + GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3497,8 +3440,8 @@ NamespaceExportCmd( int resetListFirst = 0; int firstArg, patternCt, i, result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } @@ -3506,7 +3449,7 @@ NamespaceExportCmd( * Process the optional "-clear" argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { @@ -3520,9 +3463,9 @@ NamespaceExportCmd( * the namespace's current export pattern list. */ - patternCt = (objc - firstArg); + patternCt = objc - firstArg; if (patternCt == 0) { - if (firstArg > 2) { + if (firstArg > 1) { return TCL_OK; } else { /* @@ -3596,12 +3539,12 @@ NamespaceForgetCmd( const char *pattern; register int i, result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); return TCL_ERROR; } - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_ForgetImport(interp, NULL, pattern); if (result != TCL_OK) { @@ -3663,8 +3606,8 @@ NamespaceImportCmd( register int i, result; int firstArg; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -3672,7 +3615,7 @@ NamespaceImportCmd( * Skip over the optional "-force" as the first argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { @@ -3681,7 +3624,7 @@ NamespaceImportCmd( } } else { /* - * When objc == 2, command is just [namespace import]. Introspection + * When objc == 1, command is just [namespace import]. Introspection * form to return list of imported commands. */ @@ -3757,6 +3700,17 @@ NamespaceImportCmd( static int NamespaceInscopeCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, + objv); +} + +static int +NRNamespaceInscopeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3764,11 +3718,12 @@ NamespaceInscopeCmd( { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; + register Interp *iPtr = (Interp *) interp; int i, result; Tcl_Obj *cmdObjPtr; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3776,7 +3731,7 @@ NamespaceInscopeCmd( * Resolve the namespace reference. */ - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) { return TCL_ERROR; } @@ -3792,8 +3747,14 @@ NamespaceInscopeCmd( return result; } - framePtr->objc = objc; - framePtr->objv = objv; + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } /* * Execute the command. If there is just one argument, just treat it as a @@ -3802,21 +3763,21 @@ NamespaceInscopeCmd( * of extra arguments to form the command to evaluate. */ - if (objc == 4) { - cmdObjPtr = objv[3]; + if (objc == 3) { + cmdObjPtr = objv[2]; } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); - for (i = 4; i < objc; i++) { + for (i = 3; i < objc; i++) { if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ return TCL_ERROR; } } - concatObjv[0] = objv[3]; + concatObjv[0] = objv[2]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ @@ -3866,17 +3827,17 @@ NamespaceOriginCmd( Tcl_Command command, origCommand; Tcl_Obj *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - command = Tcl_GetCommandFromObj(interp, objv[2]); + command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[2]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); @@ -3926,14 +3887,14 @@ NamespaceParentCmd( { Tcl_Namespace *nsPtr; - if (objc == 2) { + if (objc == 1) { nsPtr = TclGetCurrentNamespace(interp); - } else if (objc == 3) { - if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + } else if (objc == 2) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); return TCL_ERROR; } @@ -3987,8 +3948,8 @@ NamespacePathCmd( Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); return TCL_ERROR; } @@ -3996,17 +3957,16 @@ NamespacePathCmd( * If no path is given, return the current path. */ - if (objc == 2) { - /* - * Not a very fast way to compute this, but easy to get right. - */ + if (objc == 1) { + Tcl_Obj *resultObj = Tcl_NewObj(); for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_AppendElement(interp, - nsPtr->commandPathArray[i].nsPtr->fullName); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -4014,7 +3974,7 @@ NamespacePathCmd( * There is a path given, so parse it into an array of namespace pointers. */ - if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { @@ -4070,7 +4030,7 @@ TclSetNsPath( Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ { if (pathLength != 0) { - NamespacePathEntry *tmpPathArray = (NamespacePathEntry *) + NamespacePathEntry *tmpPathArray = ckalloc(sizeof(NamespacePathEntry) * pathLength); int i; @@ -4139,7 +4099,7 @@ UnlinkNsPath( } } } - ckfree((char *) nsPtr->commandPathArray); + ckfree(nsPtr->commandPathArray); } /* @@ -4211,8 +4171,8 @@ NamespaceQualifiersCmd( register const char *name, *p; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4221,7 +4181,7 @@ NamespaceQualifiersCmd( * the last "::" qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4280,14 +4240,14 @@ NamespaceUnknownCmd( Tcl_Obj *resultPtr; int rc; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?script?"); return TCL_ERROR; } currNsPtr = TclGetCurrentNamespace(interp); - if (objc == 2) { + if (objc == 1) { /* * Introspection - return the current namespace handler. */ @@ -4298,9 +4258,9 @@ NamespaceUnknownCmd( } Tcl_SetObjResult(interp, resultPtr); } else { - rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]); if (rc == TCL_OK) { - Tcl_SetObjResult(interp, objv[2]); + Tcl_SetObjResult(interp, objv[1]); } return rc; } @@ -4465,8 +4425,8 @@ NamespaceTailCmd( { register const char *name, *p; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4475,7 +4435,7 @@ NamespaceTailCmd( * qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4526,17 +4486,17 @@ NamespaceUpvarCmd( Var *otherPtr, *arrayPtr; const char *myName; - if (objc < 3 || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "ns ?otherVar myVar ...?"); + if (objc < 2 || (objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?"); return TCL_ERROR; } - if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } - objc -= 3; - objv += 3; + objc -= 2; + objv += 2; for (; objc>0 ; objc-=2, objv+=2) { /* @@ -4601,16 +4561,16 @@ NamespaceWhichCmd( int lookupType = 0; Tcl_Obj *resultPtr; - if (objc < 3 || objc > 4) { + if (objc < 2 || objc > 3) { badArgs: - Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); + Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name"); return TCL_ERROR; - } else if (objc == 4) { + } else if (objc == 3) { /* * Look for a flag controlling the lookup. */ - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! @@ -4685,7 +4645,7 @@ FreeNsNameInternalRep( */ TclNsDecrRefCount(resNamePtr->nsPtr); - ckfree((char *) resNamePtr); + ckfree(resNamePtr); } objPtr->typePtr = NULL; } @@ -4753,8 +4713,13 @@ SetNsNameFromAny( const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - const char *name = TclGetString(objPtr); + const char *name; + + if (interp == NULL) { + return TCL_ERROR; + } + name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); @@ -4772,13 +4737,12 @@ SetNsNameFromAny( if (objPtr->typePtr == &nsNameType) { TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } return TCL_ERROR; } nsPtr->refCount++; - resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); + resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; @@ -4840,7 +4804,7 @@ TclGetNamespaceChildTable( return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; @@ -4850,31 +4814,37 @@ TclGetNamespaceChildTable( /* *---------------------------------------------------------------------- * - * Tcl_LogCommandInfo -- + * TclLogCommandInfo -- * * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo field to describe the command that - * was being executed when the error occurred. + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. When pc and + * tosPtr are non-NULL, conveying a bytecode execution "inner context", + * and the offending instruction is suitable, that inner context is + * recorded in errorStack. * * Results: * None. * * Side effects: - * Information about the command is added to errorInfo and the line - * number stored internally in the interpreter is set. + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void -Tcl_LogCommandInfo( +TclLogCommandInfo( Tcl_Interp *interp, /* Interpreter in which to log information. */ const char *script, /* First character in script containing * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length) /* Number of bytes in command (-1 means use + int length, /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ + const unsigned char *pc, /* Current pc of bytecode execution context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ { register const char *p; Interp *iPtr = (Interp *) interp; @@ -4891,55 +4861,55 @@ Tcl_LogCommandInfo( } if (command != NULL) { - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - if (length < 0) { - length = strlen(command); - } - overflow = (length > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + if (length < 0) { + length = strlen(command); + } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), (overflow ? limit : length), command, (overflow ? "..." : ""))); - varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); - if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { - /* - * Should not happen. - */ - - return; - } else { - Tcl_HashEntry *hPtr + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { + /* + * Should not happen. + */ + + return; + } else { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); - if (tracePtr->traceProc != EstablishErrorInfoTraces) { - /* - * The most recent trace set on ::errorInfo is not the one the - * core itself puts on last. This means some other code is + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is * tracing the variable, and the additional trace(s) might be * write traces that expect the timing of writes to * ::errorInfo that existed Tcl releases before 8.5. To * satisfy that compatibility need, we write the current * -errorinfo value to the ::errorInfo variable. - */ + */ - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); - } - } + } + } } /* @@ -4947,44 +4917,153 @@ Tcl_LogCommandInfo( */ if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); + } } if (!iPtr->framePtr->objc) { - /* special frame, nothing to report */ + /* + * Special frame, nothing to report. + */ } else if (iPtr->varFramePtr != iPtr->framePtr) { - /* uplevel case, [lappend errorstack UP $relativelevel] */ + /* + * uplevel case, [lappend errorstack UP $relativelevel] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { - /* normal case, [lappend errorstack CALL [info level 0]] */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + /* + * normal case, [lappend errorstack CALL [info level 0]] + */ + + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( iPtr->framePtr->objc, iPtr->framePtr->objv)); } } /* + *---------------------------------------------------------------------- + * + * TclErrorStackResetIf -- + * + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. + * + * Results: + * None. + * + * Side effects: + * Reset errorstack if it needs be, and in that case remember the + * passed-in error message as inner context. + * + *---------------------------------------------------------------------- + */ + +void +TclErrorStackResetIf( + Tcl_Interp *interp, + const char *msg, + int length) +{ + Interp *iPtr = (Interp *) interp; + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length) /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ +{ + TclLogCommandInfo(interp, script, command, length, NULL, NULL); +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 5f0483c..a6523fc 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -13,8 +13,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclNotify.c,v 1.31 2010/02/24 10:45:04 dkf Exp $ */ #include "tclInt.h" @@ -183,7 +181,7 @@ TclFinalizeNotifier(void) for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; - ckfree((char *) hold); + ckfree(hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; @@ -278,7 +276,7 @@ Tcl_CreateEventSource( * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -332,7 +330,7 @@ Tcl_DeleteEventSource( } else { prevPtr->nextPtr = sourcePtr->nextPtr; } - ckfree((char *) sourcePtr); + ckfree(sourcePtr); return; } } @@ -364,6 +362,7 @@ Tcl_QueueEvent( * TCL_QUEUE_MARK. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + QueueEvent(tsdPtr, evPtr, position); } @@ -413,7 +412,7 @@ Tcl_ThreadQueueEvent( if (tsdPtr) { QueueEvent(tsdPtr, evPtr, position); } else { - ckfree((char *) evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&listLock); } @@ -564,7 +563,7 @@ Tcl_DeleteEvents( hold = evPtr; evPtr = evPtr->nextPtr; - ckfree((char *) hold); + ckfree(hold); } else { /* * Event is to be retained. @@ -703,7 +702,7 @@ Tcl_ServiceEvent( } } if (evPtr) { - ckfree((char *) evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; diff --git a/generic/tclOO.c b/generic/tclOO.c index 820fee0..d6d2d6a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,12 +3,10 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOO.c,v 1.36 2010/03/05 15:32:16 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -30,27 +28,20 @@ static const struct { {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, - {"filter", TclOODefineFilterObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, - {"mixin", TclOODefineMixinObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, - {"superclass", TclOODefineSuperclassObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, - {"variable", TclOODefineVariablesObjCmd, 0}, {NULL, NULL, 0} }, objdefCmds[] = { {"class", TclOODefineClassObjCmd, 1}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, {"export", TclOODefineExportObjCmd, 1}, - {"filter", TclOODefineFilterObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, - {"mixin", TclOODefineMixinObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, {"unexport", TclOODefineUnexportObjCmd, 1}, - {"variable", TclOODefineVariablesObjCmd, 1}, {NULL, NULL, 0} }; @@ -81,7 +72,7 @@ static int FinalizeNext(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeObjectCall(ClientData data[], Tcl_Interp *interp, int result); -static void InitFoundation(Tcl_Interp *interp); +static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); static void MyDeleted(ClientData clientData); @@ -90,6 +81,7 @@ 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 SquelchCachedName(Object *oPtr); static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, @@ -131,11 +123,92 @@ static const DeclaredClassMethod objMethods[] = { {NULL, 0, {0, NULL, NULL, NULL, NULL}} }; -static char initScript[] = - "namespace eval ::oo { variable version " TCLOO_VERSION " };" - "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; -/* "tcl_findLibrary tcloo $oo::version $oo::version" */ -/* " tcloo.tcl OO_LIBRARY oo::library;"; */ +/* + * And for the oo::class constructor... + */ + +static const Tcl_MethodType classConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::class constructor", + TclOO_Class_Constructor, NULL, NULL +}; + +/* + * Scripted parts of TclOO. First, the master script (cannot be outside this + * file). + */ + +static const char *initScript = +"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +"namespace eval ::oo { variable version " TCLOO_VERSION " };" +"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +/* "tcl_findLibrary tcloo $oo::version $oo::version" */ +/* " tcloo.tcl OO_LIBRARY oo::library;"; */ + +/* + * The scripted part of the definitions of slots. + */ + +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;" +" }" +" }" +"}"; + +/* + * The actual definition of the variable holding the TclOO stub table. + */ MODULE_SCOPE const TclOOStubs tclOOStubs; @@ -145,6 +218,20 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define GetFoundation(interp) \ ((Foundation *)((Interp *)(interp))->objectFoundation) + +/* + * Macros to make inspecting into the guts of an object cleaner. + * + * The ocPtr parameter (only in these macros) is assumed to work fine with + * either an oPtr or a classPtr. Note that the roots oo::object and oo::class + * have _both_ their object and class flags tagged with ROOT_OBJECT and + * ROOT_CLASS respectively. + */ + +#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) +#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) +#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) /* * ---------------------------------------------------------------------- @@ -171,7 +258,9 @@ TclOOInit( * Build the core of the OO system. */ - InitFoundation(interp); + if (InitFoundation(interp) != TCL_OK) { + return TCL_ERROR; + } /* * Run our initialization script and, if that works, declare the package @@ -215,16 +304,17 @@ TclOOGetFoundation( * ---------------------------------------------------------------------- */ -static void +static int InitFoundation( Tcl_Interp *interp) { static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); - Foundation *fPtr = (Foundation *) ckalloc(sizeof(Foundation)); + Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; Tcl_DString buffer; + Command *cmdPtr; int i; /* @@ -246,17 +336,19 @@ InitFoundation( DeletedHelpersNamespace); fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; - fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); - fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1); - fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1); + TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); + TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); + TclNewLiteralStringObj(fPtr->destructorName, "<destructor>"); + TclNewLiteralStringObj(fPtr->clonedName, "<cloned>"); + TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); - Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, - TclOONRUpcatch, NULL, NULL); + Tcl_IncrRefCount(fPtr->clonedName); + Tcl_IncrRefCount(fPtr->defineName); Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", TclOOUnknownDefinition, NULL, NULL); - namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1); + TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); @@ -266,14 +358,14 @@ InitFoundation( Tcl_DStringInit(&buffer); for (i=0 ; defineCmds[i].name ; i++) { - Tcl_DStringAppend(&buffer, "::oo::define::", 14); + TclDStringAppendLiteral(&buffer, "::oo::define::"); Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); Tcl_DStringFree(&buffer); } for (i=0 ; objdefCmds[i].name ; i++) { - Tcl_DStringAppend(&buffer, "::oo::objdefine::", 17); + TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); @@ -293,11 +385,13 @@ InitFoundation( 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((char *) fPtr->objectCls->superclasses.list); + ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; fPtr->classCls->thisPtr->selfCls = fPtr->classCls; fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); AddRef(fPtr->objectCls->thisPtr); @@ -315,31 +409,28 @@ 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. - * - * The 0xDeadBeef is a special signal to the errorInfo logger that is used - * by constructors that stops it from generating extra error information - * that is confusing. */ - namePtr = Tcl_NewStringObj("new", -1); + TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); - - argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj( - "set script [list ::oo::define [self] $definitionScript];" - "lassign [::oo::UpCatch $script] msg opts\n" - "if {[dict get $opts -code] == 1} {" - " dict set opts -errorline 0xDeadBeef\n" - "}\n" - "return -options $opts $msg", -1); - fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, - fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); - Tcl_DecrRefCount(argsPtr); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); /* * Create non-object commands and plug ourselves into the Tcl [info] @@ -348,14 +439,26 @@ InitFoundation( Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, - NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, + NULL, NULL); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + TclOOSelfObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); TclOOInitInfo(interp); + + /* + * Now make the class of slots. + */ + + if (TclOODefineSlots(fPtr) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_Eval(interp, slotScript); } /* @@ -418,10 +521,12 @@ KillFoundation( DelRef(fPtr->objectCls->thisPtr); DelRef(fPtr->objectCls); - Tcl_DecrRefCount(fPtr->unknownMethodNameObj); - Tcl_DecrRefCount(fPtr->constructorName); - Tcl_DecrRefCount(fPtr->destructorName); - ckfree((char *) fPtr); + TclDecrRefCount(fPtr->unknownMethodNameObj); + TclDecrRefCount(fPtr->constructorName); + TclDecrRefCount(fPtr->destructorName); + TclDecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->defineName); + ckfree(fPtr); } /* @@ -455,7 +560,7 @@ AllocObject( CommandTrace *tracePtr; int creationEpoch, ignored; - oPtr = (Object *) ckalloc(sizeof(Object)); + oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* @@ -555,7 +660,7 @@ AllocObject( Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); - Tcl_DStringAppend(&buffer, "::", 2); + TclDStringAppendLiteral(&buffer, "::"); Tcl_DStringAppend(&buffer, nameStr, -1); oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); @@ -569,8 +674,7 @@ AllocObject( cmdPtr = (Command *) oPtr->command; cmdPtr->nreProc = PublicNRObjectCmd; - cmdPtr->tracePtr = tracePtr = (CommandTrace *) - ckalloc(sizeof(CommandTrace)); + cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; @@ -582,7 +686,7 @@ AllocObject( * a bottleneck in string manipulation. Another abstraction-buster. */ - cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); memset(cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", @@ -603,6 +707,27 @@ AllocObject( /* * ---------------------------------------------------------------------- * + * SquelchCachedName -- + * + * Encapsulates how to throw away a cached object name. Called from + * object rename traces and at object destruction. + * + * ---------------------------------------------------------------------- + */ + +static inline void +SquelchCachedName( + Object *oPtr) +{ + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * * MyDeleted -- * * This callback is triggered when the object's [my] command is deleted @@ -669,8 +794,7 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Class *clsPtr; - CallContext *contextPtr; + Foundation *fPtr = oPtr->fPtr; /* * If this is a rename and not a delete of the object, we just flush the @@ -678,10 +802,7 @@ ObjectRenamedTrace( */ if (flags & TCL_TRACE_RENAME) { - if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); - oPtr->cachedNameObj = NULL; - } + SquelchCachedName(oPtr); return; } @@ -702,17 +823,20 @@ ObjectRenamedTrace( */ AddRef(oPtr); + AddRef(fPtr->classCls); + AddRef(fPtr->objectCls); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr); oPtr->command = NULL; - oPtr->flags |= OBJECT_DELETED; - if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp) - || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) { - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, 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) { - int result; - Tcl_InterpState state; - contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; state = Tcl_SaveInterpState(interp, TCL_OK); @@ -731,25 +855,20 @@ ObjectRenamedTrace( * and nuke the namespace (which triggers the final crushing of the object * structure itself). * - * The class of classes needs some special care; if it is deleted (and + * 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 objects now as well. Due to the incestuous nature of those two + * 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)) { - if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) { - Tcl_DeleteCommandFromToken(interp, - oPtr->fPtr->classCls->thisPtr->command); - } else if (oPtr->flags & ROOT_CLASS) { - oPtr->fPtr->classCls = NULL; - } + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } - clsPtr = oPtr->classPtr; - if (clsPtr != NULL) { - AddRef(clsPtr); + if (oPtr->classPtr != NULL) { + AddRef(oPtr->classPtr); ReleaseClassContents(interp, oPtr); } @@ -761,9 +880,13 @@ ObjectRenamedTrace( if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { Tcl_DeleteNamespace(oPtr->namespacePtr); } - if (clsPtr) { - DelRef(clsPtr); + if (oPtr->classPtr) { + DelRef(oPtr->classPtr); } + DelRef(fPtr->classCls->thisPtr); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->classCls); + DelRef(fPtr->objectCls); DelRef(oPtr); } @@ -783,77 +906,128 @@ ReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { - int i, n; - Class *clsPtr = oPtr->classPtr, **list; - Object **insts; + FOREACH_HASH_DECLS; + int i; + Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; + Object *instancePtr; + Foundation *fPtr = oPtr->fPtr; + + /* + * Sanity check! + */ + + if (!Deleted(oPtr)) { + if (IsRootClass(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::class"); + } 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"); + } + } /* - * Must empty list before processing the members of the list so that - * things happen in the correct order even if something tries to play - * fast-and-loose. + * Lock a number of dependent objects until we've stopped putting our + * fingers in them. */ - list = clsPtr->mixinSubs.list; - n = clsPtr->mixinSubs.num; - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - clsPtr->mixinSubs.size = 0; - for (i=0 ; i<n ; i++) { - AddRef(list[i]); - AddRef(list[i]->thisPtr); + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (mixinSubclassPtr != NULL) { + AddRef(mixinSubclassPtr); + AddRef(mixinSubclassPtr->thisPtr); + } } - for (i=0 ; i<n ; i++) { - if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) { - list[i]->thisPtr->flags |= OBJECT_DELETED; - Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + FOREACH(subclassPtr, clsPtr->subclasses) { + if (subclassPtr != NULL && !IsRoot(subclassPtr)) { + AddRef(subclassPtr); + AddRef(subclassPtr->thisPtr); } - DelRef(list[i]->thisPtr); - DelRef(list[i]); } - if (list != NULL) { - ckfree((char *) list); + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + if (instancePtr != NULL && !IsRoot(instancePtr)) { + AddRef(instancePtr); + } + } } - list = clsPtr->subclasses.list; - n = clsPtr->subclasses.num; - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - clsPtr->subclasses.size = 0; - for (i=0 ; i<n ; i++) { - AddRef(list[i]); - AddRef(list[i]->thisPtr); - } - for (i=0 ; i<n ; i++) { - if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) { - list[i]->thisPtr->flags |= OBJECT_DELETED; - Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + /* + * Squelch classes that this class has been mixed into. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + if (mixinSubclassPtr == NULL) { + continue; } - DelRef(list[i]->thisPtr); - DelRef(list[i]); + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + DelRef(mixinSubclassPtr->thisPtr); + DelRef(mixinSubclassPtr); } - if (list != NULL) { - ckfree((char *) list); + if (clsPtr->mixinSubs.list != NULL) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; + clsPtr->mixinSubs.num = 0; } - insts = clsPtr->instances.list; - n = clsPtr->instances.num; - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - clsPtr->instances.size = 0; - for (i=0 ; i<n ; i++) { - AddRef(insts[i]); + /* + * Squelch subclasses of this class. + */ + + FOREACH(subclassPtr, clsPtr->subclasses) { + if (subclassPtr == NULL || IsRoot(subclassPtr)) { + continue; + } + if (!Deleted(subclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + DelRef(subclassPtr->thisPtr); + DelRef(subclassPtr); + } + if (clsPtr->subclasses.list != NULL) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.num = 0; } - for (i=0 ; i<n ; i++) { - if (!(insts[i]->flags & OBJECT_DELETED)) { - insts[i]->flags |= OBJECT_DELETED; - Tcl_DeleteCommandFromToken(interp, insts[i]->command); + + /* + * Squelch instances of this class (includes objects we're mixed into). + */ + + if (!IsRootClass(oPtr)) { + FOREACH(instancePtr, clsPtr->instances) { + if (instancePtr == NULL || IsRoot(instancePtr)) { + continue; + } + if (!Deleted(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + } + DelRef(instancePtr); } - DelRef(insts[i]); } - if (insts != NULL) { - ckfree((char *) insts); + 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. + */ + if (clsPtr->constructorChainPtr) { TclOODeleteChain(clsPtr->constructorChainPtr); clsPtr->constructorChainPtr = NULL; @@ -863,30 +1037,35 @@ ReleaseClassContents( clsPtr->destructorChainPtr = NULL; } if (clsPtr->classChainCache) { - FOREACH_HASH_DECLS; CallChain *callPtr; FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { TclOODeleteChain(callPtr); } Tcl_DeleteHashTable(clsPtr->classChainCache); - ckfree((char *) clsPtr->classChainCache); + ckfree(clsPtr->classChainCache); clsPtr->classChainCache = NULL; } + /* + * Squelch our filter list. + */ + if (clsPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } - ckfree((char *) clsPtr->filters.list); + ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } + /* + * Squelch our metadata. + */ if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH_DECLS; Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; @@ -894,7 +1073,7 @@ ReleaseClassContents( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree((char *) clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } } @@ -922,7 +1101,7 @@ ObjectNamespaceDeleted( Class *clsPtr = oPtr->classPtr, *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int i, preserved = !(oPtr->flags & OBJECT_DELETED); + int i; /* * Instruct everyone to no longer use any allocated fields of the object. @@ -931,27 +1110,19 @@ ObjectNamespaceDeleted( * point into freed memory, allowing crashes. */ - oPtr->flags |= OBJECT_DELETED; if (oPtr->command) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } - if (preserved) { - AddRef(oPtr); - if (clsPtr != NULL) { - AddRef(clsPtr); - ReleaseClassContents(NULL, oPtr); - } - } /* * Splice the object out of its context. After this, we must *not* call * methods on the object. */ - if (!(oPtr->flags & ROOT_OBJECT)) { + if (!IsRootObject(oPtr)) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); } @@ -959,14 +1130,14 @@ ObjectNamespaceDeleted( TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { - ckfree((char *) oPtr->mixins.list); + ckfree(oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { - ckfree((char *) oPtr->filters.list); + ckfree(oPtr->filters.list); } if (oPtr->methodsPtr) { @@ -974,24 +1145,21 @@ ObjectNamespaceDeleted( TclOODelMethodRef(mPtr); } Tcl_DeleteHashTable(oPtr->methodsPtr); - ckfree((char *) oPtr->methodsPtr); + ckfree(oPtr->methodsPtr); } FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { - ckfree((char *) oPtr->variables.list); + ckfree(oPtr->variables.list); } if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } - if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); - oPtr->cachedNameObj = NULL; - } + SquelchCachedName(oPtr); if (oPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; @@ -1001,60 +1169,59 @@ ObjectNamespaceDeleted( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(oPtr->metadataPtr); - ckfree((char *) oPtr->metadataPtr); + ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } if (clsPtr != NULL) { Class *superPtr; + Tcl_ObjectMetadataType *metadataTypePtr; + ClientData value; if (clsPtr->metadataPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree((char *) clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { - ckfree((char *) clsPtr->filters.list); + ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } FOREACH(mixinPtr, clsPtr->mixins) { - if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) { + if (!Deleted(mixinPtr->thisPtr)) { TclOORemoveFromMixinSubs(clsPtr, mixinPtr); } } if (i) { - ckfree((char *) clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); clsPtr->mixins.num = 0; } FOREACH(superPtr, clsPtr->superclasses) { - if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) { + if (!Deleted(superPtr->thisPtr)) { TclOORemoveFromSubclasses(clsPtr, superPtr); } } if (i) { - ckfree((char *) clsPtr->superclasses.list); + ckfree(clsPtr->superclasses.list); clsPtr->superclasses.num = 0; } if (clsPtr->subclasses.list) { - ckfree((char *) clsPtr->subclasses.list); + ckfree(clsPtr->subclasses.list); clsPtr->subclasses.num = 0; } if (clsPtr->instances.list) { - ckfree((char *) clsPtr->instances.list); + ckfree(clsPtr->instances.list); clsPtr->instances.num = 0; } if (clsPtr->mixinSubs.list) { - ckfree((char *) clsPtr->mixinSubs.list); + ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.num = 0; } @@ -1066,10 +1233,10 @@ ObjectNamespaceDeleted( TclOODelMethodRef(clsPtr->destructorPtr); FOREACH(variableObj, clsPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { - ckfree((char *) clsPtr->variables.list); + ckfree(clsPtr->variables.list); } DelRef(clsPtr); @@ -1080,12 +1247,6 @@ ObjectNamespaceDeleted( */ DelRef(oPtr); - if (preserved) { - if (clsPtr) { - DelRef(clsPtr); - } - DelRef(oPtr); - } } /* @@ -1116,12 +1277,16 @@ TclOORemoveFromInstances( return; removeInstance: - clsPtr->instances.num--; - if (i < clsPtr->instances.num) { - clsPtr->instances.list[i] = - clsPtr->instances.list[clsPtr->instances.num]; + if (Deleted(clsPtr->thisPtr)) { + clsPtr->instances.list[i] = NULL; + } else { + clsPtr->instances.num--; + if (i < clsPtr->instances.num) { + clsPtr->instances.list[i] = + clsPtr->instances.list[clsPtr->instances.num]; + } + clsPtr->instances.list[clsPtr->instances.num] = NULL; } - clsPtr->instances.list[clsPtr->instances.num] = NULL; } /* @@ -1142,14 +1307,15 @@ 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) { - clsPtr->instances.list = (Object **) - ckalloc(sizeof(Object *) * ALLOC_CHUNK); + clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK); } else { - clsPtr->instances.list = (Object **) - ckrealloc((char *) clsPtr->instances.list, + clsPtr->instances.list = ckrealloc(clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } @@ -1184,12 +1350,16 @@ TclOORemoveFromSubclasses( return; removeSubclass: - superPtr->subclasses.num--; - if (i < superPtr->subclasses.num) { - superPtr->subclasses.list[i] = - superPtr->subclasses.list[superPtr->subclasses.num]; + if (Deleted(superPtr->thisPtr)) { + superPtr->subclasses.list[i] = NULL; + } else { + superPtr->subclasses.num--; + if (i < superPtr->subclasses.num) { + superPtr->subclasses.list[i] = + superPtr->subclasses.list[superPtr->subclasses.num]; + } + superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } /* @@ -1210,14 +1380,15 @@ TclOOAddToSubclasses( * is assumed that the class is not already * present as a subclass in the superclass. */ { + if (Deleted(superPtr->thisPtr)) { + return; + } if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = (Class **) - ckalloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = (Class **) - ckrealloc((char *) superPtr->subclasses.list, + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } @@ -1252,12 +1423,16 @@ TclOORemoveFromMixinSubs( return; removeSubclass: - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + if (Deleted(superPtr->thisPtr)) { + superPtr->mixinSubs.list[i] = NULL; + } else { + superPtr->mixinSubs.num--; + if (i < superPtr->mixinSubs.num) { + superPtr->mixinSubs.list[i] = + superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + } + superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } /* @@ -1278,14 +1453,15 @@ TclOOAddToMixinSubs( * is assumed that the class is not already * present as a subclass in the superclass. */ { + if (Deleted(superPtr->thisPtr)) { + return; + } if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { superPtr->mixinSubs.size += ALLOC_CHUNK; if (superPtr->mixinSubs.size == ALLOC_CHUNK) { - superPtr->mixinSubs.list = (Class **) - ckalloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->mixinSubs.list = (Class **) - ckrealloc((char *) superPtr->mixinSubs.list, + superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } @@ -1312,7 +1488,7 @@ AllocClass( * (with automatic name) is to be used. */ { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = (Class *) ckalloc(sizeof(Class)); + Class *clsPtr = ckalloc(sizeof(Class)); /* * Make an object if we haven't been given one. @@ -1353,7 +1529,7 @@ AllocClass( */ clsPtr->superclasses.num = 1; - clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *)); + clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; /* @@ -1408,8 +1584,10 @@ Tcl_NewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + 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; } @@ -1449,16 +1627,23 @@ Tcl_NewObjectInstance( TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr != NULL) { - int result, flags; + int result; Tcl_InterpState state; - AddRef(oPtr); state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp*) interp)->ensembleRewrite.sourceObjs) { + ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; + ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; + } result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); - flags = oPtr->flags; /* * It's an error if the object was whacked in the constructor. @@ -1466,13 +1651,13 @@ Tcl_NewObjectInstance( * errors by accident...) [Bug 2903011] */ - if (result != TCL_ERROR && (flags & OBJECT_DELETED)) { - Tcl_SetResult(interp, "object deleted in constructor", - TCL_STATIC); + 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); - DelRef(oPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1481,7 +1666,7 @@ Tcl_NewObjectInstance( * bad. [Bug 2903011] */ - if (!(flags & OBJECT_DELETED)) { + if (!Deleted(oPtr)) { Tcl_DeleteCommandFromToken(interp, oPtr->command); } return NULL; @@ -1523,8 +1708,10 @@ TclNRNewObjectInstance( if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, TCL_NAMESPACE_ONLY)) { - Tcl_AppendResult(interp, "can't create object \"", nameStr, - "\": command already exists with that name", NULL); + 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 TCL_ERROR; } @@ -1569,15 +1756,24 @@ TclNRNewObjectInstance( return TCL_OK; } - AddRef(oPtr); state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp *) interp)->ensembleRewrite.sourceObjs) { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; + ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + } + + /* * Fire off the constructors non-recursively. */ + AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); @@ -1594,7 +1790,6 @@ FinalizeAlloc( Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; - int flags = oPtr->flags; /* * It's an error if the object was whacked in the constructor. Force this @@ -1602,12 +1797,13 @@ FinalizeAlloc( * [Bug 2903011] */ - if (result != TCL_ERROR && (flags & OBJECT_DELETED)) { - Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC); + 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); - DelRef(oPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1616,13 +1812,15 @@ FinalizeAlloc( * 2903011] */ - if (!(flags & OBJECT_DELETED)) { + if (!Deleted(oPtr)) { Tcl_DeleteCommandFromToken(interp, oPtr->command); } + DelRef(oPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; + DelRef(oPtr); return TCL_OK; } @@ -1649,20 +1847,18 @@ Tcl_CopyObjectInstance( FOREACH_HASH_DECLS; Method *mPtr; Class *mixinPtr; - Tcl_Obj *keyPtr, *filterObj; - int i; + CallContext *contextPtr; + Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + int i, result; /* - * Sanity checks. + * Sanity check. */ - if (targetName == NULL && oPtr->classPtr != NULL) { - Tcl_AppendResult(interp, "must supply a name when copying a class", - NULL); - return NULL; - } - if (oPtr->flags & ROOT_CLASS) { - Tcl_AppendResult(interp, "may not clone the class of classes", NULL); + if (IsRootClass(oPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not clone the class of classes", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); return NULL; } @@ -1716,6 +1912,15 @@ Tcl_CopyObjectInstance( } /* + * Copy the object's variable resolution list to the new object. + */ + + DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); + FOREACH(variableObj, o2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* * 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 * it the root of the object system or in the midst of processing a filter @@ -1723,7 +1928,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING); + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. @@ -1775,11 +1980,10 @@ Tcl_CopyObjectInstance( TclOORemoveFromSubclasses(cls2Ptr, superPtr); } if (cls2Ptr->superclasses.num) { - cls2Ptr->superclasses.list = (Class **) - ckrealloc((char *) cls2Ptr->superclasses.list, + cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { - cls2Ptr->superclasses.list = (Class **) + cls2Ptr->superclasses.list = ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, @@ -1799,6 +2003,15 @@ Tcl_CopyObjectInstance( } /* + * Copy the source class's variable resolution list. + */ + + DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); + FOREACH(variableObj, cls2Ptr->variables) { + Tcl_IncrRefCount(variableObj); + } + + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ @@ -1807,7 +2020,7 @@ Tcl_CopyObjectInstance( TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); } if (cls2Ptr->mixins.num != 0) { - ckfree((char *) clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { @@ -1866,6 +2079,31 @@ Tcl_CopyObjectInstance( } } + TclResetRewriteEnsemble(interp, 1); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + if (contextPtr) { + args[0] = TclOOObjectName(interp, o2Ptr); + args[1] = oPtr->fPtr->clonedName; + args[2] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, + args); + TclDecrRefCount(args[0]); + TclDecrRefCount(args[1]); + TclDecrRefCount(args[2]); + TclOODeleteContext(contextPtr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (while performing post-copy callback)"); + } + if (result != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + return (Tcl_Object) o2Ptr; } @@ -2018,7 +2256,7 @@ Tcl_ClassSetMetadata( if (metadata == NULL) { return; } - clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable)); + clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2098,7 +2336,7 @@ Tcl_ObjectSetMetadata( if (metadata == NULL) { return; } - oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2241,9 +2479,15 @@ TclOOObjectCmdCore( Tcl_Obj *methodNamePtr; int result; + /* + * If we've no method name, throw this directly into the unknown + * processing. + */ + if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); - return TCL_ERROR; + flags |= FORCE_UNKNOWN; + methodNamePtr = NULL; + goto noMapping; } /* @@ -2258,7 +2502,7 @@ TclOOObjectCmdCore( result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, (Tcl_Class *) startClsPtr, mappedMethodName); if (result != TCL_OK) { - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (result == TCL_BREAK) { goto noMapping; } else if (result == TCL_ERROR) { @@ -2274,11 +2518,13 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", + TclGetString(methodNamePtr), NULL); return TCL_ERROR; } } else { @@ -2290,9 +2536,11 @@ TclOOObjectCmdCore( contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, flags | (oPtr->flags & FILTER_HANDLING), NULL); if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "impossible to invoke method \"%s\": no defined method or" + " unknown method", TclGetString(methodNamePtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); return TCL_ERROR; } } @@ -2316,9 +2564,10 @@ TclOOObjectCmdCore( } } if (contextPtr->index >= contextPtr->callPtr->numChain) { - result = TCL_ERROR; - Tcl_SetResult(interp, "no valid method implementation", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no valid method implementation", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(methodNamePtr), NULL); TclOODeleteContext(contextPtr); return TCL_ERROR; } @@ -2329,8 +2578,7 @@ TclOOObjectCmdCore( * for the duration. */ - AddRef(oPtr); - TclNRAddCallback(interp, FinalizeObjectCall, contextPtr,oPtr, NULL,NULL); + TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL); return TclOOInvokeContext(contextPtr, interp, objc, objv); } @@ -2340,15 +2588,12 @@ FinalizeObjectCall( Tcl_Interp *interp, int result) { - register CallContext *contextPtr = data[0]; - register Object *oPtr = data[1]; - /* - * Dispose of the call chain and drop the lock on the object's structure. + * Dispose of the call chain, which drops the lock on the object's + * structure. */ - TclOODeleteContext(contextPtr); - DelRef(oPtr); + TclOODeleteContext(data[0]); return result; } @@ -2401,8 +2646,9 @@ Tcl_ObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2469,8 +2715,9 @@ TclNRObjectContextInvokeNext( methodType = "method"; } - Tcl_AppendResult(interp, "no next ", methodType, " implementation", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); return TCL_ERROR; } @@ -2546,8 +2793,10 @@ Tcl_GetObjectFromObj( return cmdPtr->objClientData; notAnObject: - Tcl_AppendResult(interp, TclGetString(objPtr), - " does not refer to an object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to an object", TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), + NULL); return NULL; } @@ -2692,7 +2941,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0; + return Deleted(object) ? 1 : 0; } Tcl_Object diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 80b4eff..31d1113 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,5 +1,3 @@ -# $Id: tclOO.decls,v 1.8 2010/09/15 07:33:54 nijtmans Exp $ - library tclOO ###################################################################### @@ -8,7 +6,7 @@ library tclOO interface tclOO hooks tclOOInt -scspec EXTERN +scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, diff --git a/generic/tclOO.h b/generic/tclOO.h index 6dc0feb..cf253b1 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -4,29 +4,42 @@ * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2010 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOO.h,v 1.11 2010/06/02 08:22:15 nijtmans Exp $ */ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED #include "tcl.h" +#ifndef TCLOOAPI +# if defined(BUILD_tcl) || defined(BUILD_TclOO) +# define TCLOOAPI MODULE_SCOPE +# else +# define TCLOOAPI extern +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS 1 +# endif +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) + /* * Be careful when it comes to versioning; need to make sure that the * standalone TclOO version matches. Also make sure that this matches the * version in the files: * * tests/oo.test + * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.2" +#define TCLOO_VERSION "1.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b26061e..0676618 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,12 +4,10 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOOBasic.c,v 1.24 2010/02/05 13:41:33 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -21,6 +19,8 @@ static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); static int AfterNRDestructor(ClientData data[], Tcl_Interp *interp, int result); +static int DecrRefsPostClassConstructor(ClientData data[], + Tcl_Interp *interp, int result); static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], @@ -72,6 +72,74 @@ FinalizeConstruction( /* * ---------------------------------------------------------------------- * + * TclOO_Class_Constructor -- + * + * Implementation for oo::class constructor. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_Constructor( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Tcl_Obj *invoke[3]; + + if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "?definitionScript?"); + return TCL_ERROR; + } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { + return TCL_OK; + } + + /* + * Delegate to [oo::define] to do the work. + */ + + invoke[0] = oPtr->fPtr->defineName; + invoke[1] = TclOOObjectName(interp, oPtr); + invoke[2] = objv[objc-1]; + + /* + * Must add references or errors in configuration script will cause + * trouble. + */ + + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + Tcl_IncrRefCount(invoke[2]); + TclNRAddCallback(interp, DecrRefsPostClassConstructor, + invoke[0], invoke[1], invoke[2], NULL); + + /* + * Tricky point: do not want the extra reported level in the Tcl stack + * trace, so use TCL_EVAL_NOERR. + */ + + return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); +} + +static int +DecrRefsPostClassConstructor( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); + TclDecrRefCount((Tcl_Obj *) data[2]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOO_Class_Create -- * * Implementation for oo::class->create method. @@ -100,8 +168,9 @@ TclOO_Class_Create( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -117,7 +186,8 @@ TclOO_Class_Create( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -163,8 +233,9 @@ TclOO_Class_CreateNs( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -180,14 +251,16 @@ TclOO_Class_CreateNs( objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { - Tcl_AppendResult(interp, "object name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { - Tcl_AppendResult(interp, "namespace name must not be empty", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "namespace name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } @@ -231,8 +304,9 @@ TclOO_Class_New( if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" is not a class", TclGetString(cmdnameObj))); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); return TCL_ERROR; } @@ -278,9 +352,9 @@ TclOO_Object_Destroy( if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; - AddRef(oPtr); - TclNRAddCallback(interp, AfterNRDestructor, oPtr, contextPtr, - NULL, NULL); + TclNRAddCallback(interp, AfterNRDestructor, contextPtr, + NULL, NULL, NULL); + TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, 0, NULL); } } @@ -296,14 +370,12 @@ AfterNRDestructor( Tcl_Interp *interp, int result) { - Object *oPtr = data[0]; - CallContext *contextPtr = data[1]; + CallContext *contextPtr = data[0]; - TclOODeleteContext(contextPtr); - if (oPtr->command) { - Tcl_DeleteCommandFromToken(interp, oPtr->command); + if (contextPtr->oPtr->command) { + Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command); } - DelRef(oPtr); + TclOODeleteContext(contextPtr); return result; } @@ -435,9 +507,16 @@ TclOO_Object_Unknown( Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *errorMsg; + + /* + * If no method name, generate an error asking for a method name. (Only by + * overriding *this* method can an object handle the absence of a method + * name without an error). + */ if (objc < skip+1) { - Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?"); + Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?"); return TCL_ERROR; } @@ -454,31 +533,34 @@ TclOO_Object_Unknown( if (numMethodNames == 0) { Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr); + const char *piece; - Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL); if (contextPtr->callPtr->flags & PUBLIC_METHOD) { - Tcl_AppendResult(interp, "\" has no visible methods", NULL); + piece = "visible methods"; } else { - Tcl_AppendResult(interp, "\" has no methods", NULL); + piece = "methods"; } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]), - "\": must be ", NULL); + errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ", + TclGetString(objv[skip])); for (i=0 ; i<numMethodNames-1 ; i++) { if (i) { - Tcl_AppendResult(interp, ", ", NULL); + Tcl_AppendToObj(errorMsg, ", ", -1); } - Tcl_AppendResult(interp, methodNames[i], NULL); + Tcl_AppendToObj(errorMsg, methodNames[i], -1); } if (i) { - Tcl_AppendResult(interp, " or ", NULL); + Tcl_AppendToObj(errorMsg, " or ", -1); } - Tcl_AppendResult(interp, methodNames[i], NULL); - ckfree((char *) methodNames); + Tcl_AppendToObj(errorMsg, methodNames[i], -1); + ckfree(methodNames); + Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; @@ -534,8 +616,9 @@ TclOO_Object_LinkVar( */ if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "variable name \"", varName, - "\" illegal: must not contain namespace separator", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable name \"%s\" illegal: must not contain namespace" + " separator", varName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -682,10 +765,11 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * - * TclOONextObjCmd -- + * TclOONextObjCmd, TclOONextToObjCmd -- * - * Implementation of the [next] command. Note that this command is only - * ever to be used inside the body of a procedure-like method. + * Implementation of the [next] and [nextto] commands. Note that these + * commands are only ever to be used inside the body of a procedure-like + * method. * * ---------------------------------------------------------------------- */ @@ -708,8 +792,9 @@ TclOONextObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -725,6 +810,100 @@ TclOONextObjCmd( return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } +int +TclOONextToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Class *classPtr; + CallContext *contextPtr; + int i; + Tcl_Object object; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + return TCL_ERROR; + } + contextPtr = framePtr->clientData; + + /* + * Sanity check the arguments; we need the first one to refer to a class. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); + return TCL_ERROR; + } + object = Tcl_GetObjectFromObj(interp, objv[1]); + if (object == NULL) { + return TCL_ERROR; + } + classPtr = ((Object *)object)->classPtr; + if (classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + return TCL_ERROR; + } + + /* + * Search for an implementation of a method associated with the current + * call on the call chain past the point where we currently are. Do not + * allow jumping backwards! + */ + + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + /* + * Invoke the (advanced) method call context in the caller + * context. Note that this is like [uplevel 1] and not [eval]. + */ + + TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, + INT2PTR(contextPtr->index), NULL); + contextPtr->index = i-1; + iPtr->varFramePtr = framePtr->callerVarPtr; + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, objc, objv, 2); + } + } + + /* + * Generate an appropriate error message, depending on whether the value + * is on the chain but unreachable, or not on the chain at all. + */ + + for (i=contextPtr->index ; i>=0 ; i--) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method implementation by \"%s\" not reachable from here", + TclGetString(objv[1]))); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method has no non-filter implementation by \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; +} + static int RestoreFrame( ClientData data[], @@ -732,8 +911,12 @@ RestoreFrame( int result) { Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; iPtr->varFramePtr = data[0]; + if (contextPtr != NULL) { + contextPtr->index = PTR2INT(data[2]); + } return result; } @@ -756,16 +939,17 @@ TclOOSelfObjCmd( Tcl_Obj *const *objv) { static const char *const subcmds[] = { - "caller", "class", "filter", "method", "namespace", "next", "object", - "target", NULL + "call", "caller", "class", "filter", "method", "namespace", "next", + "object", "target", NULL }; enum SelfCmds { - SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, - SELF_OBJECT, SELF_TARGET + SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, + SELF_NEXT, SELF_OBJECT, SELF_TARGET }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; + Tcl_Obj *result[3]; int index; #define CurrentlyInvoked(contextPtr) \ @@ -776,8 +960,9 @@ TclOOSelfObjCmd( */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_AppendResult(interp, TclGetString(objv[0]), - " may only be called from inside a method", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } @@ -811,7 +996,8 @@ TclOOSelfObjCmd( Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; if (clsPtr == NULL) { - Tcl_AppendResult(interp, "method not defined by a class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method not defined by a class", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } @@ -831,12 +1017,12 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_FILTER: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); - Tcl_Obj *result[3]; Object *oPtr; const char *type; @@ -857,14 +1043,14 @@ TclOOSelfObjCmd( case SELF_CALLER: if ((framePtr->callerVarPtr == NULL) || !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ - Tcl_AppendResult(interp, "caller is not an object", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "caller is not an object", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); return TCL_ERROR; } else { CallContext *callerPtr = framePtr->callerVarPtr->clientData; Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr; Object *declarerPtr; - Tcl_Obj *result[3]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -875,7 +1061,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -896,7 +1083,6 @@ TclOOSelfObjCmd( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index+1].mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -907,7 +1093,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } @@ -924,13 +1111,13 @@ TclOOSelfObjCmd( return TCL_OK; case SELF_TARGET: if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_AppendResult(interp, "not inside a filtering context", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "not inside a filtering context", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); return TCL_ERROR; } else { Method *mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; int i; for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ @@ -951,7 +1138,8 @@ TclOOSelfObjCmd( * This should be unreachable code. */ - Tcl_AppendResult(interp, "method without declarer!", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method without declarer!", -1)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); @@ -959,6 +1147,11 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } + case SELF_CALL: + result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); + result[1] = Tcl_NewIntObj(contextPtr->index); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); + return TCL_OK; } return TCL_ERROR; } @@ -1017,7 +1210,7 @@ TclOOCopyObjectCmd( Tcl_DStringAppend(&buffer, iPtr->varFramePtr->nsPtr->fullName, -1); } - Tcl_DStringAppend(&buffer, "::", 2); + TclDStringAppendLiteral(&buffer, "::"); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); } @@ -1038,74 +1231,6 @@ TclOOCopyObjectCmd( } /* - * ---------------------------------------------------------------------- - * - * TclOOUpcatchCmd -- - * - * Implementation of the [oo::UpCatch] command, which is a combination of - * [uplevel 1] and [catch] that makes it easier to write transparent - * error handling in scripts. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOUpcatchCmd( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv); -} - -static int -UpcatchCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = data[0]; - Tcl_Obj *resultObj[2]; - int rewind = iPtr->execEnvPtr->rewind; - - iPtr->varFramePtr = savedFramePtr; - if (rewind || Tcl_LimitExceeded(interp)) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp))); - return TCL_ERROR; - } - resultObj[0] = Tcl_GetObjResult(interp); - resultObj[1] = Tcl_GetReturnOptions(interp, result); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj)); - return TCL_OK; -} - -int -TclOONRUpcatch( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "script"); - return TCL_ERROR; - } - if (iPtr->varFramePtr->callerVarPtr != NULL) { - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - - Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL); - return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR, - iPtr->cmdFramePtr, 1); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index e8f9757..a79e4fa 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -4,12 +4,10 @@ * This file contains the method call chain management code for the * object-system core. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOOCall.c,v 1.15 2009/09/30 03:11:26 dgp Exp $ */ #ifdef HAVE_CONFIG_H @@ -39,7 +37,7 @@ struct ChainBuilder { #define DEFINITE_PROTECTED 0x100000 #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) -#define SPECIAL (CONSTRUCTOR | DESTRUCTOR) +#define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN) /* * Function declarations for things defined in this file. @@ -103,8 +101,13 @@ void TclOODeleteContext( CallContext *contextPtr) { + register Object *oPtr = contextPtr->oPtr; + TclOODeleteChain(contextPtr->callPtr); - TclStackFree(contextPtr->oPtr->fPtr->interp, contextPtr); + if (oPtr != NULL) { + TclStackFree(oPtr->fPtr->interp, contextPtr); + DelRef(oPtr); + } } /* @@ -130,7 +133,7 @@ TclOODeleteChainCache( } } Tcl_DeleteHashTable(tablePtr); - ckfree((char *) tablePtr); + ckfree(tablePtr); } /* @@ -151,9 +154,9 @@ TclOODeleteChain( return; } if (callPtr->chain != callPtr->staticChain) { - ckfree((char *) callPtr->chain); + ckfree(callPtr->chain); } - ckfree((char *) callPtr); + ckfree(callPtr); } /* @@ -450,7 +453,7 @@ TclOOGetSortedMethodList( * heavily sorted when it is long enough to matter. */ - strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); + strings = ckalloc(sizeof(char *) * names.numEntries); FOREACH_HASH(namePtr, isWanted, &names) { if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { @@ -471,7 +474,7 @@ TclOOGetSortedMethodList( } *stringsPtr = strings; } else { - ckfree((char *) strings); + ckfree(strings); } } @@ -517,7 +520,7 @@ TclOOGetSortedClassMethodList( * heavily sorted when it is long enough to matter. */ - strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); + strings = ckalloc(sizeof(char *) * names.numEntries); FOREACH_HASH(namePtr, isWanted, &names) { if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { @@ -538,7 +541,7 @@ TclOOGetSortedClassMethodList( } *stringsPtr = strings; } else { - ckfree((char *) strings); + ckfree(strings); } } @@ -800,12 +803,12 @@ AddMethodToCallChain( */ if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { - callPtr->chain = (struct MInvoke *) - ckalloc(sizeof(struct MInvoke)*(callPtr->numChain+1)); + callPtr->chain = + 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) { - callPtr->chain = (struct MInvoke *) ckrealloc((char *) callPtr->chain, + callPtr->chain = ckrealloc(callPtr->chain, sizeof(struct MInvoke) * (callPtr->numChain + 1)); } callPtr->chain[i].mPtr = mPtr; @@ -986,7 +989,7 @@ TclOOGetCallContext( doFilters = 1; } - callPtr = (CallChain *) ckalloc(sizeof(CallChain)); + callPtr = ckalloc(sizeof(CallChain)); InitCallChain(callPtr, oPtr, flags); cb.callChainPtr = callPtr; @@ -994,6 +997,22 @@ TclOOGetCallContext( cb.oPtr = oPtr; /* + * If we're working with a forced use of unknown, do that now. + */ + + if (flags & FORCE_UNKNOWN) { + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (callPtr->numChain == 0) { + TclOODeleteChain(callPtr); + return NULL; + } + goto returnContext; + } + + /* * Add all defined filters (if any, and if we're going to be processing * them; they're not processed for constructors, destructors or when we're * in the middle of processing a filter). @@ -1051,7 +1070,7 @@ TclOOGetCallContext( if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { - oPtr->selfCls->classChainCache = (Tcl_HashTable *) + oPtr->selfCls->classChainCache = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); @@ -1060,8 +1079,7 @@ TclOOGetCallContext( (char *) methodNameObj, &i); } else { if (oPtr->chainCache == NULL) { - oPtr->chainCache = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->chainCache); } @@ -1089,6 +1107,7 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; contextPtr->index = 0; @@ -1098,6 +1117,135 @@ TclOOGetCallContext( /* * ---------------------------------------------------------------------- * + * TclOOGetStereotypeCallChain -- + * + * Construct a call-chain for a method that would be used by a + * stereotypical instance of the given class (i.e., where the object has + * no definitions special to itself). + * + * ---------------------------------------------------------------------- + */ + +CallChain * +TclOOGetStereotypeCallChain( + Class *clsPtr, /* The object to get the context for. */ + Tcl_Obj *methodNameObj, /* The name of the method to get the context + * for. NULL when getting a constructor or + * destructor chain. */ + int flags) /* What sort of context are we looking for. + * Only the bits PUBLIC_METHOD, CONSTRUCTOR, + * PRIVATE_METHOD, DESTRUCTOR and + * FILTER_HANDLING are useful. */ +{ + CallChain *callPtr; + struct ChainBuilder cb; + int i, count; + Foundation *fPtr = clsPtr->thisPtr->fPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable doneFilters; + Object obj; + + /* + * Synthesize a temporary stereotypical object so that we can use existing + * machinery to produce the stereotypical call chain. + */ + + memset(&obj, 0, sizeof(Object)); + obj.fPtr = fPtr; + obj.selfCls = clsPtr; + obj.refCount = 1; + obj.flags = USE_CLASS_CACHE; + + /* + * Check if we can get the chain out of the Tcl_Obj method name or out of + * the cache. This is made a bit more complex by the fact that there are + * multiple different layers of cache (in the Tcl_Obj, in the object, and + * in the class). + */ + + if (clsPtr->classChainCache != NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, + (char *) methodNameObj); + if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + const int reuseMask = + ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + + callPtr = Tcl_GetHashValue(hPtr); + if (IsStillValid(callPtr, &obj, flags, reuseMask)) { + callPtr->refCount++; + return callPtr; + } + Tcl_SetHashValue(hPtr, NULL); + TclOODeleteChain(callPtr); + } + } else { + hPtr = NULL; + } + + callPtr = ckalloc(sizeof(CallChain)); + memset(callPtr, 0, sizeof(CallChain)); + callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); + callPtr->epoch = fPtr->epoch; + callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; + callPtr->objectEpoch = clsPtr->thisPtr->epoch; + callPtr->refCount = 1; + callPtr->chain = callPtr->staticChain; + + cb.callChainPtr = callPtr; + cb.filterLength = 0; + cb.oPtr = &obj; + + /* + * Add all defined filters (if any, and if we're going to be processing + * them; they're not processed for constructors, destructors or when we're + * in the middle of processing a filter). + */ + + Tcl_InitObjHashTable(&doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + count = cb.filterLength = callPtr->numChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + + /* + * Check to see if the method has no implementation. If so, we probably + * need to add in a call to the unknown method. Otherwise, set up the + * cacheing of the method implementation (if relevant). + */ + + if (count == callPtr->numChain) { + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (count == callPtr->numChain) { + TclOODeleteChain(callPtr); + return NULL; + } + } else { + if (hPtr == NULL) { + if (clsPtr->classChainCache == NULL) { + clsPtr->classChainCache = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(clsPtr->classChainCache); + } + hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, + (char *) methodNameObj, &i); + } + callPtr->refCount++; + Tcl_SetHashValue(hPtr, callPtr); + StashCallChain(methodNameObj, callPtr); + } + return callPtr; +} + +/* + * ---------------------------------------------------------------------- + * * AddClassFiltersToCallContext -- * * Logic to make extracting all the filters from the class context much @@ -1255,6 +1403,91 @@ AddSimpleClassChainToCallContext( } /* + * ---------------------------------------------------------------------- + * + * TclOORenderCallChain -- + * + * Create a description of a call chain. Used in [info object call], + * [info class call], and [self call]. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOORenderCallChain( + Tcl_Interp *interp, + CallChain *callPtr) +{ + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *resultObj, *descObjs[4], **objv; + Foundation *fPtr = TclOOGetFoundation(interp); + int i; + + /* + * Allocate the literals (potentially) used in our description. + */ + + filterLiteral = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(filterLiteral); + methodLiteral = Tcl_NewStringObj("method", -1); + Tcl_IncrRefCount(methodLiteral); + objectLiteral = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(objectLiteral); + + /* + * 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 + * 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 + * the method in question (which differs for "unknown" and "filter" types) + * and the third word is the full name of the class that declares the + * method (or "object" if it is declared on the instance). + */ + + objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + 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[2] = miPtr->mPtr->declaringClassPtr + ? Tcl_GetObjectName(interp, + (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) + : objectLiteral; + descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); + + objv[i] = Tcl_NewListObj(4, descObjs); + } + + /* + * Drop the local references to the literals; if they're actually used, + * they'll live on the description itself. + */ + + Tcl_DecrRefCount(filterLiteral); + Tcl_DecrRefCount(methodLiteral); + Tcl_DecrRefCount(objectLiteral); + + /* + * Finish building the description and return it. + */ + + resultObj = Tcl_NewListObj(callPtr->numChain, objv); + TclStackFree(interp, objv); + return resultObj; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 697570d..58871c6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -1,37 +1,10 @@ /* - * $Id: tclOODecls.h,v 1.16 2010/08/19 04:26:03 nijtmans Exp $ - * * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOODECLS #define _TCLOODECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif -#endif - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclOO.decls script. - */ - -#if defined(USE_TCLOO_STUBS) -extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION) -#else -#define Tcl_OOInitStubs(interp) \ - Tcl_PkgRequire((interp),"TclOO",TCLOO_VERSION,0) -#endif - /* !BEGIN!: Do not edit below this line. */ /* @@ -39,101 +12,101 @@ extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLOOAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLOOAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); -typedef struct TclOOStubHooks { +typedef struct { const struct TclOOIntStubs *tclOOIntStubs; } TclOOStubHooks; typedef struct TclOOStubs { int magic; - const struct TclOOStubHooks *hooks; + const TclOOStubHooks *hooks; Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */ Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */ @@ -242,8 +215,4 @@ extern const TclOOStubs *tclOOStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - #endif /* _TCLOODECLS */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 1cf0786..bacab38 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,12 +4,10 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOODefineCmds.c,v 1.13 2010/03/05 11:36:19 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -19,12 +17,38 @@ #include "tclOOInt.h" /* + * The maximum length of fully-qualified object name to use in an errorinfo + * message. Longer than this will be curtailed. + */ + +#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 + +/* + * Some things that make it easier to declare a slot. + */ + +struct DeclaredSlot { + const char *name; + const Tcl_MethodType getterType; + const Tcl_MethodType setterType; +}; + +#define SLOT(name,getter,setter) \ + {"::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}} + +/* * Forward declarations. */ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); +static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, + Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, @@ -34,6 +58,63 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); +static int ClassFilterGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassFilterSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjFilterGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjFilterSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsSet(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}} +}; /* * ---------------------------------------------------------------------- @@ -131,7 +212,7 @@ TclOOObjectSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree((char *) oPtr->filters.list); + ckfree(oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; RecomputeClassCacheFlag(oPtr); @@ -144,10 +225,9 @@ TclOOObjectSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (oPtr->filters.num == 0) { - filtersList = (Tcl_Obj **) ckalloc(size); + filtersList = ckalloc(size); } else { - filtersList = (Tcl_Obj **) - ckrealloc((char *) oPtr->filters.list, size); + filtersList = ckrealloc(oPtr->filters.list, size); } for (i=0 ; i<numFilters ; i++) { filtersList[i] = filters[i]; @@ -191,7 +271,7 @@ TclOOClassSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree((char *) classPtr->filters.list); + ckfree(classPtr->filters.list); classPtr->filters.list = NULL; classPtr->filters.num = 0; } else { @@ -203,10 +283,9 @@ TclOOClassSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (classPtr->filters.num == 0) { - filtersList = (Tcl_Obj **) ckalloc(size); + filtersList = ckalloc(size); } else { - filtersList = (Tcl_Obj **) - ckrealloc((char *) classPtr->filters.list, size); + filtersList = ckrealloc(classPtr->filters.list, size); } for (i=0 ; i<numFilters ; i++) { filtersList[i] = filters[i]; @@ -246,7 +325,7 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); } - ckfree((char *) oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); @@ -257,12 +336,10 @@ TclOOObjectSetMixins( TclOORemoveFromInstances(oPtr, mixinPtr); } } - oPtr->mixins.list = (Class **) - ckrealloc((char *) oPtr->mixins.list, + oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { - oPtr->mixins.list = (Class **) - ckalloc(sizeof(Class *) * numMixins); + oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; @@ -300,7 +377,7 @@ TclOOClassSetMixins( FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); } - ckfree((char *) classPtr->mixins.list); + ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { @@ -308,12 +385,10 @@ TclOOClassSetMixins( FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); } - classPtr->mixins.list = (Class **) - ckrealloc((char *) classPtr->mixins.list, + classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } else { - classPtr->mixins.list = (Class **) - ckalloc(sizeof(Class *) * numMixins); + classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); @@ -348,8 +423,10 @@ RenameDeleteMethod( if (!useClass) { if (!oPtr->methodsPtr) { noSuchMethod: - Tcl_AppendResult(interp, "method ", TclGetString(fromPtr), - " does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method %s does not exist", TclGetString(fromPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(fromPtr), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); @@ -361,13 +438,16 @@ RenameDeleteMethod( &isNew); if (hPtr == newHPtr) { renameToSelf: - Tcl_AppendResult(interp, "cannot rename method to itself", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot rename method to itself", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: - Tcl_AppendResult(interp, "method called ", - TclGetString(toPtr), " already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method called %s already exists", + TclGetString(toPtr))); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); return TCL_ERROR; } } @@ -434,7 +514,9 @@ TclOOUnknownDefinition( const char *soughtStr, *matchedStr = NULL; if (objc < 2) { - Tcl_AppendResult(interp, "bad call of unknown handler", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad call of unknown handler", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL); return TCL_ERROR; } if (TclOOGetDefineCmdContext(interp) == NULL) { @@ -478,7 +560,9 @@ TclOOUnknownDefinition( } noMatch: - Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", soughtStr)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); return TCL_ERROR; } @@ -565,9 +649,10 @@ InitDefineContext( int result; if (namespacePtr == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -600,15 +685,25 @@ TclOOGetDefineCmdContext( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; + Tcl_Object object; if ((iPtr->varFramePtr == NULL) || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { - Tcl_AppendResult(interp, "this command may only be called from within" - " the context of an ::oo::define or ::oo::objdefine command", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command may only be called from within the context of" + " an ::oo::define or ::oo::objdefine command", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return NULL; + } + object = iPtr->varFramePtr->clientData; + if (Tcl_ObjectDeleted(object)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command cannot be called when the object has been" + " deleted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } - return (Tcl_Object) iPtr->varFramePtr->clientData; + return object; } /* @@ -645,7 +740,9 @@ GetClassInOuterContext( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(className), NULL); return NULL; } return oPtr->classPtr; @@ -654,6 +751,44 @@ GetClassInOuterContext( /* * ---------------------------------------------------------------------- * + * GenerateErrorInfo -- + * Factored out code to generate part of the error trace messages. + * + * ---------------------------------------------------------------------- + */ + +static void +GenerateErrorInfo( + Tcl_Interp *interp, /* Where to store the error info trace. */ + Object *oPtr, /* What object (or class) was being configured + * when the error occurred? */ + Tcl_Obj *savedNameObj, /* Name of object saved from before script was + * evaluated, which is needed if the object + * goes away part way through execution. OTOH, + * if the object isn't deleted then its + * current name (post-execution) has to be + * used. This matters, because the object + * could have been renamed... */ + const char *typeOfSubject) /* Part of the message, saying whether it was + * an object, class or class-as-object that + * was being configured. */ +{ + int length; + Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) + ? savedNameObj : TclOOObjectName(interp, oPtr); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for %s \"%.*s%s\" line %d)", + typeOfSubject, (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the @@ -685,8 +820,10 @@ TclOODefineObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, TclGetString(objv[1]), - " does not refer to a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to a class",TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[1]), NULL); return TCL_ERROR; } @@ -701,20 +838,15 @@ TclOODefineObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -820,20 +952,15 @@ TclOOObjDefObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -939,21 +1066,15 @@ TclOODefineSelfObjCmd( AddRef(oPtr); if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj( - TclOOObjectName(interp, oPtr), &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -1044,13 +1165,15 @@ TclOODefineClassObjCmd( return TCL_ERROR; } if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the class of the root object class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the root object class", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { - Tcl_AppendResult(interp, - "may not modify the class of the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the class of classes", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1075,9 +1198,11 @@ TclOODefineClassObjCmd( */ if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_AppendResult(interp, "may not change a ", - (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", - (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "may not change a %sclass object into a %sclass object", + (oPtr->classPtr==NULL ? "non-" : ""), + (oPtr->classPtr==NULL ? "" : "non-"))); + Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); return TCL_ERROR; } @@ -1197,7 +1322,9 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1319,7 +1446,9 @@ TclOODefineExportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1335,8 +1464,7 @@ TclOODefineExportObjCmd( if (isInstanceExport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } @@ -1348,7 +1476,7 @@ TclOODefineExportObjCmd( } if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -1380,42 +1508,6 @@ TclOODefineExportObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineFilterObjCmd -- - * Implementation of the "filter" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineFilterObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceFilter = (clientData != NULL); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceFilter && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); - return TCL_ERROR; - } - - if (!isInstanceFilter) { - TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1); - } else { - TclOOObjectSetFilters(oPtr, objc-1, objv+1); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineForwardObjCmd -- * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. @@ -1446,7 +1538,9 @@ TclOODefineForwardObjCmd( return TCL_ERROR; } if (!isInstanceForward && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") @@ -1502,7 +1596,9 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") @@ -1552,7 +1648,9 @@ TclOODefineMixinObjCmd( return TCL_ERROR; } if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + 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)); @@ -1565,7 +1663,9 @@ TclOODefineMixinObjCmd( goto freeAndError; } if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + 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; @@ -1615,7 +1715,9 @@ TclOODefineRenameMethodObjCmd( return TCL_ERROR; } if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1642,45 +1744,457 @@ TclOODefineRenameMethodObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineSuperclassObjCmd -- - * Implementation of the "superclass" subcommand of the "oo::define" - * command. + * TclOODefineUnexportObjCmd -- + * Implementation of the "unexport" subcommand of the "oo::define" and + * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int -TclOODefineSuperclassObjCmd( +TclOODefineUnexportObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Class **superclasses, *superPtr; - int i, j; + Method *mPtr; + Tcl_HashEntry *hPtr; + Class *clsPtr; + int i, isNew, changed = 0; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (!isInstanceUnexport && !clsPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + /* + * Unexporting is done by removing the PUBLIC_METHOD flag from the + * method record. If there is no such method in this object or class + * (i.e. the method comes from something inherited from or that we're + * an instance of) then we put in a blank record without that flag; + * such records are skipped over by the call chain engine *except* for + * their flags member. + */ + + if (isInstanceUnexport) { + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], + &isNew); + } else { + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], + &isNew); + } + + if (isNew) { + mPtr = ckalloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = objv[i]; + Tcl_IncrRefCount(objv[i]); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & PUBLIC_METHOD) { + mPtr->flags &= ~PUBLIC_METHOD; + changed = 1; + } + } + /* - * Get the class to operate on. + * Bump the right epoch if we actually changed anything. */ - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (changed) { + if (isInstanceUnexport) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, clsPtr); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * How to install a constructor or destructor into a class; API to call + * from C. + * + * ---------------------------------------------------------------------- + */ + +void +Tcl_ClassSetConstructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->constructorPtr) { + TclOODelMethodRef(clsPtr->constructorPtr); + clsPtr->constructorPtr = (Method *) method; + + /* + * Remember to invalidate the cached constructor chain for this class. + * [Bug 2531577] + */ + + if (clsPtr->constructorChainPtr) { + TclOODeleteChain(clsPtr->constructorChainPtr); + clsPtr->constructorChainPtr = NULL; + } + BumpGlobalEpoch(interp, clsPtr); + } +} + +void +Tcl_ClassSetDestructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->destructorPtr) { + TclOODelMethodRef(clsPtr->destructorPtr); + clsPtr->destructorPtr = (Method *) method; + if (clsPtr->destructorChainPtr) { + TclOODeleteChain(clsPtr->destructorChainPtr); + clsPtr->destructorChainPtr = NULL; + } + BumpGlobalEpoch(interp, clsPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineSlots -- + * Create the "::oo::Slot" class and its standard instances. Class + * definition is empty at the stage (added by scripting). + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineSlots( + Foundation *fPtr) +{ + const struct DeclaredSlot *slotInfoPtr; + Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); + Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Class *slotCls; + + slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) + fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; + if (slotCls == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(getName); + Tcl_IncrRefCount(setName); + for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, + (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + + if (slotObject == NULL) { + continue; + } + Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, + &slotInfoPtr->getterType, NULL); + Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, + &slotInfoPtr->setterType, NULL); + } + Tcl_DecrRefCount(getName); + Tcl_DecrRefCount(setName); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassFilterGet, ClassFilterSet -- + * Implementation of the "filter" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassFilterGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *filterObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } if (oPtr == NULL) { return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; } - if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "only classes may have superclasses defined", + + resultObj = Tcl_NewObj(); + FOREACH(filterObj, oPtr->classPtr->filters) { + Tcl_ListObjAppendElement(NULL, resultObj, filterObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassFilterSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int filterc; + Tcl_Obj **filterv; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + &filterv) != TCL_OK) { + return TCL_ERROR; + } + + TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassMixinGet, ClassMixinSet -- + * Implementation of the "mixin" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassMixinGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *mixinPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; } - if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the superclass of the root object", NULL); + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(mixinPtr, oPtr->classPtr->mixins) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, mixinPtr->thisPtr)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + +} + +static int +ClassMixinSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int mixinc, i; + Tcl_Obj **mixinv; + Class **mixins; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "mixinList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + &mixinv) != TCL_OK) { + return TCL_ERROR; + } + + mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + + for (i=0 ; i<mixinc ; i++) { + mixins[i] = GetClassInOuterContext(interp, mixinv[i], + "may only mix in classes"); + if (mixins[i] == NULL) { + goto freeAndError; + } + if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); + goto freeAndError; + } + } + + TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); + TclStackFree(interp, mixins); + return TCL_OK; + + freeAndError: + TclStackFree(interp, mixins); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassSuperGet, ClassSuperSet -- + * Implementation of the "superclass" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassSuperGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *superPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(superPtr, oPtr->classPtr->superclasses) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, superPtr->thisPtr)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassSuperSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int superc, i, j; + Tcl_Obj **superv; + Class **superclasses, *superPtr; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "superclassList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the superclass of the root object", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, + &superv) != TCL_OK) { return TCL_ERROR; } @@ -1688,34 +2202,34 @@ TclOODefineSuperclassObjCmd( * Allocate some working space. */ - superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1)); + superclasses = (Class **) ckalloc(sizeof(Class *) * superc); /* * Parse the arguments to get the class to use as superclasses. */ - for (i=0 ; i<objc-1 ; i++) { - Class *clsPtr = GetClassInOuterContext(interp, objv[i+1], + for (i=0 ; i<superc ; i++) { + superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); - - if (clsPtr == NULL) { + if (superclasses[i] == NULL) { goto failedAfterAlloc; } for (j=0 ; j<i ; j++) { - if (superclasses[j] == clsPtr) { - Tcl_AppendResult(interp, - "class should only be a direct superclass once",NULL); + if (superclasses[j] == superclasses[i]) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "class should only be a direct superclass once", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); goto failedAfterAlloc; } } - if (TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, - "attempt to form circular dependency graph", NULL); + if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: ckfree((char *) superclasses); return TCL_ERROR; } - superclasses[i] = clsPtr; } /* @@ -1732,7 +2246,7 @@ TclOODefineSuperclassObjCmd( ckfree((char *) oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; - oPtr->classPtr->superclasses.num = objc-1; + oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); } @@ -1744,92 +2258,141 @@ TclOODefineSuperclassObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineUnexportObjCmd -- - * Implementation of the "unexport" subcommand of the "oo::define" and - * "oo::objdefine" commands. + * ClassVarsGet, ClassVarsSet -- + * Implementation of the "variable" slot accessors of the "oo::define" + * command. * * ---------------------------------------------------------------------- */ -int -TclOODefineUnexportObjCmd( +static int +ClassVarsGet( ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { - int isInstanceUnexport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *variableObj; + int i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); return TCL_ERROR; } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; } - clsPtr = oPtr->classPtr; - if (!isInstanceUnexport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + + resultObj = Tcl_NewObj(); + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassVarsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv, *variableObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); return TCL_ERROR; } + objv += Tcl_ObjectContextSkippedArgs(context); - for (i=1 ; i<objc ; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); + for (i=0 ; i<varc ; i++) { + const char *varName = Tcl_GetString(varv[i]); + + if (strstr(varName, "::") != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; } + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + } - if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + 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 { - mPtr = Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; - changed = 1; + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); } } - /* - * Bump the right epoch if we actually changed anything. - */ + oPtr->classPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; - if (changed) { - if (isInstanceUnexport) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, clsPtr); + 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); } return TCL_OK; } @@ -1837,139 +2400,279 @@ TclOODefineUnexportObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineVariablesObjCmd -- - * Implementation of the "variable" subcommand of the "oo::define" and - * "oo::objdefine" commands. + * ObjectFilterGet, ObjectFilterSet -- + * Implementation of the "filter" slot accessors of the "oo::objdefine" + * command. * * ---------------------------------------------------------------------- */ -int -TclOODefineVariablesObjCmd( +static int +ObjFilterGet( ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { - int isInstanceVars = (clientData != NULL); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *variableObj; + Tcl_Obj *resultObj, *filterObj; int i; - if (oPtr == NULL) { + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(filterObj, oPtr->filters) { + Tcl_ListObjAppendElement(NULL, resultObj, filterObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ObjFilterSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int filterc; + Tcl_Obj **filterv; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } else if (oPtr == NULL) { return TCL_ERROR; } - if (!isInstanceVars && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + &filterv) != TCL_OK) { return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { - const char *varName = Tcl_GetString(objv[i]); + TclOOObjectSetFilters(oPtr, filterc, filterv); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectMixinGet, ObjectMixinSet -- + * Implementation of the "mixin" slot accessors of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ - if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); - return TCL_ERROR; - } +static int +ObjMixinGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *mixinPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { - Tcl_IncrRefCount(objv[i]); + + resultObj = Tcl_NewObj(); + FOREACH(mixinPtr, oPtr->mixins) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, mixinPtr->thisPtr)); } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} - if (!isInstanceVars) { - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != objc-1) { - if (objc == 1) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * (objc-1)); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * (objc-1)); - } - } - if (objc > 1) { - memcpy(oPtr->classPtr->variables.list, objv+1, - sizeof(Tcl_Obj *) * (objc-1)); - } - oPtr->classPtr->variables.num = objc-1; - } else { - FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != objc-1) { - if (objc == 1) { - ckfree((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * (objc-1)); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * (objc-1)); - } - } - if (objc > 1) { - memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1)); +static int +ObjMixinSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int mixinc; + Tcl_Obj **mixinv; + Class **mixins; + int i; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "mixinList"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + &mixinv) != TCL_OK) { + return TCL_ERROR; + } + + mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + + for (i=0 ; i<mixinc ; i++) { + mixins[i] = GetClassInOuterContext(interp, mixinv[i], + "may only mix in classes"); + if (mixins[i] == NULL) { + TclStackFree(interp, mixins); + return TCL_ERROR; } - oPtr->variables.num = objc-1; } + + TclOOObjectSetMixins(oPtr, mixinc, mixins); + TclStackFree(interp, mixins); return TCL_OK; } -void -Tcl_ClassSetConstructor( +/* + * ---------------------------------------------------------------------- + * + * ObjectVarsGet, ObjectVarsSet -- + * Implementation of the "variable" slot accessors of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjVarsGet( + ClientData clientData, Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) { - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->constructorPtr) { - TclOODelMethodRef(clsPtr->constructorPtr); - clsPtr->constructorPtr = (Method *) method; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *variableObj; + int i; - /* - * Remember to invalidate the cached constructor chain for this class. - * [Bug 2531577] - */ + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); + resultObj = Tcl_NewObj(); + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; } -void -Tcl_ClassSetDestructor( +static int +ObjVarsSet( + ClientData clientData, Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) { - Class *clsPtr = (Class *) clazz; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc, i; + Tcl_Obj **varv, *variableObj; - if (method != (Tcl_Method) clsPtr->destructorPtr) { - TclOODelMethodRef(clsPtr->destructorPtr); - clsPtr->destructorPtr = (Method *) method; - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "variableList"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + for (i=0 ; i<varc ; i++) { + const char *varName = Tcl_GetString(varv[i]); + + if (strstr(varName, "::") != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; } - BumpGlobalEpoch(interp, clsPtr); + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + } + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + + FOREACH(variableObj, oPtr->variables) { + Tcl_DecrRefCount(variableObj); } + if (i != varc) { + if (varc == 0) { + ckfree((char *) oPtr->variables.list); + } else if (i) { + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * varc); + } else { + oPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + oPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); + } + return TCL_OK; } /* diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index b8679b3..5be9b01 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,12 +4,10 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOOInfo.c,v 1.14 2010/03/24 13:21:11 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -19,6 +17,7 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; @@ -30,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -43,45 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; -struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; - /* * List of commands that are used to implement the [info object] subcommands. */ -static const struct NameProcMap infoObjectCmds[] = { - {"::oo::InfoObject::class", InfoObjectClassCmd}, - {"::oo::InfoObject::definition", InfoObjectDefnCmd}, - {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, - {"::oo::InfoObject::forward", InfoObjectForwardCmd}, - {"::oo::InfoObject::isa", InfoObjectIsACmd}, - {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, - {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd}, - {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, - {"::oo::InfoObject::namespace", InfoObjectNsCmd}, - {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, - {"::oo::InfoObject::vars", InfoObjectVarsCmd}, - {NULL, NULL} +static const EnsembleImplMap infoObjectCmds[] = { + {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0}, + {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0}, + {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* * List of commands that are used to implement the [info class] subcommands. */ -static const struct NameProcMap infoClassCmds[] = { - {"::oo::InfoClass::constructor", InfoClassConstrCmd}, - {"::oo::InfoClass::definition", InfoClassDefnCmd}, - {"::oo::InfoClass::destructor", InfoClassDestrCmd}, - {"::oo::InfoClass::filters", InfoClassFiltersCmd}, - {"::oo::InfoClass::forward", InfoClassForwardCmd}, - {"::oo::InfoClass::instances", InfoClassInstancesCmd}, - {"::oo::InfoClass::methods", InfoClassMethodsCmd}, - {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd}, - {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, - {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, - {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, - {"::oo::InfoClass::variables", InfoClassVariablesCmd}, - {NULL, NULL} +static const EnsembleImplMap infoClassCmds[] = { + {"call", InfoClassCallCmd, NULL, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -99,58 +99,27 @@ void TclOOInitInfo( Tcl_Interp *interp) { - Tcl_Namespace *nsPtr; Tcl_Command infoCmd; - int i; + Tcl_Obj *mapDict; /* - * Build the ensemble used to implement [info object]. + * Build the ensembles used to implement [info object] and [info class]. */ - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, - infoObjectCmds[i].proc, NULL, NULL); - } - - /* - * Build the ensemble used to implement [info class]. - */ - - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoClassCmds[i].name, - infoClassCmds[i].proc, NULL, NULL); - } + TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); + TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* * Install into the master [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { - Tcl_Obj *mapDict, *objectObj, *classObj; - - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - if (mapDict != NULL) { - objectObj = Tcl_NewStringObj("object", -1); - classObj = Tcl_NewStringObj("class", -1); - - Tcl_IncrRefCount(objectObj); - Tcl_IncrRefCount(classObj); - Tcl_DictObjPut(NULL, mapDict, objectObj, - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, classObj, - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_DecrRefCount(objectObj); - Tcl_DecrRefCount(classObj); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); - } - } + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } /* @@ -175,8 +144,8 @@ GetClassFromObj( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objPtr), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objPtr), NULL); return NULL; @@ -218,30 +187,22 @@ InfoObjectClassCmd( TclOOObjectName(interp, oPtr->selfCls->thisPtr)); return TCL_OK; } else { - Object *o2Ptr; - Class *mixinPtr; + Class *mixinPtr, *o2clsPtr; int i; - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), - "\" is not a class", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + o2clsPtr = GetClassFromObj(interp, objv[2]); + if (o2clsPtr == NULL) { return TCL_ERROR; } FOREACH(mixinPtr, oPtr->mixins) { - if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { + if (TclOOIsReachable(o2clsPtr, mixinPtr)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return TCL_OK; } } Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); + TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } } @@ -285,16 +246,16 @@ InfoObjectDefnCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -396,17 +357,17 @@ InfoObjectForwardCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -497,7 +458,9 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be mixins", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } else { Class *mixinPtr; @@ -521,7 +484,9 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be types", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be types", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { @@ -605,7 +570,7 @@ InfoObjectMethodsCmd( Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - ckfree((char *) names); + ckfree(names); } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { @@ -655,8 +620,8 @@ InfoObjectMethodTypeCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -882,8 +847,9 @@ InfoClassConstrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -940,16 +906,16 @@ InfoClassDefnCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1009,8 +975,9 @@ InfoClassDestrCmd( } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } @@ -1087,17 +1054,17 @@ InfoClassForwardCmd( } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1223,7 +1190,7 @@ InfoClassMethodsCmd( Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - ckfree((char *) names); + ckfree(names); } } else { FOREACH_HASH_DECLS; @@ -1271,8 +1238,8 @@ InfoClassMethodTypeCmd( hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), NULL); return TCL_ERROR; @@ -1462,6 +1429,95 @@ InfoClassVariablesCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + TclOODeleteChain(callPtr); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 56da45d..ab54964 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -4,12 +4,10 @@ * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOOInt.h,v 1.18 2010/04/27 12:36:21 nijtmans Exp $ */ #ifndef TCL_OO_INTERNAL_H @@ -216,6 +214,8 @@ typedef struct Object { * class of classes, and should be treated * specially during teardown (and in a few * other spots). */ +#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the + * unknown method handler at that point. */ /* * And the definition of a class. Note that every class also has an associated @@ -320,6 +320,9 @@ typedef struct Foundation { * constructor. */ Tcl_Obj *destructorName; /* Shared object containing the "name" of a * destructor. */ + Tcl_Obj *clonedName; /* Shared object containing the name of a + * "<cloned>" pseudo-constructor. */ + Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ } Foundation; /* @@ -368,7 +371,7 @@ typedef struct CallContext { } CallContext; /* - * Bits for the 'flags' field of the call context. + * Bits for the 'flags' field of the call chain. */ #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ @@ -379,21 +382,6 @@ typedef struct CallContext { #define DESTRUCTOR 0x10 /* This is a destructor. */ /* - * Assorted flags for call frames. Note that bits 1 and 2 are already taken by - * Tcl itself. - */ - -#if 0 -#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's - * clientData field contains a CallContext - * reference. */ -#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of - * the [oo::define] command; the clientData - * field contains an Object reference that has - * been confirmed to refer to a class. */ -#endif - -/* * Structure containing definition information about basic class methods. */ @@ -428,30 +416,18 @@ MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData, - Tcl_Interp *interp, const int objc, - Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineVariablesObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -467,6 +443,9 @@ MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -475,6 +454,9 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, * Method implementations (in tclOOBasic.c). */ +MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -513,6 +495,7 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +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); @@ -520,6 +503,8 @@ MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Tcl_Obj *cacheInThisObj); +MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, + Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); @@ -538,20 +523,17 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_Obj *const *objv, int skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); -MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, + CallChain *callPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); -MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); /* * Include all the private API, generated from tclOO.decls. diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index b60fa7d..acafb18 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -1,29 +1,10 @@ /* - * $Id: tclOOIntDecls.h,v 1.14 2010/08/19 04:26:04 nijtmans Exp $ - * * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif -#endif - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclOO.decls script. - */ - /* !BEGIN!: Do not edit below this line. */ /* @@ -31,46 +12,46 @@ */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -79,7 +60,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -88,28 +69,28 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); typedef struct TclOOIntStubs { int magic; - const struct TclOOIntStubHooks *hooks; + void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ @@ -179,8 +160,4 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - #endif /* _TCLOOINTDECLS */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 1255f1d..28820e0 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,12 +3,10 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclOOMethod.c,v 1.28 2010/09/26 14:16:26 msofer Exp $ */ #ifdef HAVE_CONFIG_H @@ -41,6 +39,8 @@ typedef struct { Tcl_Obj *nameObj; /* The "name" of the command. */ Command cmd; /* The command structure. Mostly bogus. */ ExtraFrameInfo efi; /* Extra information used for [info frame]. */ + Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a + * recursive call returns. */ struct PNI pni; /* Specialist information used in the efi * field for this type of call. */ } PMFrameData; @@ -157,19 +157,19 @@ Tcl_NewInstanceMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); @@ -225,14 +225,14 @@ Tcl_NewMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); @@ -280,7 +280,7 @@ TclOODelMethodRef( Tcl_DecrRefCount(mPtr->namePtr); } - ckfree((char *) mPtr); + ckfree(mPtr); } } @@ -344,7 +344,7 @@ TclOONewProcInstanceMethod( if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); + pmPtr = ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -353,7 +353,7 @@ TclOONewProcInstanceMethod( method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { - ckfree((char *) pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -405,7 +405,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } - pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); + pmPtr = ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -418,7 +418,7 @@ TclOONewProcMethod( Tcl_DecrRefCount(argsObj); } if (method == NULL) { - ckfree((char *) pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -499,12 +499,12 @@ TclOOMakeProcInstanceMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -612,12 +612,12 @@ TclOOMakeProcMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -711,6 +711,13 @@ InvokeProcedureMethod( result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] + * won't crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (--pmPtr->refCount < 1) { @@ -752,6 +759,13 @@ FinalizePMCall( } /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + + /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! @@ -820,6 +834,14 @@ PushMethodCallFrame( } /* + * Save the old cmdPtr so that when this recursive call returns, we can + * restore it. To do otherwise causes crashes in [info frame] after we + * return from a recursive call. [Bug 3001438] + */ + + fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; + + /* * Compile the body. This operation may fail. */ @@ -845,7 +867,7 @@ PushMethodCallFrame( result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { - return result; + goto failureReturn; } /* @@ -856,7 +878,7 @@ PushMethodCallFrame( result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); if (result != TCL_OK) { - return result; + goto failureReturn; } fdPtr->framePtr->clientData = contextPtr; @@ -891,6 +913,15 @@ PushMethodCallFrame( } return TCL_OK; + + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + failureReturn: + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + return result; } /* @@ -929,7 +960,7 @@ ProcedureMethodVarResolver( Tcl_Var *varPtr) { int result; - Tcl_ResolvedVarInfo *rPtr; + Tcl_ResolvedVarInfo *rPtr = NULL; result = ProcedureMethodCompiledVarResolver(interp, varName, strlen(varName), contextNs, &rPtr); @@ -939,6 +970,14 @@ ProcedureMethodVarResolver( } *varPtr = rPtr->fetchProc(interp, rPtr); + + /* + * Must not retain reference to resolved information. [Bug 3105999] + */ + + if (rPtr != NULL) { + rPtr->deleteProc(rPtr); + } return (*varPtr? TCL_OK : TCL_CONTINUE); } @@ -956,8 +995,6 @@ ProcedureMethodCompiledVarConnect( int i, isNew, cacheIt, varLen, len; const char *match, *varName; - varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); - /* * Check that the variable is being requested in a context that is also a * method call; if not (i.e. we're evaluating in the object's namespace or @@ -984,6 +1021,7 @@ ProcedureMethodCompiledVarConnect( * either. */ + varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] @@ -1017,6 +1055,14 @@ ProcedureMethodCompiledVarConnect( } if (cacheIt) { infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr); + + /* + * We must keep a reference to the variable so everything will + * continue to work correctly even if it is unset; being unset does + * not end the life of the variable at this level. [Bug 3185009] + */ + + VarHashRefCount(infoPtr->cachedObjectVar)++; } return TclVarHashGetValue(hPtr); } @@ -1027,8 +1073,16 @@ ProcedureMethodCompiledVarDelete( { OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr; + /* + * Release the reference to the variable if we were holding it. + */ + + if (infoPtr->cachedObjectVar) { + VarHashRefCount(infoPtr->cachedObjectVar)--; + TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL); + } Tcl_DecrRefCount(infoPtr->variableObj); - ckfree((char *) infoPtr); + ckfree(infoPtr); } static int @@ -1053,7 +1107,7 @@ ProcedureMethodCompiledVarResolver( return TCL_CONTINUE; } - infoPtr = (OOResVarInfo *) ckalloc(sizeof(OOResVarInfo)); + infoPtr = ckalloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; @@ -1150,15 +1204,6 @@ ConstructorErrorHandler( const char *objectName, *kindName; int objectNameLen; - if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) { - /* - * Horrible hack to deal with certain constructors that must not add - * information to the error trace. - */ - - return; - } - if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; @@ -1224,7 +1269,7 @@ DeleteProcedureMethodRecord( if (pmPtr->deleteClientdataProc) { pmPtr->deleteClientdataProc(pmPtr->clientData); } - ckfree((char *) pmPtr); + ckfree(pmPtr); } static void @@ -1245,8 +1290,7 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = (ProcedureMethod *) - ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; @@ -1285,12 +1329,13 @@ TclOONewForwardInstanceMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } - fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); + fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); @@ -1326,12 +1371,13 @@ TclOONewForwardMethod( return NULL; } if (prefixLen < 1) { - Tcl_AppendResult(interp, "method forward prefix must be non-empty", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "method forward prefix must be non-empty", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } - fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); + fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); @@ -1415,7 +1461,7 @@ DeleteForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_DecrRefCount(fmPtr->prefixObj); - ckfree((char *) fmPtr); + ckfree(fmPtr); } static int @@ -1425,7 +1471,7 @@ CloneForwardMethod( ClientData *newClientData) { ForwardMethod *fmPtr = clientData; - ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); + ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; fm2Ptr->fullyQualified = fmPtr->fullyQualified; diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index ed1c4cd..900ab22 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -1,6 +1,4 @@ /* - * $Id: tclOOStubInit.c,v 1.12 2010/08/21 16:30:26 nijtmans Exp $ - * * This file is (mostly) automatically generated from tclOO.decls. * It is compiled and linked in with the tclOO package proper. */ diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 5a8c743..55f2378 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -1,5 +1,4 @@ /* - * $Id: tclOOStubLib.c,v 1.5 2010/01/25 20:26:18 nijtmans Exp $ * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ @@ -54,8 +53,9 @@ TclOOInitializeStubs( if (clientData == NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", - "package not present or incomplete", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s package; package not present or incomplete", + packageName)); return NULL; } else { const TclOOStubs * const stubsPtr = clientData; @@ -77,9 +77,9 @@ TclOOInitializeStubs( error: Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package", - " (requested version '", version, "', loaded version '", - actualVersion, "'): ", errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package" + " (requested version '%s', loaded version '%s'): %s", + packageName, version, actualVersion, errMsg)); return NULL; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index 0aed0c2..74cb29e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclObj.c,v 1.175 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" @@ -55,9 +53,9 @@ char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * 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, for sanity - * checking purposes. + * 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, + * for sanity checking purposes. */ typedef struct ObjData { @@ -81,7 +79,7 @@ typedef struct ObjData { typedef struct ThreadSpecificData { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function - * EvalTokensStandard() from a literal text + * TclSubstTokens() from a literal text * where bs+nl sequences occured in it, if * any. I.e. this table keeps track of * invisible and stripped continuation lines. @@ -164,6 +162,10 @@ typedef struct PendingObjData { static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData +#elif HAVE_FAST_TSD +static __thread PendingObjData pendingObjData; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ @@ -460,12 +462,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree((char *) objData); + ckfree(objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree((char *) tablePtr); + ckfree(tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -541,7 +543,7 @@ TclGetContLineTable(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } @@ -576,8 +578,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *) - ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); if (!newEntry) { /* @@ -816,7 +817,7 @@ TclThreadFinalizeContLines( Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - ckfree((char *) tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -1106,8 +1107,7 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; @@ -1120,7 +1120,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *) ckalloc(sizeof(ObjData)); + objData = ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1279,7 +1279,7 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *) ckalloc(bytesToAlloc); + basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; @@ -1330,7 +1330,7 @@ TclFreeObj( ObjInitDeletionContext(context); if (objPtr->refCount < -1) { - Tcl_Panic("Reference count for %lx was negative", objPtr); + Tcl_Panic("Reference count for %p was negative", objPtr); } /* @@ -1353,7 +1353,7 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); @@ -1365,7 +1365,7 @@ TclFreeObj( TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objToFree); + ckfree(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1486,7 +1486,7 @@ TclFreeObj( } } } -#endif +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -1512,7 +1512,6 @@ TclObjBeingDeleted( { return (objPtr->length == -1); } - /* *---------------------------------------------------------------------- @@ -1706,7 +1705,6 @@ Tcl_InvalidateStringRep( { TclInvalidateStringRep(objPtr); } - /* *---------------------------------------------------------------------- @@ -2267,6 +2265,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); } return TCL_ERROR; } @@ -2354,8 +2354,8 @@ UpdateStringOfDouble( Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); - objPtr->bytes = (char *) ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2550,8 +2550,8 @@ UpdateStringOfInt( len = TclFormatInt(buffer, objPtr->internalRep.longValue); - objPtr->bytes = ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, buffer); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2763,12 +2763,9 @@ Tcl_GetLongFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -2856,7 +2853,7 @@ UpdateStringOfWideInt( sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); - objPtr->bytes = ckalloc((unsigned) len + 1); + objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } @@ -3067,12 +3064,9 @@ Tcl_GetWideIntFromObj( } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3168,7 +3162,7 @@ FreeBignum( UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { - ckfree((char *) objPtr->internalRep.ptrAndLongRep.ptr); + ckfree(objPtr->internalRep.ptrAndLongRep.ptr); } objPtr->typePtr = NULL; } @@ -3253,13 +3247,13 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc((size_t) size); + stringVal = ckalloc(size); status = mp_toradix_n(&bignumVal, stringVal, 10, size); if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing null byte */ + objPtr->length = size - 1; /* size includes a trailing NUL byte. */ } /* @@ -3401,12 +3395,9 @@ GetBignumFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3566,6 +3557,24 @@ Tcl_SetBignumObj( TclSetBignumIntRep(objPtr, bignumValue); } +/* + *---------------------------------------------------------------------- + * + * TclSetBignumIntRep -- + * + * Install a bignum into the internal representation of an object. + * + * Results: + * None. + * + * Side effects: + * Object internal representation is updated and object type is set. The + * bignum value is cleared, since ownership has transferred to the + * object. + * + *---------------------------------------------------------------------- + */ + void TclSetBignumIntRep( Tcl_Obj *objPtr, @@ -3576,8 +3585,9 @@ TclSetBignumIntRep( /* * Clear the mp_int value. - * Don't call mp_clear() because it would free the digit array - * we just packed into the Tcl_Obj. + * + * Don't call mp_clear() because it would free the digit array we just + * packed into the Tcl_Obj. */ bignumValue->dp = NULL; @@ -3590,9 +3600,17 @@ TclSetBignumIntRep( * * TclGetNumberFromObj -- * + * Extracts a number (of any possible numeric type) from an object. + * * Results: + * Whether the extraction worked. The type is stored in the variable + * referred to by the typePtr argument, and a pointer to the + * representation is stored in the variable referred to by the + * clientDataPtr. * * Side effects: + * Can allocate thread-specific data for handling the copy-out space for + * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ @@ -3611,18 +3629,18 @@ TclGetNumberFromObj( } else { *typePtr = TCL_NUMBER_DOUBLE; } - *clientDataPtr = &(objPtr->internalRep.doubleValue); + *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &(objPtr->internalRep.longValue); + *clientDataPtr = &objPtr->internalRep.longValue; return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; - *clientDataPtr = &(objPtr->internalRep.wideValue); + *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } #endif @@ -3686,23 +3704,21 @@ Tcl_DbIncrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to incr ref count of " - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "incr ref count"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ ++(objPtr)->refCount; } @@ -3751,19 +3767,17 @@ Tcl_DbDecrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to decr ref count of " - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "decr ref count"); } /* @@ -3774,14 +3788,15 @@ Tcl_DbDecrRefCount( ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree((char *) objData); + ckfree(objData); } Tcl_DeleteHashEntry(hPtr); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3831,22 +3846,21 @@ Tcl_DbIsShared( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; + if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to check shared status of" - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "check shared status"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -3858,7 +3872,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif +#endif /* TCL_COMPILE_STATS */ return ((objPtr)->refCount > 1); } @@ -3912,11 +3926,10 @@ AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; - Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr = keyPtr; + Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); - hPtr->key.oneWordValue = (char *) objPtr; + hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; @@ -4009,7 +4022,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree((char *) hPtr); + ckfree(hPtr); } /* @@ -4204,7 +4217,7 @@ TclSetCmdNameObj( } cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr = ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; @@ -4280,7 +4293,7 @@ FreeCmdNameInternalRep( Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - ckfree((char *) resPtr); + ckfree(resPtr); } } objPtr->typePtr = NULL; @@ -4353,6 +4366,10 @@ SetCmdNameFromAny( Namespace *currNsPtr; register ResolvedCmdName *resPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Find the Command structure, if any, that describes the command called * "name". Build a ResolvedCmdName that holds a cached pointer to this @@ -4373,7 +4390,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* @@ -4387,7 +4404,7 @@ SetCmdNameFromAny( } } else { TclFreeIntRep(objPtr); - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr = ckalloc(sizeof(ResolvedCmdName)); resPtr->refCount = 1; objPtr->internalRep.twoPtrValue.ptr1 = resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -4445,11 +4462,8 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char refcountBuffer[TCL_INTEGER_SPACE+1]; - char objPtrBuffer[TCL_INTEGER_SPACE+3]; - char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2]; -#define TCLOBJ_TRUNCATE_STRINGREP 16 - char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1]; + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); @@ -4462,27 +4476,30 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(refcountBuffer, "%d", objv[1]->refCount); - sprintf(objPtrBuffer, "%p", (void *)objv[1]); - Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ? - objv[1]->typePtr->name : "pure string", " with a refcount of ", - refcountBuffer, ", object pointer at ", objPtrBuffer, NULL); + 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); + if (objv[1]->typePtr) { - sprintf(internalRepBuffer, "%p:%p", - (void *)objv[1]->internalRep.twoPtrValue.ptr1, - (void *)objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendResult(interp, ", internal representation ", - internalRepBuffer, NULL); + 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]->bytes) { - strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP); - stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0; - Tcl_AppendResult(interp, ", string representation \"", - stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ? - "\"..." : "\".", NULL); + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); } else { - Tcl_AppendResult(interp, ", no string representation.", NULL); + Tcl_AppendToObj(descObj, ", no string representation", -1); } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b3a5ed6..b87a8df 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -11,19 +11,23 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPanic.c,v 1.14 2009/07/22 19:54:50 nijtmans Exp $ */ #include "tclInt.h" -#undef Tcl_Panic +#if defined(_WIN32) || defined(__CYGWIN__) + MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); +#endif /* * The panicProc variable contains a pointer to an application specific panic * procedure. */ +#if defined(__CYGWIN__) +static Tcl_PanicProc *panicProc = tclWinDebugPanic; +#else static Tcl_PanicProc *panicProc = NULL; +#endif /* *---------------------------------------------------------------------- @@ -45,6 +49,10 @@ void Tcl_SetPanicProc( Tcl_PanicProc *proc) { +#if defined(_WIN32) + /* tclWinDebugPanic only installs if there is no panicProc yet. */ + if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#endif panicProc = proc; } @@ -85,12 +93,31 @@ Tcl_PanicVA( if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#ifdef _WIN32 + } else if (IsDebuggerPresent()) { + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#endif } else { fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); fprintf(stderr, "\n"); fflush(stderr); +#if defined(_WIN32) || defined(__CYGWIN__) +# if defined(__GNUC__) + __builtin_trap(); +# elif defined(_WIN64) + __debugbreak(); +# elif defined(_MSC_VER) + _asm {int 3} +# else + DebugBreak(); +# endif +#endif +#if defined(_WIN32) + ExitProcess(1); +#else abort(); +#endif } } diff --git a/generic/tclParse.c b/generic/tclParse.c index 0e55549..08615a7 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -11,10 +11,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * */ - + #include "tclInt.h" +#include "tclParse.h" /* * The following table provides parsing information about each possible 8-bit @@ -42,18 +42,7 @@ * TYPE_BRACE - Character is a curly brace (either left or right). */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 - -#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] - -static const char charTypeTable[] = { +const char tclCharTypeTable[] = { /* * Negative character values, from -128 to -1: */ @@ -269,7 +258,8 @@ Tcl_ParseCommand( if ((start == NULL) && (numBytes != 0)) { if (interp != NULL) { - Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't parse a NULL pointer", -1)); } return TCL_ERROR; } @@ -434,7 +424,7 @@ Tcl_ParseCommand( } if (isLiteral) { - int elemCount = 0, code = TCL_OK, nakedbs = 0; + int elemCount = 0, code = TCL_OK, literal = 1; const char *nextElem, *listEnd, *elemStart; /* @@ -456,33 +446,24 @@ Tcl_ParseCommand( */ while (nextElem < listEnd) { - int size, brace; + int size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, - &elemStart, &nextElem, &size, &brace); - if (code != TCL_OK) { + &elemStart, &nextElem, &size, &literal); + if ((code != TCL_OK) || !literal) { break; } - if (!brace) { - const char *s; - - for(s=elemStart;size>0;s++,size--) { - if ((*s)=='\\') { - nakedbs = 1; - break; - } - } - } if (elemStart < listEnd) { elemCount++; } } - if ((code != TCL_OK) || nakedbs) { + if ((code != TCL_OK) || !literal) { /* - * Some list element could not be parsed, or contained - * naked backslashes. This means the literal string was - * not in fact a valid nor canonical list. Defer the + * Some list element could not be parsed, or is not + * present as a literal substring of the script. The + * compiler cannot handle list elements that get generated + * by a call to TclCopyAndCollapse(). Defer the * handling of this to compile/eval time, where code is * already in place to report the "attempt to expand a * non-list" error or expand lists that require @@ -506,6 +487,7 @@ Tcl_ParseCommand( * tokens representing the expanded list. */ + const char *listStart; int growthNeeded = wordIndex + 2*elemCount - parsePtr->numTokens; @@ -525,14 +507,12 @@ Tcl_ParseCommand( * word value. */ - nextElem = tokenPtr[1].start; - while (isspace(UCHAR(*nextElem))) { - nextElem++; - } + listStart = nextElem = tokenPtr[1].start; while (nextElem < listEnd) { + int quoted; + tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; tokenPtr->numComponents = 1; - tokenPtr->start = nextElem; tokenPtr++; tokenPtr->type = TCL_TOKEN_TEXT; @@ -540,14 +520,13 @@ Tcl_ParseCommand( TclFindElement(NULL, nextElem, listEnd - nextElem, &(tokenPtr->start), &nextElem, &(tokenPtr->size), NULL); - if (tokenPtr->start + tokenPtr->size == listEnd) { - tokenPtr[-1].size = listEnd - tokenPtr[-1].start; - } else { - tokenPtr[-1].size = tokenPtr->start - + tokenPtr->size - tokenPtr[-1].start; - tokenPtr[-1].size += (isspace(UCHAR( - tokenPtr->start[tokenPtr->size])) == 0); - } + + quoted = (tokenPtr->start[-1] == '{' + || tokenPtr->start[-1] == '"') + && tokenPtr->start > listStart; + tokenPtr[-1].start = tokenPtr->start - quoted; + tokenPtr[-1].size = tokenPtr->start + tokenPtr->size + - tokenPtr[-1].start + quoted; tokenPtr++; } @@ -590,14 +569,14 @@ Tcl_ParseCommand( } if (src[-1] == '"') { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-quote", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); } parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; } else { if (interp != NULL) { - Tcl_SetResult(interp, "extra characters after close-brace", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); } parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; } @@ -617,6 +596,30 @@ Tcl_ParseCommand( /* *---------------------------------------------------------------------- * + * TclIsSpaceProc -- + * + * Report whether byte is in the set of whitespace characters used by + * Tcl to separate words in scripts or elements in lists. + * + * Results: + * Returns 1, if byte is in the set, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIsSpaceProc( + char byte) +{ + return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n'; +} + +/* + *---------------------------------------------------------------------- + * * ParseWhiteSpace -- * * Scans up to numBytes bytes starting at src, consuming white space @@ -732,17 +735,17 @@ int TclParseHex( const char *src, /* First character to parse. */ int numBytes, /* Max number of byes to scan */ - Tcl_UniChar *resultPtr) /* Points to storage provided by caller where - * the Tcl_UniChar resulting from the + int *resultPtr) /* Points to storage provided by caller where + * the character resulting from the * conversion is to be written. */ { - Tcl_UniChar result = 0; + int result = 0; register const char *p = src; while (numBytes--) { unsigned char digit = UCHAR(*p); - if (!isxdigit(digit)) { + if (!isxdigit(digit) || (result > 0x10fff)) { break; } @@ -796,7 +799,8 @@ TclParseBackslash( * written there. */ { register const char *p = src+1; - Tcl_UniChar result; + Tcl_UniChar unichar; + int result; int count; char buf[TCL_UTF_MAX]; @@ -853,7 +857,7 @@ TclParseBackslash( result = 0xb; break; case 'x': - count += TclParseHex(p+1, numBytes-1, &result); + count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); if (count == 2) { /* * No hexadigits -> This is just "x". @@ -868,7 +872,7 @@ TclParseBackslash( } break; case 'u': - count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); + count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result); if (count == 2) { /* * No hexadigits -> This is just "u". @@ -876,6 +880,15 @@ TclParseBackslash( result = 'u'; } break; + case 'U': + count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "U". + */ + result = 'U'; + } + break; case '\n': count--; do { @@ -894,17 +907,17 @@ TclParseBackslash( */ if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = UCHAR(*p - '0'); + result = *p - '0'; p++; if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ || (UCHAR(*p) >= '8')) { break; } count = 3; - result = UCHAR((result << 3) + (*p - '0')); + result = (result << 3) + (*p - '0'); p++; if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { + || (UCHAR(*p) >= '8') || (result >= 0x20)) { break; } count = 4; @@ -920,14 +933,15 @@ TclParseBackslash( */ if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ + count = Tcl_UtfToUniChar(p, &unichar) + 1; /* +1 for '\' */ } else { char utfBytes[TCL_UTF_MAX]; memcpy(utfBytes, p, (size_t) (numBytes - 1)); utfBytes[numBytes - 1] = '\0'; - count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1; } + result = unichar; break; } @@ -935,7 +949,7 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } - return Tcl_UniCharToUtf((int) result, dst); + return Tcl_UniCharToUtf(result, dst); } /* @@ -1104,7 +1118,7 @@ ParseTokens( } /* - * This is a variable reference. Call Tcl_ParseVarName to do all + * This is a variable reference. Call Tcl_ParseVarName to do all * the dirty work of parsing the name. */ @@ -1128,7 +1142,7 @@ ParseTokens( } /* - * Command substitution. Call Tcl_ParseCommand recursively (and + * Command substitution. Call Tcl_ParseCommand recursively (and * repeatedly) to parse the nested command(s), then throw away the * parse information. */ @@ -1162,8 +1176,8 @@ ParseTokens( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-bracket", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; @@ -1281,7 +1295,7 @@ Tcl_FreeParse( * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { - ckfree((char *) parsePtr->tokenPtr); + ckfree(parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } @@ -1398,8 +1412,8 @@ Tcl_ParseVarName( } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, - "missing close-brace for variable name", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace for variable name", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; @@ -1466,8 +1480,8 @@ Tcl_ParseVarName( } if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing )", - TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing )", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_PAREN; parsePtr->term = src; @@ -1742,7 +1756,8 @@ Tcl_ParseBraces( goto error; } - Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing close-brace", -1)); /* * Guess if the problem is due to comments by searching the source string @@ -1763,9 +1778,9 @@ Tcl_ParseBraces( openBrace = 0; break; case '#' : - if (openBrace && isspace(UCHAR(src[-1]))) { - Tcl_AppendResult(parsePtr->interp, - ": possible unbalanced brace in comment", NULL); + if (openBrace && TclIsSpaceProc(src[-1])) { + Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp), + ": possible unbalanced brace in comment", -1); goto error; } break; @@ -1844,7 +1859,8 @@ Tcl_ParseQuotedString( } if (*parsePtr->term != '"') { if (parsePtr->interp != NULL) { - Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "missing \"", -1)); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; @@ -1876,10 +1892,10 @@ Tcl_ParseQuotedString( * None. * * Side effects: - * The Tcl_Parse struct '*parsePtr' is filled with parse results. * The caller is expected to eventually call Tcl_FreeParse() to properly * cleanup the value written there. + * * If a parse error occurs, the Tcl_InterpState value '*statePtr' is * filled with the state created by that error. When *statePtr is written * to, the caller is expected to make the required calls to either @@ -2155,7 +2171,7 @@ TclSubstTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (int *) ckalloc(maxNumCL * sizeof(int)); + clPosition = ckalloc(maxNumCL * sizeof(int)); } adjust = 0; @@ -2173,8 +2189,8 @@ TclSubstTokens( break; case TCL_TOKEN_BS: - appendByteLength = Tcl_UtfBackslash(tokenPtr->start, NULL, - utfCharBytes); + appendByteLength = TclParseBackslash(tokenPtr->start, + tokenPtr->size, NULL, utfCharBytes); append = utfCharBytes; /* @@ -2205,7 +2221,7 @@ TclSubstTokens( if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *) ckrealloc((char *) clPosition, + clPosition = ckrealloc(clPosition, maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; @@ -2363,7 +2379,7 @@ TclSubstTokens( */ if (maxNumCL) { - ckfree((char *) clPosition); + ckfree(clPosition); } } else { Tcl_ResetResult(interp); diff --git a/generic/tclParse.h b/generic/tclParse.h new file mode 100644 index 0000000..20c609c --- /dev/null +++ b/generic/tclParse.h @@ -0,0 +1,17 @@ +/* + * Minimal set of shared macro definitions and declarations so that multiple + * source files can make use of the parsing table in tclParse.c + */ + +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 + +#define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)] + +MODULE_SCOPE const char tclCharTypeTable[]; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index fd4651f..2b9ff87 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPathObj.c,v 1.89 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" @@ -29,6 +27,8 @@ static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); static int FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); +static int MakePathFromNormalized(Tcl_Interp *interp, + Tcl_Obj *pathPtr); /* * Define the 'path' object type, which Tcl uses to represent file paths @@ -94,9 +94,7 @@ typedef struct FsPath { * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ - struct FilesystemRecord *fsRecPtr; - /* Pointer to the filesystem record entry to - * use for this path. */ + const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */ } FsPath; /* @@ -154,14 +152,8 @@ typedef struct FsPath { Tcl_Obj * TclFSNormalizeAbsolutePath( Tcl_Interp *interp, /* Interpreter to use */ - Tcl_Obj *pathPtr, /* Absolute path to normalize */ - ClientData *clientDataPtr) /* If non-NULL, then may be set to the - * fs-specific clientData for this path. This - * will happen when that extra information can - * be calculated efficiently as a side-effect - * of normalization. */ + Tcl_Obj *pathPtr) /* Absolute path to normalize */ { - ClientData clientData = NULL; const char *dirSep, *oldDirSep; int first = 1; /* Set to zero once we've passed the first * directory separator - we can't use '..' to @@ -271,6 +263,14 @@ TclFSNormalizeAbsolutePath( } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { linkObj = Tcl_FSLink(retVal, NULL, 0); + + /* Safety check in case driver caused sharing */ + if (Tcl_IsShared(retVal)) { + TclDecrRefCount(retVal); + retVal = Tcl_DuplicateObj(retVal); + Tcl_IncrRefCount(retVal); + } + if (linkObj != NULL) { /* * Got a link. Need to check if the link is relative @@ -295,11 +295,6 @@ TclFSNormalizeAbsolutePath( break; } } - if (Tcl_IsShared(retVal)) { - TclDecrRefCount(retVal); - retVal = Tcl_DuplicateObj(retVal); - Tcl_IncrRefCount(retVal); - } /* * We want the trailing slash. @@ -315,7 +310,12 @@ TclFSNormalizeAbsolutePath( */ TclDecrRefCount(retVal); - retVal = linkObj; + if (Tcl_IsShared(linkObj)) { + retVal = Tcl_DuplicateObj(linkObj); + TclDecrRefCount(linkObj); + } else { + retVal = linkObj; + } linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* @@ -427,17 +427,14 @@ TclFSNormalizeAbsolutePath( * for normalizing a path. */ - TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); + TclFSNormalizeToUniquePath(interp, retVal, 0); /* * Since we know it is a normalized path, we can actually convert this * object into an FsPath for greater efficiency */ - TclFSMakePathFromNormalized(interp, retVal, clientData); - if (clientDataPtr != NULL) { - *clientDataPtr = clientData; - } + MakePathFromNormalized(interp, retVal); /* * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs. @@ -569,8 +566,7 @@ TclPathPart( if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); - if (TclFSEpochOk(fsPathPtr->filesystemEpoch) - && (PATHFLAGS(pathPtr) != 0)) { + if (PATHFLAGS(pathPtr) != 0) { switch (portion) { case TCL_PATH_DIRNAME: { /* @@ -832,44 +828,39 @@ Tcl_FSJoinPath( * reference count. */ int elements) /* Number of elements to use (-1 = all) */ { - Tcl_Obj *res; - int i; - const Tcl_Filesystem *fsPtr = NULL; + Tcl_Obj *copy, *res; + int objc; + Tcl_Obj **objv; - if (elements < 0) { - if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { - return NULL; - } - } else { - /* - * Just make sure it is a valid list. - */ - - int listTest; - - if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { - return NULL; - } + if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { + return NULL; + } - /* - * Correct this if it is too large, otherwise we will waste our time - * joining null elements to the path. - */ + elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; + copy = TclListObjCopy(NULL, listObj); + Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); + res = TclJoinPath(elements, objv); + Tcl_DecrRefCount(copy); + return res; +} - if (elements > listTest) { - elements = listTest; - } - } +Tcl_Obj * +TclJoinPath( + int elements, + Tcl_Obj * const objv[]) +{ + Tcl_Obj *res; + int i; + const Tcl_Filesystem *fsPtr = NULL; res = NULL; for (i = 0; i < elements; i++) { - Tcl_Obj *elt, *driveName = NULL; int driveNameLength, strEltLen, length; Tcl_PathType type; char *strElt, *ptr; - - Tcl_ListObjIndex(NULL, listObj, i, &elt); + Tcl_Obj *driveName = NULL; + Tcl_Obj *elt = objv[i]; /* * This is a special case where we can be much more efficient, where @@ -883,9 +874,8 @@ Tcl_FSJoinPath( if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { - Tcl_Obj *tailObj; + Tcl_Obj *tailObj = objv[i+1]; - Tcl_ListObjIndex(NULL, listObj, i+1, &tailObj); type = TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; @@ -1077,11 +1067,17 @@ Tcl_FSJoinPath( if (sep != NULL) { separator = TclGetString(sep)[0]; } + /* Safety check in case the VFS driver caused sharing */ + if (Tcl_IsShared(res)) { + TclDecrRefCount(res); + res = Tcl_DuplicateObj(res); + Tcl_IncrRefCount(res); + } } if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - length++; + Tcl_GetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1158,7 +1154,6 @@ Tcl_FSConvertToPathType( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; } return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); @@ -1177,7 +1172,6 @@ Tcl_FSConvertToPathType( * UpdateStringOfFsPath(pathPtr); * } * FreeFsPathInternalRep(pathPtr); - * pathPtr->typePtr = NULL; * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); * } * } @@ -1270,7 +1264,6 @@ TclNewFSPathObj( { FsPath *fsPathPtr; Tcl_Obj *pathPtr; - ThreadSpecificData *tsdPtr; const char *p; int state = 0, count = 0; @@ -1298,10 +1291,8 @@ TclNewFSPathObj( return pathPtr; } - tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - pathPtr = Tcl_NewObj(); - fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); /* * Set up the path. @@ -1313,8 +1304,8 @@ TclNewFSPathObj( fsPathPtr->cwdPtr = dirPtr; Tcl_IncrRefCount(dirPtr); fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = NULL; + fsPathPtr->filesystemEpoch = 0; SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; @@ -1373,37 +1364,20 @@ AppendPath( const char *bytes; Tcl_Obj *copy = Tcl_DuplicateObj(head); - bytes = Tcl_GetStringFromObj(copy, &numBytes); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the - * Windows special case? Perhaps we should just check if cwd is a root - * volume. We should never get numBytes == 0 in this code path. + * This is likely buggy when dealing with virtual filesystem drivers + * that use some character other than "/" as a path separator. I know + * of no evidence that such a foolish thing exists. This solution was + * chosen so that "JoinPath" operations that pass through either path + * intrep produce the same results; that is, bugward compatibility. If + * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (bytes[numBytes-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - } - break; - - case TCL_PLATFORM_WINDOWS: - /* - * We need the extra 'numBytes != 2', and ':' checks because a volume - * relative path doesn't get a '/'. For example 'glob C:*cat*.exe' - * will return 'C:cat32.exe' - */ - - if (bytes[numBytes-1] != '/' && bytes[numBytes-1] != '\\') { - if (numBytes!= 2 || bytes[1] != ':') { - Tcl_AppendToObj(copy, "/", 1); - } - } - break; + bytes = Tcl_GetStringFromObj(tail, &numBytes); + if (numBytes == 0) { + Tcl_AppendToObj(copy, "/", 1); + } else { + TclpNativeJoinPath(copy, bytes); } - - Tcl_AppendObjToObj(copy, tail); return copy; } @@ -1441,8 +1415,7 @@ TclFSMakePathRelative( if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0 - && fsPathPtr->cwdPtr == cwdPtr) { + if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { return fsPathPtr->normPathPtr; } } @@ -1486,7 +1459,7 @@ TclFSMakePathRelative( /* *--------------------------------------------------------------------------- * - * TclFSMakePathFromNormalized -- + * MakePathFromNormalized -- * * Like SetFsPathFromAny, but assumes the given object is an absolute * normalized path. Only for internal use. @@ -1500,15 +1473,12 @@ TclFSMakePathRelative( *--------------------------------------------------------------------------- */ -int -TclFSMakePathFromNormalized( +static int +MakePathFromNormalized( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *pathPtr, /* The object to convert. */ - ClientData nativeRep) /* The native rep for the object, if known - * else NULL. */ + Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; @@ -1522,9 +1492,10 @@ TclFSMakePathFromNormalized( if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object" - "string representation", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find object string representation", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); } return TCL_ERROR; } @@ -1533,7 +1504,7 @@ TclFSMakePathFromNormalized( TclFreeIntRep(pathPtr); } - fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); /* * It's a pure normalized absolute path. @@ -1547,9 +1518,10 @@ TclFSMakePathFromNormalized( fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; - fsPathPtr->nativePathPtr = nativeRep; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsPtr = NULL; + /* Remember the epoch under which we decided pathPtr was normalized */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; @@ -1588,14 +1560,13 @@ Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, ClientData clientData) { - Tcl_Obj *pathPtr; + Tcl_Obj *pathPtr = NULL; FsPath *fsPathPtr; - FilesystemRecord *fsFromPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData, - &fsFromPtr); + if (fromFilesystem->internalToNormalizedProc != NULL) { + pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData); + } if (pathPtr == NULL) { return NULL; } @@ -1615,7 +1586,7 @@ Tcl_FSNewNativePath( TclFreeIntRep(pathPtr); } - fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; @@ -1626,9 +1597,8 @@ Tcl_FSNewNativePath( fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; - fsPathPtr->fsRecPtr = fsFromPtr; - fsPathPtr->fsRecPtr->fileRefCount++; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = fromFilesystem; + fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; @@ -1686,6 +1656,12 @@ Tcl_FSGetTranslatedPath( retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); srcFsPathPtr->translatedPathPtr = retObj; + if (translatedCwdPtr->typePtr == &tclFsPathType) { + srcFsPathPtr->filesystemEpoch + = PATHOBJ(translatedCwdPtr)->filesystemEpoch; + } else { + srcFsPathPtr->filesystemEpoch = 0; + } Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { @@ -1740,7 +1716,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; const char *orig = Tcl_GetStringFromObj(transPtr, &len); - char *result = ckalloc((unsigned) len+1); + char *result = ckalloc(len+1); memcpy(result, orig, (size_t) len+1); TclDecrRefCount(transPtr); @@ -1788,8 +1764,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int cwdLen, pathType; - ClientData clientData = NULL; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1801,7 +1776,12 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - copy = AppendPath(dir, fsPathPtr->normPathPtr); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + if (tailLen) { + copy = AppendPath(dir, fsPathPtr->normPathPtr); + } else { + copy = Tcl_DuplicateObj(dir); + } Tcl_IncrRefCount(dir); Tcl_IncrRefCount(copy); @@ -1822,7 +1802,7 @@ Tcl_FSGetNormalizedPath( * 2385549] ... */ - Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL); + Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy); Tcl_DecrRefCount(copy); copy = newCopy; @@ -1837,8 +1817,7 @@ Tcl_FSGetNormalizedPath( * will actually start off directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, - (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); } /* Now we need to construct the new path object. */ @@ -1881,15 +1860,6 @@ Tcl_FSGetNormalizedPath( TclDecrRefCount(dir); } - if (clientData != NULL) { - /* - * This may be unnecessary. It appears that the - * TclFSNormalizeToUniquePath call above should have already set - * this up. Not changing out of fear of the unknown. - */ - - fsPathPtr->nativePathPtr = clientData; - } PATHFLAGS(pathPtr) = 0; } @@ -1903,7 +1873,6 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { return NULL; } @@ -1911,7 +1880,6 @@ Tcl_FSGetNormalizedPath( } else if (fsPathPtr->normPathPtr == NULL) { int cwdLen; Tcl_Obj *copy; - ClientData clientData = NULL; copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); @@ -1923,17 +1891,12 @@ Tcl_FSGetNormalizedPath( * of the previously normalized 'dir'. This should be much faster! */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, - (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); fsPathPtr->normPathPtr = copy; Tcl_IncrRefCount(fsPathPtr->normPathPtr); - if (clientData != NULL) { - fsPathPtr->nativePathPtr = clientData; - } } } if (fsPathPtr->normPathPtr == NULL) { - ClientData clientData = NULL; Tcl_Obj *useThisCwd = NULL; int pureNormalized = 1; @@ -2015,12 +1978,7 @@ Tcl_FSGetNormalizedPath( */ fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, - absolutePath, - (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); - if (0 && (clientData != NULL)) { - fsPathPtr->nativePathPtr = - fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc(clientData); - } + absolutePath); /* * Check if path is pure normalized (this can only be the case if it @@ -2111,7 +2069,7 @@ Tcl_FSGetInternalRep( * not easily achievable with the current implementation. */ - if (srcFsPathPtr->fsRecPtr == NULL) { + if (srcFsPathPtr->fsPtr == NULL) { /* * This only usually happens in wrappers like TclpStat which create a * string object and pass it to TclpObjStat. Code which calls the @@ -2131,7 +2089,7 @@ Tcl_FSGetInternalRep( */ srcFsPathPtr = PATHOBJ(pathPtr); - if (srcFsPathPtr->fsRecPtr == NULL) { + if (srcFsPathPtr->fsPtr == NULL) { return NULL; } } @@ -2143,7 +2101,7 @@ Tcl_FSGetInternalRep( * for this is we ask what filesystem this path belongs to. */ - if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + if (fsPtr != srcFsPathPtr->fsPtr) { const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr); if (actualFs == fsPtr) { @@ -2156,7 +2114,7 @@ Tcl_FSGetInternalRep( Tcl_FSCreateInternalRepProc *proc; char *nativePathPtr; - proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; + proc = srcFsPathPtr->fsPtr->createInternalRepProc; if (proc == NULL) { return NULL; } @@ -2214,7 +2172,6 @@ TclFSEnsureEpochOk( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2225,8 +2182,8 @@ TclFSEnsureEpochOk( * Check whether the object is already assigned to a fs. */ - if (srcFsPathPtr->fsRecPtr != NULL) { - *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; + if (srcFsPathPtr->fsPtr != NULL) { + *fsPtrPtr = srcFsPathPtr->fsPtr; } return TCL_OK; } @@ -2250,10 +2207,9 @@ TclFSEnsureEpochOk( void TclFSSetPathDetails( Tcl_Obj *pathPtr, - FilesystemRecord *fsRecPtr, + const Tcl_Filesystem *fsPtr, ClientData clientData) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FsPath *srcFsPathPtr; /* @@ -2267,10 +2223,9 @@ TclFSSetPathDetails( } srcFsPathPtr = PATHOBJ(pathPtr); - srcFsPathPtr->fsRecPtr = fsRecPtr; + srcFsPathPtr->fsPtr = fsPtr; srcFsPathPtr->nativePathPtr = clientData; - srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; - fsRecPtr->fileRefCount++; + srcFsPathPtr->filesystemEpoch = TclFSEpoch(); } /* @@ -2359,10 +2314,6 @@ SetFsPathFromAny( FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; -#if defined(__CYGWIN__) && defined(__WIN32__) - int copied = 0; -#endif - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; @@ -2389,7 +2340,6 @@ SetFsPathFromAny( */ if (name[0] == '~') { - char *expandedUser; Tcl_DString temp; int split; char separator = '/'; @@ -2422,9 +2372,11 @@ SetFsPathFromAny( dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment " - "variable to expand path", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); } return TCL_ERROR; } @@ -2439,9 +2391,10 @@ SetFsPathFromAny( Tcl_DStringInit(&temp); if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", name+1, - "\" doesn't exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", name+1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); } Tcl_DStringFree(&temp); if (split != len) { @@ -2454,8 +2407,7 @@ SetFsPathFromAny( } } - expandedUser = Tcl_DStringValue(&temp); - transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); + transPtr = TclDStringToObj(&temp); if (split != len) { /* @@ -2500,51 +2452,29 @@ SetFsPathFromAny( transPtr = joined; } } - Tcl_DStringFree(&temp); } else { - transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL); + transPtr = TclJoinPath(1, &pathPtr); } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - /* - * In the Cygwin world, call conv_to_win32_path in order to use the - * mount table to translate the file name into something Windows will - * understand. Take care when converting empty strings! - */ - - name = Tcl_GetStringFromObj(transPtr, &len); - if (len > 0) { - cygwin_conv_to_win32_path(name, winbuf); - TclWinNoBackslash(winbuf); - if (Tcl_IsShared(transPtr)) { - copied = 1; - transPtr = Tcl_DuplicateObj(transPtr); - Tcl_IncrRefCount(transPtr); - } - Tcl_SetStringObj(transPtr, winbuf, -1); - } - } -#endif /* __CYGWIN__ && __WIN32__ */ - /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ - fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; if (transPtr != pathPtr) { Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + /* Redo translation when $env(HOME) changes */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); + } else { + fsPathPtr->filesystemEpoch = 0; } fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = NULL; /* * Free old representation before installing our new one. @@ -2554,12 +2484,6 @@ SetFsPathFromAny( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; -#if defined(__CYGWIN__) && defined(__WIN32__) - if (copied) { - Tcl_DecrRefCount(transPtr); - } -#endif - return TCL_OK; } @@ -2583,27 +2507,17 @@ FreeFsPathInternalRep( if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); } - if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsRecPtr != NULL) { + if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = - fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc; + fsPathPtr->fsPtr->freeInternalRepProc; if (freeProc != NULL) { freeProc(fsPathPtr->nativePathPtr); fsPathPtr->nativePathPtr = NULL; } } - if (fsPathPtr->fsRecPtr != NULL) { - fsPathPtr->fsRecPtr->fileRefCount--; - if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { - /* - * It has been unregistered already. - */ - - ckfree((char *) fsPathPtr->fsRecPtr); - } - } - ckfree((char *) fsPathPtr); + ckfree(fsPathPtr); pathPtr->typePtr = NULL; } @@ -2613,41 +2527,41 @@ DupFsPathInternalRep( Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */ { FsPath *srcFsPathPtr = PATHOBJ(srcPtr); - FsPath *copyFsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr != NULL) { + if (srcFsPathPtr->translatedPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->translatedPathPtr = copyPtr; + } else { copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != copyPtr) { + if (copyFsPathPtr->translatedPathPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } - } else { - copyFsPathPtr->translatedPathPtr = NULL; } - if (srcFsPathPtr->normPathPtr != NULL) { + if (srcFsPathPtr->normPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->normPathPtr = copyPtr; + } else { copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != copyPtr) { + if (copyFsPathPtr->normPathPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } - } else { - copyFsPathPtr->normPathPtr = NULL; } - if (srcFsPathPtr->cwdPtr != NULL) { - copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + if (copyFsPathPtr->cwdPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); - } else { - copyFsPathPtr->cwdPtr = NULL; } copyFsPathPtr->flags = srcFsPathPtr->flags; - if (srcFsPathPtr->fsRecPtr != NULL + if (srcFsPathPtr->fsPtr != NULL && srcFsPathPtr->nativePathPtr != NULL) { Tcl_FSDupInternalRepProc *dupProc = - srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; + srcFsPathPtr->fsPtr->dupInternalRepProc; if (dupProc != NULL) { copyFsPathPtr->nativePathPtr = @@ -2658,11 +2572,8 @@ DupFsPathInternalRep( } else { copyFsPathPtr->nativePathPtr = NULL; } - copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; + copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - if (copyFsPathPtr->fsRecPtr != NULL) { - copyFsPathPtr->fsRecPtr->fileRefCount++; - } copyPtr->typePtr = &tclFsPathType; } diff --git a/generic/tclPipe.c b/generic/tclPipe.c index cbefbc1..83fb818 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPipe.c,v 1.24 2010/06/14 12:58:13 nijtmans Exp $ */ #include "tclInt.h" @@ -108,9 +106,12 @@ FileForRedirect( if (msg) { Tcl_SetObjResult(interp, msg); } else { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(chan), "\" wasn't opened for ", - ((writing) ? "writing" : "reading"), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for %s", + Tcl_GetChannelName(chan), + ((writing) ? "writing" : "reading"))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADCHAN", NULL); } return NULL; } @@ -141,9 +142,10 @@ FileForRedirect( file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { - Tcl_AppendResult(interp, "couldn't ", - ((writing) ? "write" : "read"), " file \"", spec, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't %s file \"%s\": %s", + (writing ? "write" : "read"), spec, + Tcl_PosixError(interp))); return NULL; } *closePtr = 1; @@ -151,8 +153,9 @@ FileForRedirect( return file; badLastArg: - Tcl_AppendResult(interp, "can't specify \"", arg, - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", arg)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -185,7 +188,7 @@ Tcl_DetachPids( Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = (Detached *) ckalloc(sizeof(Detached)); + detPtr = ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; @@ -235,7 +238,7 @@ Tcl_ReapDetachedProcs(void) } else { prevPtr->nextPtr = detPtr->nextPtr; } - ckfree((char *) detPtr); + ckfree(detPtr); detPtr = nextPtr; } Tcl_MutexUnlock(&pipeMutex); @@ -283,7 +286,7 @@ TclCleanupChildren( for (i = 0; i < numPids; i++) { /* * We need to get the resolved pid before we wait on it as the windows - * implimentation of Tcl_WaitPid deletes the information such that any + * implementation of Tcl_WaitPid deletes the information such that any * following calls to TclpGetPid fail. */ @@ -303,8 +306,8 @@ TclCleanupChildren( msg = "child process lost (is SIGCHLD ignored or trapped?)"; } - Tcl_AppendResult(interp, "error waiting for process to exit: ", - msg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg)); } continue; } @@ -334,16 +337,19 @@ TclCleanupChildren( p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_AppendResult(interp, "child killed: ", p, "\n", 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_AppendResult(interp, "child suspended: ", p, "\n", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child suspended: %s\n", p)); } else { - Tcl_AppendResult(interp, - "child wait status didn't make sense\n", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child wait status didn't make sense\n", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "ODDWAITRESULT", msg1, NULL); } } } @@ -371,8 +377,9 @@ TclCleanupChildren( result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading stderr output file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading stderr output file: %s", + Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; Tcl_SetObjResult(interp, objPtr); @@ -390,7 +397,8 @@ TclCleanupChildren( */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { - Tcl_AppendResult(interp, "child process exited abnormally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child process exited abnormally", -1)); } return result; } @@ -539,8 +547,10 @@ TclCreatePipeline( } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } } @@ -565,8 +575,11 @@ TclCreatePipeline( if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { - Tcl_AppendResult(interp, "can't specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't specify \"%s\" as last word in command", + argv[i])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } skip = 2; @@ -673,8 +686,11 @@ TclCreatePipeline( */ if (i != argc-1) { - Tcl_AppendResult(interp, "must specify \"", argv[i], - "\" as last word in command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "must specify \"%s\" as last word in command", + argv[i])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } errorFile = outputFile; @@ -713,8 +729,10 @@ TclCreatePipeline( * We had a bar followed only by redirections. */ - Tcl_SetResult(interp, "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal use of | or |& in command", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", + NULL); goto error; } @@ -728,9 +746,9 @@ TclCreatePipeline( inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create input file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input file for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -741,9 +759,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { - Tcl_AppendResult(interp, - "couldn't create input pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create input pipe for command: %s", + Tcl_PosixError(interp))); goto error; } inputClose = 1; @@ -770,9 +788,9 @@ TclCreatePipeline( */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { - Tcl_AppendResult(interp, - "couldn't create output pipe for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create output pipe for command: %s", + Tcl_PosixError(interp))); goto error; } outputClose = 1; @@ -810,9 +828,9 @@ TclCreatePipeline( errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create error file for command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create error file for command: %s", + Tcl_PosixError(interp))); goto error; } *errFilePtr = errorFile; @@ -837,7 +855,7 @@ TclCreatePipeline( */ Tcl_ReapDetachedProcs(); - pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid))); + pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; @@ -883,8 +901,8 @@ TclCreatePipeline( } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } } @@ -990,7 +1008,7 @@ TclCreatePipeline( Tcl_DetachPids(1, &pidPtr[i]); } } - ckfree((char *) pidPtr); + ckfree(pidPtr); } numPids = -1; goto cleanup; @@ -1063,13 +1081,19 @@ Tcl_OpenCommandChannel( if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { - Tcl_AppendResult(interp, "can't read output from command:" - " standard output was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't read output from command:" + " standard output was redirected", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { - Tcl_AppendResult(interp, "can't write input to command:" - " standard input was redirected", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't write input to command:" + " standard input was redirected", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } } @@ -1078,8 +1102,9 @@ Tcl_OpenCommandChannel( numPids, pidPtr); if (channel == NULL) { - Tcl_AppendResult(interp, "pipe for command could not be created", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "pipe for command could not be created", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } return channel; @@ -1087,7 +1112,7 @@ Tcl_OpenCommandChannel( error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); - ckfree((char *) pidPtr); + ckfree(pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 82a683c..5b09ddb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -10,8 +10,6 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.44 2010/08/31 20:48:17 nijtmans Exp $ - * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. @@ -156,8 +154,10 @@ Tcl_PkgProvideEx( } return TCL_OK; } - Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "conflicting versions provided for package \"%s\": %s, then %s", + name, pkgPtr->version, version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -285,9 +285,10 @@ Tcl_PkgRequireEx( */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not " - "compiled with stub support", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Cannot load package \"%s\" in standalone executable:" + " This package is not compiled with stub support", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -355,6 +356,10 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } + /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for @@ -374,10 +379,12 @@ PkgRequireCore( */ if (pkgPtr->clientData != NULL) { - Tcl_AppendResult(interp, "circular package dependency: " - "attempt to provide ", name, " ", - (char *) pkgPtr->clientData, " requires ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; } @@ -424,7 +431,9 @@ PkgRequireCore( } } - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ if (reqc > 0) { /* Check satisfaction of requirements. */ @@ -491,10 +500,12 @@ PkgRequireCore( Tcl_ResetResult(interp); if (pkgPtr->version == NULL) { code = TCL_ERROR; - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, - " failed: no version of package ", name, - " provided", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); } else { char *pvi, *vi; @@ -512,21 +523,24 @@ PkgRequireCore( ckfree(vi); if (res != 0) { code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } } } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", name, - " ", versionToProvide, " failed: bad return code: ", - TclGetString(codePtr), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; } @@ -583,11 +597,9 @@ PkgRequireCore( Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad return code: ", - TclGetString(codePtr), NULL); - Tcl_DecrRefCount(codePtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); code = TCL_ERROR; } if (code == TCL_ERROR) { @@ -600,7 +612,9 @@ PkgRequireCore( } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } @@ -610,27 +624,29 @@ PkgRequireCore( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { + if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - } - if (satisfies) { - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + if (!satisfies) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } - return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; } /* @@ -709,10 +725,11 @@ Tcl_PkgPresentEx( } if (version != NULL) { - Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s %s is not present", name, version)); } else { - Tcl_AppendResult(interp, "package ", name, " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s is not present", name)); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; @@ -793,9 +810,9 @@ Tcl_PackageObjCmd( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + ckfree(availPtr); } - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } break; } @@ -838,7 +855,8 @@ Tcl_PackageObjCmd( if (res == 0){ if (objc == 4) { ckfree(argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); @@ -851,7 +869,7 @@ Tcl_PackageObjCmd( return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr = ckalloc(sizeof(PkgAvail)); DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -870,18 +888,25 @@ Tcl_PackageObjCmd( if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; - } - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } else { + Tcl_Obj *resultObj; + + resultObj = Tcl_NewObj(); + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( + Tcl_GetHashKey(tablePtr, hPtr), -1)); + } } + Tcl_SetObjResult(interp, resultObj); } break; case PKG_PRESENT: { const char *name; + if (objc < 3) { goto require; } @@ -936,7 +961,8 @@ Tcl_PackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPtr->version, -1)); } } return TCL_OK; @@ -998,7 +1024,8 @@ Tcl_PackageObjCmd( if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(iPtr->packageUnknown, -1)); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { @@ -1086,23 +1113,27 @@ Tcl_PackageObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; - } - argv2 = TclGetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + } else { + Tcl_Obj *resultObj = Tcl_NewObj(); + + argv2 = TclGetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(availPtr->version, -1)); + } } + Tcl_SetObjResult(interp, resultObj); } break; case PKG_VSATISFIES: { char *argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "version ?requirement ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); return TCL_ERROR; } @@ -1156,7 +1187,7 @@ FindPackage( hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr = ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; @@ -1204,9 +1235,9 @@ TclFreePackageInfo( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + ckfree(availPtr); } - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { @@ -1328,8 +1359,9 @@ CheckVersionAndConvert( error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1590,8 +1622,9 @@ CheckRequirement( * More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", - string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected versionMin-versionMax but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } @@ -1642,19 +1675,17 @@ AddRequirementsToResult( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + Tcl_Obj *result = Tcl_GetObjResult(interp); + int i, length; - for (i = 0; i < reqc; i++) { - int length; - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + for (i = 0; i < reqc; i++) { + const char *v = Tcl_GetStringFromObj(reqv[i], &length); - if ((length & 0x1) && (v[length/2] == '-') - && (strncmp(v, v+((length+1)/2), length/2) == 0)) { - Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); - } else { - Tcl_AppendResult(interp, " ", v, NULL); - } + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1683,15 +1714,15 @@ AddRequirementsToDString( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + int i; + if (reqc > 0) { for (i = 0; i < reqc; i++) { - Tcl_DStringAppend(dsPtr, " ", 1); - Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); + TclDStringAppendLiteral(dsPtr, " "); + TclDStringAppendObj(dsPtr, reqv[i]); } } else { - Tcl_DStringAppend(dsPtr, " 0-", -1); + TclDStringAppendLiteral(dsPtr, " 0-"); } } diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index abc66ad..466d535 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPkgConfig.c,v 1.6 2010/02/24 10:32:17 dkf Exp $ */ /* Note, the definitions in this module are influenced by the following C @@ -24,7 +22,7 @@ * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. - * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. + * - NDEBUG NSCMdt tcl is compiled with symbol info off. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * @@ -72,7 +70,7 @@ # define CFG_64 "0" #endif -#ifdef TCL_CFG_DEBUG +#ifndef NDEBUG # define CFG_DEBUG "1" #else # define CFG_DEBUG "0" diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 2ca31d5..e9b92fe 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -5,8 +5,6 @@ * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. - * - * RCS: @(#) $Id: tclPlatDecls.h,v 1.40 2010/08/19 04:26:03 nijtmans Exp $ */ #ifndef _TCLPLATDECLS @@ -33,7 +31,7 @@ * TCHAR is needed here for win32, so if it is not defined yet do it here. * This way, we don't need to include <tchar.h> just for one define. */ -#if defined(_WIN32) && !defined(_TCHAR_DEFINED) +#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(_TCHAR_DEFINED) # if defined(_UNICODE) typedef wchar_t TCHAR; # else @@ -48,7 +46,7 @@ * Exported function declarations: */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); @@ -71,9 +69,9 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( typedef struct TclPlatStubs { int magic; - const struct TclPlatStubHooks *hooks; + void *hooks; -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ @@ -97,7 +95,7 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ diff --git a/generic/tclPort.h b/generic/tclPort.h index e9d6046..7021b8d 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPort.h,v 1.18 2010/01/22 13:02:50 nijtmans Exp $ */ #ifndef _TCLPORT @@ -27,16 +25,6 @@ # include "tclUnixPort.h" #endif -#if defined(__CYGWIN__) -# define USE_PUTENV 1 -# define USE_PUTENV_FOR_UNSET 1 -/* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern char **__cygwin_environ; - DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *); -# define environ __cygwin_environ -# define timezone _timezone -#endif - #if !defined(LLONG_MIN) # ifdef TCL_WIDE_INT_IS_LONG # define LLONG_MIN LONG_MIN diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index a507650..411eb27 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPosixStr.c,v 1.17 2010/06/28 08:50:12 nijtmans Exp $ */ #include "tclInt.h" @@ -37,7 +35,7 @@ const char * Tcl_ErrnoId(void) { switch (errno) { -#ifdef E2BIG +#if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW)) case E2BIG: return "E2BIG"; #endif #ifdef EACCES @@ -205,7 +203,7 @@ Tcl_ErrnoId(void) #ifdef ELIBEXEC case ELIBEXEC: return "ELIBEXEC"; #endif -#ifdef ELIBMAX +#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED)) case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN @@ -496,7 +494,7 @@ Tcl_ErrnoMsg( int err) /* Error number (such as in errno variable). */ { switch (err) { -#ifdef E2BIG +#if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW)) case E2BIG: return "argument list too long"; #endif #ifdef EACCES @@ -664,7 +662,7 @@ Tcl_ErrnoMsg( #ifdef ELIBEXEC case ELIBEXEC: return "cannot exec a shared library directly"; #endif -#ifdef ELIBMAX +#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED)) case ELIBMAX: return "attempting to link in more shared libraries than system limit"; #endif diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index f90e4bc..0bd8f93 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPreserve.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -91,7 +89,7 @@ TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - ckfree((char *) refArray); + ckfree(refArray); refArray = NULL; inUse = 0; spaceAvl = 0; @@ -146,8 +144,7 @@ Tcl_Preserve( if (inUse == spaceAvl) { spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = (Reference *) ckrealloc((char *) refArray, - spaceAvl * sizeof(Reference)); + refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference)); } /* @@ -227,9 +224,9 @@ Tcl_Release( Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { - ckfree((char *) clientData); + ckfree(clientData); } else { - freeProc((char *) clientData); + freeProc(clientData); } } return; @@ -240,7 +237,7 @@ Tcl_Release( * Reference not found. This is a bug in the caller. */ - Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); + Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData); } /* @@ -280,7 +277,7 @@ Tcl_EventuallyFree( continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", clientData); + Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; @@ -294,9 +291,9 @@ Tcl_EventuallyFree( */ if (freeProc == TCL_DYNAMIC) { - ckfree((char *) clientData); + ckfree(clientData); } else { - freeProc((char *)clientData); + freeProc(clientData); } } @@ -330,9 +327,8 @@ TclHandleCreate( * be tracked for deletion. Must not be * NULL. */ { - HandleStruct *handlePtr; + HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct)); - handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG handlePtr->ptr2 = ptr; @@ -372,16 +368,16 @@ TclHandleFree( handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %x", handlePtr); + Tcl_Panic("using previously disposed TclHandle %p", handlePtr); } if (handlePtr->ptr2 != handlePtr->ptr) { - Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->ptr = NULL; if (handlePtr->refCount == 0) { - ckfree((char *) handlePtr); + ckfree(handlePtr); } } @@ -415,10 +411,10 @@ TclHandlePreserve( handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %x", handlePtr); + Tcl_Panic("using previously disposed TclHandle %p", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { - Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif @@ -456,16 +452,16 @@ TclHandleRelease( handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %x", handlePtr); + Tcl_Panic("using previously disposed TclHandle %p", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { - Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount--; if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { - ckfree((char *) handlePtr); + ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 315af88..933e7d2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclProc.c,v 1.182 2010/09/27 19:42:38 msofer Exp $ */ #include "tclInt.h" @@ -154,20 +152,25 @@ Tcl_ProcObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", 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_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -193,7 +196,7 @@ Tcl_ProcObjCmd( Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, procName, -1); @@ -255,11 +258,11 @@ Tcl_ProcObjCmd( && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -287,9 +290,9 @@ Tcl_ProcObjCmd( Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - ckfree((char *) cfOldPtr->line); + ckfree(cfOldPtr->line); cfOldPtr->line = NULL; - ckfree((char *) cfOldPtr); + ckfree(cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } @@ -332,7 +335,9 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - procArgs += 4; + int numBytes; + + procArgs +=4; while (*procArgs != '\0') { if (*procArgs != ' ') { goto done; @@ -344,12 +349,9 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetString(objv[3]); - while (*procBody != '\0') { - if (!isspace(UCHAR(*procBody))) { - goto done; - } - procBody++; + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { + goto done; } /* @@ -462,7 +464,7 @@ TclCreateProc( Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr = ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; @@ -493,6 +495,8 @@ TclCreateProc( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -515,15 +519,20 @@ TclCreateProc( goto procError; } if (fieldCount > 2) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); + ckfree(fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too many fields in argument specifier \"%s\"", + argArray[i])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); + ckfree(fieldValues); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument with no name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } @@ -547,17 +556,21 @@ TclCreateProc( } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is an array element", NULL); - ckfree((char *) fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is an array element", + fieldValues[0])); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is not a simple name", NULL); - ckfree((char *) fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is not a simple name", + fieldValues[0])); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; @@ -584,7 +597,9 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree((char *) fieldValues); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } @@ -603,7 +618,9 @@ TclCreateProc( "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", procName, fieldValues[0])); - ckfree((char *) fieldValues); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } } @@ -621,9 +638,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameLength + 1)); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -643,7 +658,7 @@ TclCreateProc( } else { localPtr->defValuePtr = NULL; } - strcpy(localPtr->name, fieldValues[0]); + memcpy(localPtr->name, fieldValues[0], nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -652,11 +667,11 @@ TclCreateProc( } } - ckfree((char *) fieldValues); + ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree((char *) argArray); + ckfree(argArray); return TCL_OK; procError: @@ -673,12 +688,12 @@ TclCreateProc( Tcl_DecrRefCount(defPtr); } - ckfree((char *) localPtr); + ckfree(localPtr); } - ckfree((char *) procPtr); + ckfree(procPtr); } if (argArray != NULL) { - ckfree((char *) argArray); + ckfree(argArray); } return TCL_ERROR; } @@ -757,8 +772,8 @@ TclGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -889,9 +904,8 @@ TclObjGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1109,6 +1123,8 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; + #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; #else @@ -1250,7 +1266,7 @@ InitResolvedLocals( if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - ckfree((char *) localPtr->resolveInfo); + ckfree(localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } @@ -1344,7 +1360,7 @@ TclFreeLocalCache( } } } - ckfree((char *) localCachePtr); + ckfree(localCachePtr); } static void @@ -1368,9 +1384,9 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache) - + (localCt-1)*sizeof(Tcl_Obj *) - + numArgs*sizeof(Var)); + localCachePtr = ckalloc(sizeof(LocalCache) + + (localCt - 1) * sizeof(Tcl_Obj *) + + numArgs * sizeof(Var)); namePtr = &localCachePtr->varName0; varPtr = (Var *) (namePtr + localCt); @@ -1772,6 +1788,7 @@ TclNRInterpProcCore( } #endif /*TCL_COMPILE_DEBUG*/ +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; @@ -1801,6 +1818,15 @@ TclNRInterpProcCore( iPtr->varFramePtr->objc - l - 1, (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + + TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, + iPtr->varFramePtr->objc - l - 1, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); + } +#endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. @@ -1856,10 +1882,10 @@ InterpProcNR2( * transform to an error now. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((result == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invoked \"%s\" outside of a loop", + ((result == TCL_BREAK) ? "break" : "continue"))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* @@ -1975,15 +2001,16 @@ TclProcCompileProc( if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a precompiled script jumped interps", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - bodyPtr->typePtr->freeIntRepProc(bodyPtr); - bodyPtr->typePtr = NULL; + TclFreeIntRep(bodyPtr); } } @@ -2038,8 +2065,16 @@ TclProcCompileProc( procPtr->lastLocalPtr = lastPtr; while (clPtr) { CompiledLocal *toFree = clPtr; + clPtr = clPtr->nextPtr; - ckfree((char *) toFree); + if (toFree->resolveInfo) { + if (toFree->resolveInfo->deleteProc) { + toFree->resolveInfo->deleteProc(toFree->resolveInfo); + } else { + ckfree(toFree->resolveInfo); + } + } + ckfree(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; } @@ -2182,7 +2217,7 @@ TclProcCleanupProc( if (resVarInfo->deleteProc) { resVarInfo->deleteProc(resVarInfo); } else { - ckfree((char *) resVarInfo); + ckfree(resVarInfo); } } @@ -2190,10 +2225,10 @@ TclProcCleanupProc( defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - ckfree((char *) localPtr); + ckfree(localPtr); localPtr = nextPtr; } - ckfree((char *) procPtr); + ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc @@ -2201,7 +2236,7 @@ TclProcCleanupProc( * procbody structures created by tbcload. */ - if (!iPtr) { + if (iPtr == NULL) { return; } @@ -2212,13 +2247,15 @@ TclProcCleanupProc( cfPtr = Tcl_GetHashValue(hePtr); - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); - cfPtr->data.eval.path = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + cfPtr->data.eval.path = NULL; + } + ckfree(cfPtr->line); + cfPtr->line = NULL; + ckfree(cfPtr); } - ckfree((char *) cfPtr->line); - cfPtr->line = NULL; - ckfree((char *) cfPtr); Tcl_DeleteHashEntry(hePtr); } @@ -2449,21 +2486,26 @@ SetLambdaFromAny( { Interp *iPtr = (Interp *) interp; const char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; - int objc, result; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; + int isNew, objc, result; + CmdFrame *cfPtr = NULL; Proc *procPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Convert objPtr to list type first; if it cannot be converted, or if its * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements(interp, objPtr, &objc, &objv); + result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - TclNewLiteralStringObj(errPtr, "can't interpret \""); - Tcl_AppendObjToObj(errPtr, objPtr); - Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); - Tcl_SetObjResult(interp, errPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't interpret \"%s\" as a lambda expression", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } @@ -2541,19 +2583,19 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - int isNew, buf[2]; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ + cfPtr = ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2564,9 +2606,6 @@ SetLambdaFromAny( cfPtr->cmd.str.cmd = NULL; cfPtr->cmd.str.len = 0; - - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew), cfPtr); } /* @@ -2578,6 +2617,8 @@ SetLambdaFromAny( } TclStackFree(interp, contextPtr); } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, + &isNew), cfPtr); /* * Set the namespace for this lambda: given by objv[2] understood as a @@ -2605,7 +2646,7 @@ SetLambdaFromAny( * conversion to lambdaType. */ - objPtr->typePtr->freeIntRepProc(objPtr); + TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; @@ -2889,26 +2930,28 @@ Tcl_DisassembleObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; - } else { - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); - return TCL_ERROR; - } + } - /* - * Compile (if uncompiled) and disassemble a procedure. - */ + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; case DISAS_SCRIPT: /* * Compile and disassemble a script. @@ -2941,8 +2984,10 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -2974,14 +3019,18 @@ Tcl_DisassembleObjCmd( methodBody: if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", - TclGetString(objv[3]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "body not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -3014,7 +3063,10 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6848960..6c1dc08 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclRegexp.c,v 1.34 2010/02/24 10:32:17 dkf Exp $ */ #include "tclInt.h" @@ -716,14 +714,14 @@ TclRegError( int status) /* Status code to report. */ { char buf[100]; /* ample in practice */ - char cbuf[100]; /* lots in practice */ + char cbuf[TCL_INTEGER_SPACE]; size_t n; const char *p; Tcl_ResetResult(interp); n = TclReError(status, NULL, buf, sizeof(buf)); p = (n > sizeof(buf)) ? "..." : ""; - Tcl_AppendResult(interp, msg, buf, p, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p)); sprintf(cbuf, "%d", status); (void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf)); @@ -907,7 +905,7 @@ CompileRegexp( * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp)); + regexpPtr = ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; regexpPtr->details.rm_extend.rm_so = -1; @@ -934,7 +932,7 @@ CompileRegexp( * Clean up and report errors in the interpreter, if possible. */ - ckfree((char *)regexpPtr); + ckfree(regexpPtr); if (interp) { TclRegError(interp, "couldn't compile regular expression pattern: ", status); @@ -949,10 +947,8 @@ CompileRegexp( */ if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { - regexpPtr->globObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&stringBuf), - Tcl_DStringLength(&stringBuf)); + regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); Tcl_IncrRefCount(regexpPtr->globObjPtr); - Tcl_DStringFree(&stringBuf); } else { regexpPtr->globObjPtr = NULL; } @@ -962,7 +958,7 @@ CompileRegexp( * the entire pattern. */ - regexpPtr->matches = (regmatch_t *) + regexpPtr->matches = ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* @@ -989,8 +985,8 @@ CompileRegexp( tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i]; tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } - tsdPtr->patterns[0] = ckalloc((unsigned) length+1); - strcpy(tsdPtr->patterns[0], string); + tsdPtr->patterns[0] = ckalloc(length + 1); + memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; @@ -1022,9 +1018,9 @@ FreeRegexp( TclDecrRefCount(regexpPtr->globObjPtr); } if (regexpPtr->matches) { - ckfree((char *) regexpPtr->matches); + ckfree(regexpPtr->matches); } - ckfree((char *) regexpPtr); + ckfree(regexpPtr); } /* diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index bd26b85..3b2433e 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclRegexp.h,v 1.16 2008/05/02 10:27:08 dkf Exp $ */ #ifndef _TCLREGEXP diff --git a/generic/tclResolve.c b/generic/tclResolve.c index 7a86427..974737e 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclResolve.c,v 1.12 2010/01/29 16:17:20 nijtmans Exp $ */ #include "tclInt.h" @@ -67,6 +65,7 @@ Tcl_AddInterpResolvers( { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; + unsigned len; /* * Since we're adding a new name resolution scheme, we must force all code @@ -102,9 +101,10 @@ Tcl_AddInterpResolvers( * list, so that it overrides existing schemes. */ - resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); - resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1)); - strcpy(resPtr->name, name); + resPtr = ckalloc(sizeof(ResolverScheme)); + len = strlen(name) + 1; + resPtr->name = ckalloc(len); + memcpy(resPtr->name, name, len); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; @@ -226,7 +226,7 @@ Tcl_RemoveInterpResolvers( *prevPtrPtr = resPtr->nextPtr; ckfree(resPtr->name); - ckfree((char *) resPtr); + ckfree(resPtr); return 1; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 18aae6c..9707f20 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclResult.c,v 1.62 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" @@ -77,7 +75,7 @@ Tcl_SaveInterpState( int status) /* status code for current operation */ { Interp *iPtr = (Interp *) interp; - InterpState *statePtr = (InterpState *) ckalloc(sizeof(InterpState)); + InterpState *statePtr = ckalloc(sizeof(InterpState)); statePtr->status = status; statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; @@ -207,7 +205,7 @@ Tcl_DiscardInterpState( Tcl_DecrRefCount(statePtr->errorStack); } Tcl_DecrRefCount(statePtr->objResult); - ckfree((char *) statePtr); + ckfree(statePtr); } /* @@ -333,7 +331,7 @@ Tcl_RestoreResult( */ if (iPtr->appendResult != NULL) { - ckfree((char *) iPtr->appendResult); + ckfree(iPtr->appendResult); } iPtr->appendResult = statePtr->appendResult; @@ -382,12 +380,10 @@ Tcl_DiscardResult( if (statePtr->result == statePtr->appendResult) { ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); } else if (statePtr->freeProc) { - if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else { - statePtr->freeProc(statePtr->result); - } + statePtr->freeProc(statePtr->result); } } @@ -430,13 +426,13 @@ Tcl_SetResult( int length = strlen(result); if (length > TCL_RESULT_SIZE) { - iPtr->result = ckalloc((unsigned) length+1); + iPtr->result = ckalloc(length + 1); iPtr->freeProc = TCL_DYNAMIC; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } - strcpy(iPtr->result, result); + memcpy(iPtr->result, result, (unsigned) length+1); } else { iPtr->result = (char *) result; iPtr->freeProc = freeProc; @@ -587,7 +583,7 @@ Tcl_GetObjResult( * result, then reset the string result. */ - if (*(iPtr->result) != 0) { + if (iPtr->result[0] != 0) { ResetObjResult(iPtr); objResultPtr = iPtr->objResultPtr; @@ -603,7 +599,7 @@ Tcl_GetObjResult( iPtr->freeProc = 0; } iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; + iPtr->result[0] = 0; } return iPtr->objResultPtr; } @@ -650,14 +646,14 @@ Tcl_AppendResultVA( * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] */ -#ifdef USE_DIRECT_INTERP_RESULT_ACCESS +#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_DIRECT_INTERP_RESULT_ACCESS */ +#endif /* USE_INTERP_RESULT */ } /* @@ -833,7 +829,7 @@ SetupAppendBuffer( } else { totalSpace *= 2; } - new = ckalloc((unsigned) totalSpace); + new = ckalloc(totalSpace); strcpy(new, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); @@ -982,14 +978,15 @@ ResetObjResult( TclNewObj(objResultPtr); Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; - } else if (objResultPtr->bytes != tclEmptyStringRep) { - if (objResultPtr->bytes != NULL) { - ckfree((char *) objResultPtr->bytes); + } else { + if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes) { + ckfree(objResultPtr->bytes); + } + objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->length = 0; } - objResultPtr->bytes = tclEmptyStringRep; - objResultPtr->length = 0; TclFreeIntRep(objResultPtr); - objResultPtr->typePtr = NULL; } } @@ -1107,9 +1104,7 @@ Tcl_SetObjErrorCode( * * Tcl_GetErrorLine -- * - * Results: - * - * Side effects: + * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1126,9 +1121,7 @@ Tcl_GetErrorLine( * * Tcl_SetErrorLine -- * - * Results: - * - * Side effects: + * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1275,7 +1268,8 @@ TclProcessReturn( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], + &valuePtr); if (valuePtr != NULL) { int infoLen; @@ -1286,7 +1280,8 @@ TclProcessReturn( iPtr->flags |= ERR_ALREADY_LOGGED; } } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], + &valuePtr); if (valuePtr != NULL) { int len, valueObjc; Tcl_Obj **valueObjv; @@ -1299,26 +1294,36 @@ TclProcessReturn( Tcl_IncrRefCount(newObj); iPtr->errorStack = newObj; } + /* * List extraction done after duplication to avoid moving the rug * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { + + if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, + valueObjv); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], + &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", NULL); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], + &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } @@ -1391,10 +1396,9 @@ TclMergeReturnOptions( * Value is not a legal dictionary. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", compare, - " value: expected dictionary but got \"", - TclGetString(objv[1]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s value: expected dictionary but got \"%s\"", + compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); goto error; @@ -1423,7 +1427,8 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) { + if (TclGetCompletionCodeFromObj(interp, valuePtr, + &code) == TCL_ERROR) { goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); @@ -1441,10 +1446,9 @@ TclMergeReturnOptions( * Value is not a legal level. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -level value: " - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -level value: expected non-negative integer but got" + " \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); goto error; } @@ -1463,10 +1467,10 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorcode. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorcode value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorcode value: expected a list but got \"%s\"", + TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", NULL); goto error; @@ -1485,21 +1489,24 @@ TclMergeReturnOptions( /* * Value is not a list, which is illegal for -errorstack. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -errorstack value: expected a list but got \"%s\"", + TclGetString(valuePtr))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", + NULL); goto error; } if (length % 2) { /* * Errorstack must always be an even-sized list */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "forbidden odd-sized list for -errorstack: \"%s\"", + TclGetString(valuePtr))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", + "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; } } @@ -1597,6 +1604,31 @@ Tcl_GetReturnOptions( /* *------------------------------------------------------------------------- * + * TclNoErrorStack -- + * + * Removes the -errorstack entry from an options dict to avoid reference + * cycles. + * + * Results: + * The (unshared) argument options dict, modified in -place. + * + *------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNoErrorStack( + Tcl_Interp *interp, + Tcl_Obj *options) +{ + Tcl_Obj **keys = GetKeys(); + + Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); + return options; +} + +/* + *------------------------------------------------------------------------- + * * Tcl_SetReturnOptions -- * * Accepts an interp and a dictionary of return options, and sets the @@ -1625,9 +1657,8 @@ Tcl_SetReturnOptions( Tcl_IncrRefCount(options); if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected dict but got \"", - TclGetString(options), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected dict but got \"%s\"", TclGetString(options))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, diff --git a/generic/tclScan.c b/generic/tclScan.c index 6d23950..ef7eedf 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclScan.c,v 1.35 2010/03/05 14:34:04 dkf Exp $ */ #include "tclInt.h" @@ -103,10 +101,9 @@ BuildCharSet( end += Tcl_UtfToUniChar(end, &ch); } - cset->chars = (Tcl_UniChar *) - ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); + cset->ranges = ckalloc(sizeof(struct Range) * nranges); } else { cset->ranges = NULL; } @@ -226,9 +223,9 @@ static void ReleaseCharSet( CharSet *cset) { - ckfree((char *)cset->chars); + ckfree(cset->chars); if (cset->ranges) { - ckfree((char *)cset->ranges); + ckfree(cset->ranges); } } @@ -264,6 +261,10 @@ ValidateFormat( int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; + Tcl_Obj *errorMsg; /* Place to build an error messages. Note that + * these are messy operations because we do + * not want to use the formatting engine; + * we're inside there! */ /* * Initialize an array that records the number of times a variable is @@ -331,9 +332,10 @@ ValidateFormat( gotSequential = 1; if (gotXpg) { mixedXPG: - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot mix \"%\" and \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -377,9 +379,10 @@ ValidateFormat( switch (ch) { case 'c': if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "field width may not be specified in %c conversion", - TCL_STATIC); + -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } /* @@ -390,9 +393,12 @@ ValidateFormat( if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, - "field size modifier may not be specified in %", buf, - " conversion", NULL); + errorMsg = Tcl_NewStringObj( + "field size modifier may not be specified in %", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, " conversion", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } /* @@ -409,8 +415,9 @@ ValidateFormat( break; case 'u': if (flags & SCAN_BIG) { - Tcl_SetResult(interp, - "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } break; @@ -445,13 +452,18 @@ ValidateFormat( } break; badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched [ in format string", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, "bad scan conversion character \"", buf, - "\"", NULL); + errorMsg = Tcl_NewStringObj( + "bad scan conversion character \"", -1); + Tcl_AppendToObj(errorMsg, buf, -1); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -495,9 +507,10 @@ ValidateFormat( } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is assigned by multiple \"%n$\" conversion specifiers", - TCL_STATIC); + -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* @@ -505,9 +518,10 @@ ValidateFormat( * and/or numVars != 0), then too many vars were given */ - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is not assigned by any conversion specifiers", - TCL_STATIC); + -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } } @@ -517,12 +531,14 @@ ValidateFormat( badIndex: if (gotXpg) { - Tcl_SetResult(interp, "\"%n$\" argument index out of range", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"%n$\" argument index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { - Tcl_SetResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "different numbers of variable names and field specifiers", - TCL_STATIC); + -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } error: @@ -592,7 +608,7 @@ Tcl_ScanObjCmd( */ if (totalVars > 0) { - objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * totalVars); + objs = ckalloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } @@ -994,9 +1010,14 @@ Tcl_ScanObjCmd( continue; } result++; - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i+3]), "\"", NULL); + + /* + * In case of multiple errors in setting variables, just report + * the first one. + */ + + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], + (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); @@ -1022,7 +1043,7 @@ Tcl_ScanObjCmd( } } if (objs != NULL) { - ckfree((char *) objs); + ckfree(objs); } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { @@ -1042,7 +1063,7 @@ Tcl_ScanObjCmd( } return code; } - + /* * Local Variables: * mode: c diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d0a5345..2d534a68 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1,6 +1,4 @@ /* - *---------------------------------------------------------------------- - * * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions @@ -13,10 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclStrToD.c,v 1.46 2010/05/21 12:43:29 nijtmans Exp $ - * - *---------------------------------------------------------------------- */ #include "tclInt.h" @@ -41,6 +35,11 @@ #endif /* + * Rounding controls. (Thanks a lot, Intel!) + */ + +#ifdef __i386 +/* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values * somewhat unpredictably. It is tempting to include fpu_control.h, but that @@ -48,41 +47,65 @@ * and ix86-isms are factored out here. */ -#if defined(__GNUC__) && defined(__i386) -typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); -#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) -#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) +#if defined(__GNUC__) +typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); + +#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) +#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) # define FPU_IEEE_ROUNDING 0x027f # define ADJUST_FPU_CONTROL_WORD -#endif +#define TCL_IEEE_DOUBLE_ROUNDING \ + fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ + fpu_control_t oldRoundingMode; \ + _FPU_GETCW(oldRoundingMode); \ + _FPU_SETCW(roundTo53Bits) +#define TCL_DEFAULT_DOUBLE_ROUNDING \ + _FPU_SETCW(oldRoundingMode) -/* Sun ProC needs sunmath for rounding control on x86 like gcc above. - * - * +/* + * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) +#elif defined(__sun) #include <sunmath.h> +#define TCL_IEEE_DOUBLE_ROUNDING \ + ieee_flags("set","precision","double",NULL) +#define TCL_DEFAULT_DOUBLE_ROUNDING \ + ieee_flags("clear","precision",NULL,NULL) + +/* + * Other platforms are assumed to always operate in full IEEE mode, so we make + * the macros to go in and out of that mode do nothing. + */ + +#else /* !__GNUC__ && !__sun */ +#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) +#endif +#else /* !__i386 */ +#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif /* - * MIPS floating-point units need special settings in control registers - * to use gradual underflow as we expect. This fix is for the MIPSpro - * compiler. + * MIPS floating-point units need special settings in control registers to use + * gradual underflow as we expect. This fix is for the MIPSpro compiler. */ + #if defined(__sgi) && defined(_COMPILER_VERSION) #include <sys/fpu.h> #endif + /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa -# define NAN_START 0x7ff4 -# define NAN_MASK (((Tcl_WideUInt) 1) << 50) +# define NAN_START 0x7ff4 +# define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else -# define NAN_START 0x7ff8 -# define NAN_MASK (((Tcl_WideUInt) 1) << 51) +# define NAN_START 0x7ff8 +# define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* @@ -90,6 +113,65 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); * runtime). */ +/* Magic constants */ + +#define LOG10_2 0.3010299956639812 +#define TWO_OVER_3LOG10 0.28952965460216784 +#define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 + +/* + * Definitions of the parts of an IEEE754-format floating point number. + */ + +#define SIGN_BIT 0x80000000 + /* Mask for the sign bit in the first word of + * a double. */ +#define EXP_MASK 0x7ff00000 + /* Mask for the exponent field in the first + * word of a double. */ +#define EXP_SHIFT 20 /* Shift count to make the exponent an + * integer. */ +#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) + /* Hidden 1 bit for the significand. */ +#define HI_ORDER_SIG_MASK 0x000fffff + /* Mask for the high-order part of the + * significand in the first word of a + * double. */ +#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ + | 0xffffffff) + /* Mask for the 52-bit significand. */ +#define FP_PRECISION 53 /* Number of bits of significand plus the + * hidden bit. */ +#define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */ + +/* + * Derived quantities. + */ + +#define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ +#define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ +#define BLETCH 0x10 /* Highest power of two that is greater than + * DBL_MAX_10_EXP, divided by 16. */ +#define DIGIT_GROUP 8 /* floor(DIGIT_BIT*log(2)/log(10)) */ + +/* + * Union used to dismantle floating point numbers. + */ + +typedef union Double { + struct { +#ifdef WORDS_BIGENDIAN + int word0; + int word1; +#else + int word1; + int word0; +#endif + } w; + double d; + Tcl_WideUInt q; +} Double; + static int maxpow10_wide; /* The powers of ten that can be represented * exactly as wide integers. */ static Tcl_WideUInt *pow10_wide; @@ -105,13 +187,11 @@ static int log2FLT_RADIX; /* Logarithm of the floating point radix. */ static int mantBits; /* Number of bits in a double's significand */ static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to * 5**256 */ -static double tiny = 0.0; /* The smallest representable double */ +static double tiny = 0.0; /* The smallest representable double. */ static int maxDigits; /* The maximum number of digits to the left of * the decimal point of a double. */ static int minDigits; /* The maximum number of digits to the right * of the decimal point in a double. */ -static int mantDIGIT; /* Number of mp_digit's needed to hold the - * significand of a double. */ static const double pow_10_2_n[] = { /* Inexact higher powers of ten. */ 1.0, 100.0, @@ -123,35 +203,171 @@ static const double pow_10_2_n[] = { /* Inexact higher powers of ten. */ 1.0e+128, 1.0e+256 }; + static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * Nokia's floating point has the words * reversed: if big-endian is 7654 3210, * and little-endian is 0123 4567, * then Nokia's FP is 4567 0123; - * little-endian within the 32-bit words - * but big-endian between them. */ + * little-endian within the 32-bit words but + * big-endian between them. */ + +/* + * Table of powers of 5 that are small enough to fit in an mp_digit. + */ + +static const mp_digit dpow5[13] = { + 1, 5, 25, 125, + 625, 3125, 15625, 78125, + 390625, 1953125, 9765625, 48828125, + 244140625 +}; + +/* + * Table of powers: pow5_13[n] = 5**(13*2**(n+1)) + */ + +static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52, + * 5**104, 5**208 */ +static const double tens[] = { + 1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09, + 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, + 1e20, 1e21, 1e22 +}; + +static const int itens [] = { + 1, + 10, + 100, + 1000, + 10000, + 100000, + 1000000, + 10000000, + 100000000 +}; + +static const double bigtens[] = { + 1e016, 1e032, 1e064, 1e128, 1e256 +}; +#define N_BIGTENS 5 + +static const int log2pow5[27] = { + 01, 3, 5, 7, 10, 12, 14, 17, 19, 21, + 24, 26, 28, 31, 33, 35, 38, 40, 42, 45, + 47, 49, 52, 54, 56, 59, 61 +}; +#define N_LOG2POW5 27 + +static const Tcl_WideUInt wuipow5[27] = { + (Tcl_WideUInt) 1, /* 5**0 */ + (Tcl_WideUInt) 5, + (Tcl_WideUInt) 25, + (Tcl_WideUInt) 125, + (Tcl_WideUInt) 625, + (Tcl_WideUInt) 3125, /* 5**5 */ + (Tcl_WideUInt) 3125*5, + (Tcl_WideUInt) 3125*25, + (Tcl_WideUInt) 3125*125, + (Tcl_WideUInt) 3125*625, + (Tcl_WideUInt) 3125*3125, /* 5**10 */ + (Tcl_WideUInt) 3125*3125*5, + (Tcl_WideUInt) 3125*3125*25, + (Tcl_WideUInt) 3125*3125*125, + (Tcl_WideUInt) 3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125, /* 5**15 */ + (Tcl_WideUInt) 3125*3125*3125*5, + (Tcl_WideUInt) 3125*3125*3125*25, + (Tcl_WideUInt) 3125*3125*3125*125, + (Tcl_WideUInt) 3125*3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125*3125, /* 5**20 */ + (Tcl_WideUInt) 3125*3125*3125*3125*5, + (Tcl_WideUInt) 3125*3125*3125*3125*25, + (Tcl_WideUInt) 3125*3125*3125*3125*125, + (Tcl_WideUInt) 3125*3125*3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125*3125*3125, /* 5**25 */ + (Tcl_WideUInt) 3125*3125*3125*3125*3125*5 /* 5**26 */ +}; /* * Static functions defined in this file. */ -static double AbsoluteValue(double v, int *signum); -static int AccumulateDecimalDigit(unsigned, int, +static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); -static double BignumToBiasedFrExp(const mp_int *big, int *machexp); -static int GetIntegerTimesPower(double v, mp_int *r, int *e); static double MakeHighPrecisionDouble(int signum, mp_int *significand, int nSigDigs, int exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, int exponent); +#ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); -static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); -static double Pow10TimesFrExp(int exponent, double fraction, - int *machexp); +#endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); +static void MulPow5(mp_int *, unsigned, mp_int *); +static int NormalizeRightward(Tcl_WideUInt *); +static int RequiredPrecision(Tcl_WideUInt); +static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, + int *); +static void TakeAbsoluteValue(Double *, int *); +static char * FormatInfAndNaN(Double *, int *, char **); +static char * FormatZero(int *, char **); +static int ApproximateLog10(Tcl_WideUInt, int, int); +static int BetterLog10(double, int, int *); +static void ComputeScale(int, int, int *, int *, int *, int *); +static void SetPrecisionLimits(int, int, int *, int *, int *, + int *); +static char * BumpUp(char *, char *, int *); +static int AdjustRange(double *, int); +static char * ShorteningQuickFormat(double, int, int, double, + char *, int *); +static char * StrictQuickFormat(double, int, int, double, + char *, int *); +static char * QuickConversion(double, int, int, int, int, int, int, + int *, char **); +static void CastOutPowersOf2(int *, int *, int *); +static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, + int, int, int, int, int, int, int, int, int, + int, int, int *, char **); +static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, + int, int, int, int, int, int, + int, int, int *, char **); +static int ShouldBankerRoundUpPowD(mp_int *, int, int); +static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, + int, int, int, mp_int *); +static char * ShorteningBignumConversionPowD(Double *dPtr, + int convType, Tcl_WideUInt bw, int b2, int b5, + int m2plus, int m2minus, int m5, + int sd, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversionPowD(Double *dPtr, int convType, + Tcl_WideUInt bw, int b2, int b5, + int sd, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static int ShouldBankerRoundUp(mp_int *, mp_int *, int); +static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, + mp_int *, int, int, mp_int *); +static char * ShorteningBignumConversion(Double *dPtr, int convType, + Tcl_WideUInt bw, int b2, + int m2plus, int m2minus, + int s2, int s5, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversion(Double *dPtr, int convType, + Tcl_WideUInt bw, int b2, + int s2, int s5, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static double BignumToBiasedFrExp(const mp_int *big, int *machexp); +static double Pow10TimesFrExp(int exponent, double fraction, + int *machexp); static double SafeLdExp(double fraction, int exponent); +#ifdef IEEE_FLOATING_POINT +static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); +#endif /* *---------------------------------------------------------------------- @@ -281,38 +497,38 @@ TclParseNumber( } state = INITIAL; enum State acceptState = INITIAL; - int signum = 0; /* Sign of the number being parsed */ + int signum = 0; /* Sign of the number being parsed. */ Tcl_WideUInt significandWide = 0; /* Significand of the number being parsed (if - * no overflow) */ + * no overflow). */ mp_int significandBig; /* Significand of the number being parsed (if - * it overflows significandWide) */ - int significandOverflow = 0;/* Flag==1 iff significandBig is used */ + * it overflows significandWide). */ + int significandOverflow = 0;/* Flag==1 iff significandBig is used. */ Tcl_WideUInt octalSignificandWide = 0; /* Significand of an octal number; needed * because we don't know whether a number with * a leading zero is octal or decimal until - * we've scanned forward to a '.' or 'e' */ + * we've scanned forward to a '.' or 'e'. */ mp_int octalSignificandBig; /* Significand of octal number once - * octalSignificandWide overflows */ + * octalSignificandWide overflows. */ int octalSignificandOverflow = 0; - /* Flag==1 if octalSignificandBig is used */ + /* Flag==1 if octalSignificandBig is used. */ int numSigDigs = 0; /* Number of significant digits in the decimal - * significand */ + * significand. */ int numTrailZeros = 0; /* Number of trailing zeroes at the current * point in the parse. */ int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal - * point */ + * point. */ int exponentSignum = 0; /* Signum of the exponent of a floating point - * number */ - long exponent = 0; /* Exponent of a floating point number */ - const char *p; /* Pointer to next character to scan */ - size_t len; /* Number of characters remaining after p */ + * number. */ + long exponent = 0; /* Exponent of a floating point number. */ + const char *p; /* Pointer to next character to scan. */ + size_t len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in - * an acceptable number */ + * an acceptable number. */ size_t acceptLen; /* Number of characters following that * point. */ - int status = TCL_OK; /* Status to return to caller */ + int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ @@ -344,7 +560,7 @@ TclParseNumber( * I, N, and whitespace. */ - if (isspace(UCHAR(c))) { + if (TclIsSpaceProc(c)) { if (flags & TCL_PARSE_NO_WHITESPACE) { goto endgame; } @@ -402,9 +618,9 @@ TclParseNumber( case ZERO: /* * Scanned a leading zero (perhaps with a + or -). Acceptable - * inputs are digits, period, X, b, and E. If 8 or 9 is encountered, - * the number can't be octal. This state and the OCTAL state - * differ only in whether they recognize 'X' and 'b'. + * inputs are digits, period, X, b, and E. If 8 or 9 is + * encountered, the number can't be octal. This state and the + * OCTAL state differ only in whether they recognize 'X' and 'b'. */ acceptState = state; @@ -864,7 +1080,7 @@ TclParseNumber( } /* FALLTHROUGH */ case sNANPAREN: - if (isspace(UCHAR(c))) { + if (TclIsSpaceProc(c)) { break; } if (numSigDigs < 13) { @@ -874,7 +1090,10 @@ TclParseNumber( d = 10 + c - 'a'; } else if (c >= 'A' && c <= 'F') { d = 10 + c - 'A'; + } else { + goto endgame; } + numSigDigs++; significandWide = (significandWide << 4) + d; state = sNANHEX; break; @@ -915,7 +1134,7 @@ TclParseNumber( * Accept trailing whitespace. */ - while (len != 0 && isspace(UCHAR(*p))) { + while (len != 0 && TclIsSpaceProc(*p)) { p++; len--; } @@ -998,7 +1217,7 @@ TclParseNumber( case OCTAL: /* - * Returning an octal integer. Final scaling step + * Returning an octal integer. Final scaling step. */ shift = 3 * numTrailZeros; @@ -1059,7 +1278,7 @@ TclParseNumber( case DECIMAL: significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1, &significandWide, &significandBig, significandOverflow); - if (!significandOverflow && (significandWide > MOST_BITS+signum)) { + if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } @@ -1115,16 +1334,16 @@ TclParseNumber( objPtr->typePtr = &tclDoubleType; if (exponentSignum) { - exponent = - exponent; + exponent = -exponent; } if (!significandOverflow) { objPtr->internalRep.doubleValue = MakeLowPrecisionDouble( signum, significandWide, numSigDigs, - (numTrailZeros + exponent - numDigitsAfterDp)); + numTrailZeros + exponent - numDigitsAfterDp); } else { objPtr->internalRep.doubleValue = MakeHighPrecisionDouble( signum, &significandBig, numSigDigs, - (numTrailZeros + exponent - numDigitsAfterDp)); + numTrailZeros + exponent - numDigitsAfterDp); } break; @@ -1141,12 +1360,12 @@ TclParseNumber( #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: - objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide); + objPtr->internalRep.doubleValue = MakeNaN(signum,significandWide); objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: - /* This case only to silence compiler warning */ + /* This case only to silence compiler warning. */ Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); } } @@ -1157,11 +1376,9 @@ TclParseNumber( if (status != TCL_OK) { if (interp != NULL) { - Tcl_Obj *msg; + Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", + expected); - TclNewLiteralStringObj(msg, "expected "); - Tcl_AppendToObj(msg, expected, -1); - Tcl_AppendToObj(msg, " but got \"", -1); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); if (state == BAD_OCTAL) { @@ -1218,7 +1435,7 @@ AccumulateDecimalDigit( Tcl_WideUInt w; /* - * Try wide multiplication first + * Try wide multiplication first. */ if (!bignumFlag) { @@ -1231,10 +1448,10 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { + || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { /* - * Wide multiplication will overflow. Expand the - * number to a bignum and fall through into the bignum case. + * Wide multiplication will overflow. Expand the number to a + * bignum and fall through into the bignum case. */ TclBNInitBignumFromWideUInt(bignumRepPtr, w); @@ -1242,6 +1459,7 @@ AccumulateDecimalDigit( /* * Wide multiplication. */ + *wideRepPtr = w * pow10_wide[numZeros+1] + digit; return 0; } @@ -1309,12 +1527,12 @@ AccumulateDecimalDigit( static double MakeLowPrecisionDouble( int signum, /* 1 if the number is negative, 0 otherwise */ - Tcl_WideUInt significand, /* Significand of the number */ - int numSigDigs, /* Number of digits in the significand */ - int exponent) /* Power of ten */ + Tcl_WideUInt significand, /* Significand of the number. */ + int numSigDigs, /* Number of digits in the significand. */ + int exponent) /* Power of ten. */ { - double retval; /* Value of the number */ - mp_int significandBig; /* Significand expressed as a bignum */ + double retval; /* Value of the number. */ + mp_int significandBig; /* Significand expressed as a bignum. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1324,15 +1542,7 @@ MakeLowPrecisionDouble( * ulp, so we need to change rounding mode to 53-bits. */ -#if defined(__GNUC__) && defined(__i386) - fpu_control_t roundTo53Bits = 0x027f; - fpu_control_t oldRoundingMode; - _FPU_GETCW(oldRoundingMode); - _FPU_SETCW(roundTo53Bits); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("set","precision","double",NULL); -#endif + TCL_IEEE_DOUBLE_ROUNDING; /* * Test for the easy cases. @@ -1347,10 +1557,12 @@ MakeLowPrecisionDouble( * without special handling. */ - retval = (double)(Tcl_WideInt)significand * pow10vals[exponent]; + retval = (double) + ((Tcl_WideInt)significand * pow10vals[exponent]); goto returnValue; } else { int diff = DBL_DIG - numSigDigs; + if (exponent-diff <= mmaxpow) { /* * 10**exponent is not an exact integer, but @@ -1359,8 +1571,8 @@ MakeLowPrecisionDouble( * with only one roundoff. */ - volatile double factor = - (double)(Tcl_WideInt)significand * pow10vals[diff]; + volatile double factor = (double) + ((Tcl_WideInt)significand * pow10vals[diff]); retval = factor * pow10vals[exponent-diff]; goto returnValue; } @@ -1373,7 +1585,8 @@ MakeLowPrecisionDouble( * only one rounding. */ - retval = (double)(Tcl_WideInt)significand / pow10vals[-exponent]; + retval = (double) + ((Tcl_WideInt)significand / pow10vals[-exponent]); goto returnValue; } } @@ -1402,12 +1615,7 @@ MakeLowPrecisionDouble( * On gcc on x86, restore the floating point mode word. */ -#if defined(__GNUC__) && defined(__i386) - _FPU_SETCW(oldRoundingMode); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("clear","precision",NULL,NULL); -#endif + TCL_DEFAULT_DOUBLE_ROUNDING; return retval; } @@ -1432,13 +1640,13 @@ MakeLowPrecisionDouble( static double MakeHighPrecisionDouble( - int signum, /* 1=negative, 0=nonnegative */ - mp_int *significand, /* Exact significand of the number */ - int numSigDigs, /* Number of significant digits */ - int exponent) /* Power of 10 by which to multiply */ + int signum, /* 1=negative, 0=nonnegative. */ + mp_int *significand, /* Exact significand of the number. */ + int numSigDigs, /* Number of significant digits. */ + int exponent) /* Power of 10 by which to multiply. */ { double retval; - int machexp; /* Machine exponent of a power of 10 */ + int machexp; /* Machine exponent of a power of 10. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1448,15 +1656,7 @@ MakeHighPrecisionDouble( * ulp, so we need to change rounding mode to 53-bits. */ -#if defined(__GNUC__) && defined(__i386) - fpu_control_t roundTo53Bits = 0x027f; - fpu_control_t oldRoundingMode; - _FPU_GETCW(oldRoundingMode); - _FPU_SETCW(roundTo53Bits); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("set","precision","double",NULL); -#endif + TCL_IEEE_DOUBLE_ROUNDING; /* * Quick checks for over/underflow. @@ -1515,12 +1715,8 @@ MakeHighPrecisionDouble( * On gcc on x86, restore the floating point mode word. */ -#if defined(__GNUC__) && defined(__i386) - _FPU_SETCW(oldRoundingMode); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("clear","precision",NULL,NULL); -#endif + TCL_DEFAULT_DOUBLE_ROUNDING; + return retval; } @@ -1539,8 +1735,8 @@ MakeHighPrecisionDouble( #ifdef IEEE_FLOATING_POINT static double MakeNaN( - int signum, /* Sign bit (1=negative, 0=nonnegative */ - Tcl_WideUInt tags) /* Tag bits to put in the NaN */ + int signum, /* Sign bit (1=negative, 0=nonnegative. */ + Tcl_WideUInt tags) /* Tag bits to put in the NaN. */ { union { Tcl_WideUInt iv; @@ -1578,28 +1774,28 @@ MakeNaN( static double RefineApproximation( - double approxResult, /* Approximate result of conversion */ - mp_int *exactSignificand, /* Integer significand */ - int exponent) /* Power of 10 to multiply by significand */ + double approxResult, /* Approximate result of conversion. */ + mp_int *exactSignificand, /* Integer significand. */ + int exponent) /* Power of 10 to multiply by significand. */ { int M2, M5; /* Powers of 2 and of 5 needed to put the * decimal and binary numbers over a common * denominator. */ - double significand; /* Sigificand of the binary number */ - int binExponent; /* Exponent of the binary number */ + double significand; /* Sigificand of the binary number. */ + int binExponent; /* Exponent of the binary number. */ int msb; /* Most significant bit position of an - * intermediate result */ + * intermediate result. */ int nDigits; /* Number of mp_digit's in an intermediate - * result */ + * result. */ mp_int twoMv; /* Approx binary value expressed as an exact - * integer scaled by the multiplier 2M */ + * integer scaled by the multiplier 2M. */ mp_int twoMd; /* Exact decimal value expressed as an exact - * integer scaled by the multiplier 2M */ - int scale; /* Scale factor for M */ - int multiplier; /* Power of two to scale M */ + * integer scaled by the multiplier 2M. */ + int scale; /* Scale factor for M. */ + int multiplier; /* Power of two to scale M. */ double num, den; /* Numerator and denominator of the correction - * term */ - double quot; /* Correction term */ + * term. */ + double quot; /* Correction term. */ double minincr; /* Lower bound on the absolute value of the * correction term. */ int i; @@ -1629,8 +1825,8 @@ RefineApproximation( M5 = 0; } else { M5 = -exponent; - if ((M5-1) > M2) { - M2 = M5-1; + if (M5 - 1 > M2) { + M2 = M5 - 1; } } @@ -1669,7 +1865,7 @@ RefineApproximation( mp_init_copy(&twoMd, exactSignificand); for (i=0; i<=8; ++i) { - if ((M5+exponent) & (1 << i)) { + if ((M5 + exponent) & (1 << i)) { mp_mul(&twoMd, pow5+i, &twoMd); } } @@ -1679,7 +1875,7 @@ RefineApproximation( /* * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction * term. Because 2M may well overflow a double, we need to scale the - * denominator by a factor of 2**binExponent-mantBits + * denominator by a factor of 2**binExponent-mantBits. */ scale = binExponent - mantBits - 1; @@ -1734,411 +1930,2387 @@ RefineApproximation( /* *---------------------------------------------------------------------- * - * TclDoubleDigits -- + * MultPow5 -- + * + * Multiply a bignum by a power of 5. + * + * Side effects: + * Stores base*5**n in result. + * + *---------------------------------------------------------------------- + */ + +inline static void +MulPow5( + mp_int *base, /* Number to multiply. */ + unsigned n, /* Power of 5 to multiply by. */ + mp_int *result) /* Place to store the result. */ +{ + mp_int *p = base; + int n13 = n / 13; + int r = n % 13; + + if (r != 0) { + mp_mul_d(p, dpow5[r], result); + p = result; + } + r = 0; + while (n13 != 0) { + if (n13 & 1) { + mp_mul(p, pow5_13+r, result); + p = result; + } + n13 >>= 1; + ++r; + } + if (p != result) { + mp_copy(p, result); + } +} + +/* + *---------------------------------------------------------------------- + * + * NormalizeRightward -- * - * Converts a double to a string of digits. + * Shifts a number rightward until it is odd (that is, until the least + * significant bit is nonzero. * * Results: - * Returns the position of the character in the string after which the - * decimal point should appear. Since the string contains only - * significant digits, the position may be less than zero or greater than - * the length of the string. + * Returns the number of bit positions by which the number was shifted. * * Side effects: - * Stores the digits in the given buffer and sets 'signum' according to - * the sign of the number. + * Shifts the number in place; *wPtr is replaced by the shifted number. * *---------------------------------------------------------------------- + */ + +inline static int +NormalizeRightward( + Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ +{ + int rv = 0; + Tcl_WideUInt w = *wPtr; + if (!(w & (Tcl_WideUInt) 0xffffffff)) { + w >>= 32; rv += 32; + } + if (!(w & (Tcl_WideUInt) 0xffff)) { + w >>= 16; rv += 16; + } + if (!(w & (Tcl_WideUInt) 0xff)) { + w >>= 8; rv += 8; + } + if (!(w & (Tcl_WideUInt) 0xf)) { + w >>= 4; rv += 4; + } + if (!(w & 0x3)) { + w >>= 2; rv += 2; + } + if (!(w & 0x1)) { + w >>= 1; ++rv; + } + *wPtr = w; + return rv; +} + +/* + *---------------------------------------------------------------------- + * + * RequiredPrecision -- + * + * Determines the number of bits needed to hold an intger. + * + * Results: + * Returns the position of the most significant bit (0 - 63). Returns 0 + * if the number is zero. + * + *---------------------------------------------------------------------- */ -int -TclDoubleDigits( - char *buffer, /* Buffer in which to store the result, must - * have at least 18 chars */ - double v, /* Number to convert. Must be finite, and not - * NaN */ - int *signum) /* Output: 1 if the number is negative. - * Should handle -0 correctly on the IEEE - * architecture. */ +static int +RequiredPrecision( + Tcl_WideUInt w) /* Number to interrogate. */ { - int e; /* Power of FLT_RADIX that satisfies - * v = f * FLT_RADIX**e */ - int lowOK, highOK; - mp_int r; /* Scaled significand. */ - mp_int s; /* Divisor such that v = r / s */ - int smallestSig; /* Flag == 1 iff v's significand is the - * smallest that can be represented. */ - mp_int mplus; /* Scaled epsilon: (r + 2* mplus) == v(+) - * where v(+) is the floating point successor - * of v. */ - mp_int mminus; /* Scaled epsilon: (r - 2*mminus) == v(-) - * where v(-) is the floating point - * predecessor of v. */ - mp_int temp; - int rfac2 = 0; /* Powers of 2 and 5 by which large */ - int rfac5 = 0; /* integers should be scaled. */ - int sfac2 = 0; - int sfac5 = 0; - int mplusfac2 = 0; - int mminusfac2 = 0; - char c; - int i, k, n; + int rv; + unsigned long wi; + + if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { + wi = (unsigned long) (w >> 32); rv = 32; + } else { + wi = (unsigned long) w; rv = 0; + } + if (wi & 0xffff0000) { + wi >>= 16; rv += 16; + } + if (wi & 0xff00) { + wi >>= 8; rv += 8; + } + if (wi & 0xf0) { + wi >>= 4; rv += 4; + } + if (wi & 0xc) { + wi >>= 2; rv += 2; + } + if (wi & 0x2) { + wi >>= 1; ++rv; + } + if (wi & 0x1) { + ++rv; + } + return rv; +} + +/* + *---------------------------------------------------------------------- + * + * DoubleToExpAndSig -- + * + * Separates a 'double' into exponent and significand. + * + * Side effects: + * Stores the significand in '*significand' and the exponent in '*expon' + * so that dv == significand * 2.0**expon, and significand is odd. Also + * stores the position of the leftmost 1-bit in 'significand' in 'bits'. + * + *---------------------------------------------------------------------- + */ + +inline static void +DoubleToExpAndSig( + double dv, /* Number to convert. */ + Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */ + int *expon, /* OUTPUT: Exponent to multiply the number + * by. */ + int *bits) /* OUTPUT: Number of significant bits. */ +{ + Double d; /* Number being converted. */ + Tcl_WideUInt z; /* Significand under construction. */ + int de; /* Exponent of the number. */ + int k; /* Bit count. */ + + d.d = dv; /* - * Split the number into absolute value and signum. + * Extract exponent and significand. */ - v = AbsoluteValue(v, signum); + de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT; + z = d.q & SIG_MASK; + if (de != 0) { + z |= HIDDEN_BIT; + k = NormalizeRightward(&z); + *bits = FP_PRECISION - k; + *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1); + } else { + k = NormalizeRightward(&z); + *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1) + 1; + *bits = RequiredPrecision(z); + } + *significand = z; +} + +/* + *---------------------------------------------------------------------- + * + * TakeAbsoluteValue -- + * + * Takes the absolute value of a 'double' including 0, Inf and NaN + * + * Side effects: + * The 'double' in *d is replaced with its absolute value. The signum is + * stored in 'sign': 1 for negative, 0 for nonnegative. + * + *---------------------------------------------------------------------- + */ + +inline static void +TakeAbsoluteValue( + Double *d, /* Number to replace with absolute value. */ + int *sign) /* Place to put the signum. */ +{ + if (d->w.word0 & SIGN_BIT) { + *sign = 1; + d->w.word0 &= ~SIGN_BIT; + } else { + *sign = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * FormatInfAndNaN -- + * + * Bailout for formatting infinities and Not-A-Number. + * + * Results: + * Returns one of the strings 'Infinity' and 'NaN'. The string returned + * must be freed by the caller using 'ckfree'. + * + * Side effects: + * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating + * NUL byte of the string if 'endPtr' is not NULL. + * + *---------------------------------------------------------------------- + */ + +inline static char * +FormatInfAndNaN( + Double *d, /* Exceptional number to format. */ + int *decpt, /* Decimal point to set to a bogus value. */ + char **endPtr) /* Pointer to the end of the formatted data */ +{ + char *retval; + + *decpt = 9999; + if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { + retval = ckalloc(9); + strcpy(retval, "Infinity"); + if (endPtr) { + *endPtr = retval + 8; + } + } else { + retval = ckalloc(4); + strcpy(retval, "NaN"); + if (endPtr) { + *endPtr = retval + 3; + } + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * FormatZero -- + * + * Bailout to format a zero floating-point number. + * + * Results: + * Returns the constant string "0" + * + * Side effects: + * Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating + * the string in '*endPtr' if 'endPtr' is not NULL. + * + *---------------------------------------------------------------------- + */ + +inline static char * +FormatZero( + int *decpt, /* Location of the decimal point. */ + char **endPtr) /* Pointer to the end of the formatted data */ +{ + char *retval = ckalloc(2); + + strcpy(retval, "0"); + if (endPtr) { + *endPtr = retval+1; + } + *decpt = 0; + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * ApproximateLog10 -- + * + * Computes a two-term Taylor series approximation to the common log of a + * number, and computes the number's binary log. + * + * Results: + * Return an approximation to floor(log10(bw*2**be)) that is either exact + * or 1 too high. + * + *---------------------------------------------------------------------- + */ + +inline static int +ApproximateLog10( + Tcl_WideUInt bw, /* Integer significand of the number. */ + int be, /* Power of two to scale bw. */ + int bbits) /* Number of bits of precision in bw. */ +{ + int i; /* Log base 2 of the number. */ + int k; /* Floor(Log base 10 of the number) */ + double ds; /* Mantissa of the number. */ + Double d2; /* - * Handle zero specially. + * Compute i and d2 such that d = d2*2**i, and 1 < d2 < 2. + * Compute an approximation to log10(d), + * log10(d) ~ log10(2) * i + log10(1.5) + * + (significand-1.5)/(1.5 * log(10)) */ - if (v == 0.0) { - *buffer++ = '0'; - *buffer++ = '\0'; - return 1; + d2.q = bw << (FP_PRECISION - bbits) & SIG_MASK; + d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT; + i = be + bbits - 1; + ds = (d2.d - 1.5) * TWO_OVER_3LOG10 + + LOG10_3HALVES_PLUS_FUDGE + LOG10_2 * i; + k = (int) ds; + if (k > ds) { + --k; } + return k; +} + +/* + *---------------------------------------------------------------------- + * + * BetterLog10 -- + * + * Improves the result of ApproximateLog10 for numbers in the range + * 1 .. 10**(TEN_PMAX)-1 + * + * Side effects: + * Sets k_check to 0 if the new result is known to be exact, and to 1 if + * it may still be one too high. + * + * Results: + * Returns the improved approximation to log10(d). + * + *---------------------------------------------------------------------- + */ +inline static int +BetterLog10( + double d, /* Original number to format. */ + int k, /* Characteristic(Log base 10) of the + * number. */ + int *k_check) /* Flag == 1 if k is inexact. */ +{ /* - * Find a large integer r, and integer e, such that - * v = r * FLT_RADIX**e - * and r is as small as possible. Also determine whether the significand - * is the smallest possible. + * Performance hack. If k is in the range 0..TEN_PMAX, then we can use a + * powers-of-ten table to check it. */ - smallestSig = GetIntegerTimesPower(v, &r, &e); + if (k >= 0 && k <= TEN_PMAX) { + if (d < tens[k]) { + k--; + } + *k_check = 0; + } else { + *k_check = 1; + } + return k; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeScale -- + * + * Prepares to format a floating-point number as decimal. + * + * Parameters: + * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. The + * significand of x requires bbits bits to represent. + * + * Results: + * Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5 + * exactly represents the value of the x/10**k. This value will lie in + * the range [1 .. 10), and allows for computing successive digits by + * multiplying sig%10 by 10. + * + *---------------------------------------------------------------------- + */ + +inline static void +ComputeScale( + int be, /* Exponent part of number: d = bw * 2**be. */ + int k, /* Characteristic of log10(number). */ + int *b2, /* OUTPUT: Power of 2 in the numerator. */ + int *b5, /* OUTPUT: Power of 5 in the numerator. */ + int *s2, /* OUTPUT: Power of 2 in the denominator. */ + int *s5) /* OUTPUT: Power of 5 in the denominator. */ +{ + /* + * Scale numerator and denominator powers of 2 so that the input binary + * number is the ratio of integers. + */ - lowOK = highOK = (mp_iseven(&r)); + if (be <= 0) { + *b2 = 0; + *s2 = -be; + } else { + *b2 = be; + *s2 = 0; + } /* - * We are going to want to develop integers r, s, mplus, and mminus such - * that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s and - * then scale either s or r, mplus, mminus by an appropriate power of ten. - * - * We actually do this by keeping track of the powers of 2 and 5 by which - * f is multiplied to yield v and by which 1 is multiplied to yield s, - * mplus, and mminus. + * Scale numerator and denominator so that the output decimal number is + * the ratio of integers. */ - if (e >= 0) { - int bits = e * log2FLT_RADIX; + if (k >= 0) { + *b5 = 0; + *s5 = k; + *s2 += k; + } else { + *b2 -= k; + *b5 = -k; + *s5 = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * SetPrecisionLimits -- + * + * Determines how many digits of significance should be computed (and, + * hence, how much memory need be allocated) for formatting a floating + * point number. + * + * Given that 'k' is floor(log10(x)): + * if 'shortest' format is used, there will be at most 18 digits in the + * result. + * if 'F' format is used, there will be at most 'ndigits' + k + 1 digits + * if 'E' format is used, there will be exactly 'ndigits' digits. + * + * Side effects: + * Adjusts '*ndigitsPtr' to have a valid value. Stores the maximum memory + * allocation needed in *iPtr. Sets '*iLimPtr' to the limiting number of + * digits to convert if k has been guessed correctly, and '*iLim1Ptr' to + * the limiting number of digits to convert if k has been guessed to be + * one too high. + * + *---------------------------------------------------------------------- + */ - if (!smallestSig) { - /* - * Normal case, m+ and m- are both FLT_RADIX**e - */ +inline static void +SetPrecisionLimits( + int convType, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_STEELE0, TCL_DD_E_FMT, + * TCL_DD_F_FMT. */ + int k, /* Floor(log10(number to convert)) */ + int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be + * adjusted if needed). */ + int *iPtr, /* OUT: Maximum number of digits to return. */ + int *iLimPtr, /* OUT: Number of digits of significance if + * the bignum method is used.*/ + int *iLim1Ptr) /* OUT: Number of digits of significance if + * the quick method is used. */ +{ + switch (convType) { + case TCL_DD_SHORTEST0: + case TCL_DD_STEELE0: + *iLimPtr = *iLim1Ptr = -1; + *iPtr = 18; + *ndigitsPtr = 0; + break; + case TCL_DD_E_FORMAT: + if (*ndigitsPtr <= 0) { + *ndigitsPtr = 1; + } + *iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr; + break; + case TCL_DD_F_FORMAT: + *iPtr = *ndigitsPtr + k + 1; + *iLimPtr = *iPtr; + *iLim1Ptr = *iPtr - 1; + if (*iPtr <= 0) { + *iPtr = 1; + } + break; + default: + *iPtr = -1; + *iLimPtr = -1; + *iLim1Ptr = -1; + Tcl_Panic("impossible conversion type in TclDoubleDigits"); + } +} + +/* + *---------------------------------------------------------------------- + * + * BumpUp -- + * + * Increases a string of digits ending in a series of nines to designate + * the next higher number. xxxxb9999... -> xxxx(b+1)0000... + * + * Results: + * Returns a pointer to the end of the adjusted string. + * + * Side effects: + * In the case that the string consists solely of '999999', sets it to + * "1" and moves the decimal point (*kPtr) one place to the right. + * + *---------------------------------------------------------------------- + */ - rfac2 = bits + 1; - sfac2 = 1; - mplusfac2 = bits; - mminusfac2 = bits; - } else { - /* - * If f is equal to the smallest significand, then we need another - * factor of FLT_RADIX in s to cope with stepping to the next - * smaller exponent when going to e's predecessor. - */ +inline static char * +BumpUp( + char *s, /* Cursor pointing one past the end of the + * string. */ + char *retval, /* Start of the string of digits. */ + int *kPtr) /* Position of the decimal point. */ +{ + while (*--s == '9') { + if (s == retval) { + ++(*kPtr); + *s = '1'; + return s+1; + } + } + ++*s; + ++s; + return s; +} + +/* + *---------------------------------------------------------------------- + * + * AdjustRange -- + * + * Rescales a 'double' in preparation for formatting it using the 'quick' + * double-to-string method. + * + * Results: + * Returns the precision that has been lost in the prescaling as a count + * of units in the least significant place. + * + *---------------------------------------------------------------------- + */ + +inline static int +AdjustRange( + double *dPtr, /* INOUT: Number to adjust. */ + int k) /* IN: floor(log10(d)) */ +{ + int ieps; /* Number of roundoff errors that have + * accumulated. */ + double d = *dPtr; /* Number to adjust. */ + double ds; + int i, j, j1; + + ieps = 2; + + if (k > 0) { + /* + * The number must be reduced to bring it into range. + */ + + ds = tens[k & 0xf]; + j = k >> 4; + if (j & BLETCH) { + j &= (BLETCH-1); + d /= bigtens[N_BIGTENS - 1]; + ieps++; + } + i = 0; + for (; j != 0; j>>=1) { + if (j & 1) { + ds *= bigtens[i]; + ++ieps; + } + ++i; + } + d /= ds; + } else if ((j1 = -k) != 0) { + /* + * The number must be increased to bring it into range. + */ + + d *= tens[j1 & 0xf]; + i = 0; + for (j = j1>>4; j; j>>=1) { + if (j & 1) { + ieps++; + d *= bigtens[i]; + } + ++i; + } + } - rfac2 = bits + log2FLT_RADIX + 1; - sfac2 = 1 + log2FLT_RADIX; - mplusfac2 = bits + log2FLT_RADIX; - mminusfac2 = bits; + *dPtr = d; + return ieps; +} + +/* + *---------------------------------------------------------------------- + * + * ShorteningQuickFormat -- + * + * Returns a 'quick' format of a double precision number to a string of + * digits, preferring a shorter string of digits if the shorter string is + * still within 1/2 ulp of the number. + * + * Results: + * Returns the string of digits. Returns NULL if the 'quick' method fails + * and the bignum method must be used. + * + * Side effects: + * Stores the position of the decimal point at '*kPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +ShorteningQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Buffer to receive the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ +{ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit. */ + int i; + + eps = 0.5 / tens[ilim-1] - eps; + i = 0; + for (;;) { + /* + * Convert a digit. + */ + + digit = (int) d; + d -= digit; + *s++ = '0' + digit; + + /* + * Truncate the conversion if the string of digits is within 1/2 ulp + * of the actual value. + */ + + if (d < eps) { + *kPtr = k; + return s; + } + if ((1. - d) < eps) { + *kPtr = k; + return BumpUp(s, retval, kPtr); + } + + /* + * Bail out if the conversion fails to converge to a sufficiently + * precise value. + */ + + if (++i >= ilim) { + return NULL; + } + + /* + * Bring the next digit to the integer part. + */ + + eps *= 10; + d *= 10.0; + } +} + +/* + *---------------------------------------------------------------------- + * + * StrictQuickFormat -- + * + * Convert a double precision number of a string of a precise number of + * digits, using the 'quick' double precision method. + * + * Results: + * Returns the digit string, or NULL if the bignum method must be used to + * do the formatting. + * + * Side effects: + * Stores the position of the decimal point in '*kPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +StrictQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Start of the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ +{ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit of the answer. */ + int i; + + eps *= tens[ilim-1]; + i = 1; + for (;;) { + /* + * Extract a digit. + */ + + digit = (int) d; + d -= digit; + if (d == 0.0) { + ilim = i; } + *s++ = '0' + digit; + + /* + * When the given digit count is reached, handle trailing strings of 0 + * and 9. + */ + + if (i == ilim) { + if (d > 0.5 + eps) { + *kPtr = k; + return BumpUp(s, retval, kPtr); + } else if (d < 0.5 - eps) { + while (*--s == '0') { + /* do nothing */ + } + s++; + *kPtr = k; + return s; + } else { + return NULL; + } + } + + /* + * Advance to the next digit. + */ + + ++i; + d *= 10.0; + } +} + +/* + *---------------------------------------------------------------------- + * + * QuickConversion -- + * + * Converts a floating point number the 'quick' way, when only a limited + * number of digits is required and floating point arithmetic can + * therefore be used for the intermediate results. + * + * Results: + * Returns the converted string, or NULL if the bignum method must be + * used. + * + *---------------------------------------------------------------------- + */ + +inline static char * +QuickConversion( + double e, /* Number to format. */ + int k, /* floor(log10(d)), approximately. */ + int k_check, /* 0 if k is exact, 1 if it may be too high */ + int flags, /* Flags passed to dtoa: + * TCL_DD_SHORTEN_FLAG */ + int len, /* Length of the return value. */ + int ilim, /* Number of digits to store. */ + int ilim1, /* Number of digits to store if we misguessed + * k. */ + int *decpt, /* OUTPUT: Location of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the terminal null + * byte. */ +{ + int ieps; /* Number of 1-ulp roundoff errors that have + * accumulated in the calculation. */ + Double eps; /* Estimated roundoff error. */ + char *retval; /* Returned string. */ + char *end; /* Pointer to the terminal null byte in the + * returned string. */ + volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ + + /* + * Bring d into the range [1 .. 10). + */ + + ieps = AdjustRange(&e, k); + d = e; + + /* + * If the guessed value of k didn't get d into range, adjust it by one. If + * that leaves us outside the range in which quick format is accurate, + * bail out. + */ + + if (k_check && d < 1. && ilim > 0) { + if (ilim1 < 0) { + return NULL; + } + ilim = ilim1; + --k; + d *= 10.0; + ++ieps; + } + + /* + * Compute estimated roundoff error. + */ + + eps.d = ieps * d + 7.; + eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT; + + /* + * Handle the peculiar case where the result has no significant digits. + */ + + retval = ckalloc(len + 1); + if (ilim == 0) { + d -= 5.; + if (d > eps.d) { + *retval = '1'; + *decpt = k; + return retval; + } else if (d < -eps.d) { + *decpt = k; + return retval; + } else { + ckfree(retval); + return NULL; + } + } + + /* + * Format the digit string. + */ + + if (flags & TCL_DD_SHORTEN_FLAG) { + end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); } else { + end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); + } + if (end == NULL) { + ckfree(retval); + return NULL; + } + *end = '\0'; + if (endPtr != NULL) { + *endPtr = end; + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * CastOutPowersOf2 -- + * + * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers of 2 + * from numerator and denominator in preparation for the 'bignum' method + * of floating point conversion. + * + *---------------------------------------------------------------------- + */ + +inline static void +CastOutPowersOf2( + int *b2, /* Power of 2 to multiply the significand. */ + int *m2, /* Power of 2 to multiply 1/2 ulp. */ + int *s2) /* Power of 2 to multiply the common + * denominator. */ +{ + int i; + + if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the + * numerator. */ + if (*m2 < *s2) { /* Find the lowest common denominator. */ + i = *m2; + } else { + i = *s2; + } + *b2 -= i; /* Reduce to lowest terms. */ + *m2 -= i; + *s2 -= i; + } +} + +/* + *---------------------------------------------------------------------- + * + * ShorteningInt64Conversion -- + * + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The numerator and denominator in + * David Gay's conversion algorithm are known to fit in Tcl_WideUInt, + * giving considerably faster arithmetic than mp_int's. + * + * Results: + * Returns the string of significant decimal digits, in newly allocated + * memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +ShorteningInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ +{ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; + /* Numerator of the fraction being + * converted. */ + Tcl_WideUInt S = wuipow5[s5] << s2; + /* Denominator of the fraction being + * converted. */ + Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result is + * within roundoff of being exact. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ + + /* + * Adjust if the logarithm was guessed wrong. + */ + + if (b < S) { + b = 10 * b; + ++m2plus; ++m2minus; ++m5; + ilim = ilim1; + --k; + } + + /* + * Compute roundoff ranges. + */ + + mplus = wuipow5[m5] << m2plus; + mminus = wuipow5[m5] << m2minus; + + /* + * Loop through the digits. + */ + + i = 1; + for (;;) { + digit = (int)(b / S); + if (digit > 10) { + Tcl_Panic("wrong digit!"); + } + b = b % S; + /* - * v has digits after the binary point + * Does the current digit put us on the low side of the exact value + * but within within roundoff of being exact? */ - if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) { + if (b < mplus || (b == mplus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* - * Either f isn't the smallest significand or e is the smallest - * exponent. mplus and mminus will both be 1. + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. */ - rfac2 = 1; - sfac2 = 1 - e * log2FLT_RADIX; - mplusfac2 = 0; - mminusfac2 = 0; - } else { + if (2 * b > S || (2 * b == S && (digit & 1) != 0)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + } + /* - * f is the smallest significand, but e is not the smallest - * exponent. We need to scale by FLT_RADIX again to cope with the - * fact that v's predecessor has a smaller exponent. + * Stash the current digit. */ - rfac2 = 1 + log2FLT_RADIX; - sfac2 = 1 + log2FLT_RADIX * (1 - e); - mplusfac2 = FLT_RADIX; - mminusfac2 = 0; + *s++ = '0' + digit; + break; } + + /* + * Does one plus the current digit put us within roundoff of the + * number? + */ + + if (b > S - mminus || (b == S - mminus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + if (digit == 9) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + ++digit; + *s++ = '0' + digit; + break; + } + + /* + * Have we converted all the requested digits? + */ + + *s++ = '0' + digit; + if (i == ilim) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { + s = BumpUp(s, retval, &k); + } + break; + } + + /* + * Advance to the next digit. + */ + + b = 10 * b; + mplus = 10 * mplus; + mminus = 10 * mminus; + ++i; } /* - * Estimate the highest power of ten that will be needed to hold the - * result. + * Endgame - store the location of the decimal point and the end of the + * string. */ - k = (int) ceil(log(v) / log(10.)); - if (k >= 0) { - sfac2 += k; - sfac5 = k; - } else { - rfac2 -= k; - mplusfac2 -= k; - mminusfac2 -= k; - rfac5 = -k; + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * StrictInt64Conversion -- + * + * Converts a double-precision number to a fixed-length string of 'ilim' + * digits that reconverts exactly to the given number. ('ilim' should be + * replaced with 'ilim1' in the case where log10(d) has been + * overestimated). The numerator and denominator in David Gay's + * conversion algorithm are known to fit in Tcl_WideUInt, giving + * considerably faster arithmetic than mp_int's. + * + * Results: + * Returns the string of significant decimal digits, in newly allocated + * memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +StrictInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ +{ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; + /* Numerator of the fraction being + * converted. */ + Tcl_WideUInt S = wuipow5[s5] << s2; + /* Denominator of the fraction being + * converted. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ + + /* + * Adjust if the logarithm was guessed wrong. + */ + + if (b < S) { + b = 10 * b; + ilim = ilim1; + --k; } /* - * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5. + * Loop through the digits. */ - mp_init_set(&mplus, 1); - for (i=0 ; i<=8 ; ++i) { - if (rfac5 & (1 << i)) { - mp_mul(&mplus, pow5+i, &mplus); + i = 1; + for (;;) { + digit = (int)(b / S); + if (digit > 10) { + Tcl_Panic("wrong digit!"); + } + b = b % S; + + /* + * Have we converted all the requested digits? + */ + + *s++ = '0' + digit; + if (i == ilim) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { + s = BumpUp(s, retval, &k); + } else { + while (*--s == '0') { + /* do nothing */ + } + ++s; + } + break; } + + /* + * Advance to the next digit. + */ + + b = 10 * b; + ++i; + } + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * ShouldBankerRoundUpPowD -- + * + * Test whether bankers' rounding should round a digit up. Assumption is + * made that the denominator of the fraction being tested is a power of + * 2**DIGIT_BIT. + * + * Results: + * Returns 1 iff the fraction is more than 1/2, or if the fraction is + * exactly 1/2 and the digit is odd. + * + *---------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUpPowD( + mp_int *b, /* Numerator of the fraction. */ + int sd, /* Denominator is 2**(sd*DIGIT_BIT). */ + int isodd) /* 1 if the digit is odd, 0 if even. */ +{ + int i; + static const mp_digit topbit = 1 << (DIGIT_BIT - 1); + + if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { + return 0; + } + if (b->dp[sd-1] != topbit) { + return 1; } - mp_mul(&r, &mplus, &r); - mp_mul_2d(&r, rfac2, &r); - mp_init_copy(&mminus, &mplus); - mp_mul_2d(&mplus, mplusfac2, &mplus); - mp_mul_2d(&mminus, mminusfac2, &mminus); - mp_init_set(&s, 1); - for (i=0 ; i<=8 ; ++i) { - if (sfac5 & (1 << i)) { - mp_mul(&s, pow5+i, &s); + for (i = sd-2; i >= 0; --i) { + if (b->dp[i] != 0) { + return 1; } } - mp_mul_2d(&s, sfac2, &s); + return isodd; +} + +/* + *---------------------------------------------------------------------- + * + * ShouldBankerRoundUpToNextPowD -- + * + * Tests whether bankers' rounding will round down in the "denominator is + * a power of 2**MP_DIGIT" case. + * + * Results: + * Returns 1 if the rounding will be performed - which increases the + * digit by one - and 0 otherwise. + * + *---------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUpToNextPowD( + mp_int *b, /* Numerator of the fraction. */ + mp_int *m, /* Numerator of the rounding tolerance. */ + int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */ + int convType, /* Conversion type: STEELE defeats + * round-to-even (not sure why one wants to do + * this; I copied it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area for the calculation. */ +{ + int i; /* - * It is possible for k to be off by one because we used an inexact - * logarithm. + * Compare B and S-m - which is the same as comparing B+m and S - which we + * do by computing b+m and doing a bitwhack compare against + * 2**(DIGIT_BIT*sd) */ - mp_init(&temp); - mp_add(&r, &mplus, &temp); - i = mp_cmp_mag(&temp, &s); - if (i>0 || (highOK && i==0)) { - mp_mul_d(&s, 10, &s); - k++; - } else { - mp_mul_d(&temp, 10, &temp); - i = mp_cmp_mag(&temp, &s); - if (i<0 || (highOK && i==0)) { - mp_mul_d(&r, 10, &r); - mp_mul_d(&mplus, 10, &mplus); - mp_mul_d(&mminus, 10, &mminus); - k--; + mp_add(b, m, temp); + if (temp->used <= sd) { /* Too few digits to be > s */ + return 0; + } + if (temp->used > sd+1 || temp->dp[sd] > 1) { + /* >= 2s */ + return 1; + } + for (i = sd-1; i >= 0; --i) { + /* Check for ==s */ + if (temp->dp[i] != 0) { /* > s */ + return 1; } } + if (convType == TCL_DD_STEELE0) { + /* Biased rounding. */ + return 0; + } + return isodd; +} + +/* + *---------------------------------------------------------------------- + * + * ShorteningBignumConversionPowD -- + * + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The denominator in David Gay's + * conversion algorithm is known to be a power of 2**DIGIT_BIT, and hence + * the division in the main loop may be replaced by a digit shift and + * mask. + * + * Results: + * Returns the string of significant decimal digits, in newly allocated + * memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +ShorteningBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1). */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ +{ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_int mplus, mminus; /* Bounds for roundoff. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ + mp_int temp; + int r1; + + /* + * b = bw * 2**b2 * 5**b5 + * mminus = 5**m5 + */ + + TclBNInitBignumFromWideUInt(&b, bw); + mp_init_set_int(&mminus, 1); + MulPow5(&b, b5, &b); + mp_mul_2d(&b, b2, &b); + + /* + * Adjust if the logarithm was guessed wrong. + */ + + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); + ++m2plus; ++m2minus; ++m5; + ilim = ilim1; + --k; + } + + /* + * mminus = 5**m5 * 2**m2minus + * mplus = 5**m5 * 2**m2plus + */ + + mp_mul_2d(&mminus, m2minus, &mminus); + MulPow5(&mminus, m5, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); + } + mp_init(&temp); /* - * At this point, k contains the power of ten by which we're scaling the - * result. r/s is at least 1/10 and strictly less than ten, and v = r/s * - * 10**k. mplus and mminus give the rounding limits. + * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * by mp_digit extraction. */ + i = 0; for (;;) { - int tc1, tc2; + if (b.used <= sd) { + digit = 0; + } else { + digit = b.dp[sd]; + if (b.used > sd+1 || digit >= 10) { + Tcl_Panic("wrong digit!"); + } + --b.used; mp_clamp(&b); + } + + /* + * Does the current digit put us on the low side of the exact value + * but within within roundoff of being exact? + */ - mp_mul_d(&r, 10, &r); - mp_div(&r, &s, &temp, &r); /* temp = 10r / s; r = 10r mod s */ - i = temp.dp[0]; - mp_mul_d(&mplus, 10, &mplus); + r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + /* + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. + */ + + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + } + + /* + * Stash the last digit. + */ + + *s++ = '0' + digit; + break; + } + + /* + * Does one plus the current digit put us within roundoff of the + * number? + */ + + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, + dPtr->w.word1 & 1, &temp)) { + if (digit == 9) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + ++digit; + *s++ = '0' + digit; + break; + } + + /* + * Have we converted all the requested digits? + */ + + *s++ = '0' + digit; + if (i == ilim) { + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + s = BumpUp(s, retval, &k); + } + break; + } + + /* + * Advance to the next digit. + */ + + mp_mul_d(&b, 10, &b); mp_mul_d(&mminus, 10, &mminus); - tc1 = mp_cmp_mag(&r, &mminus); - if (lowOK) { - tc1 = (tc1 <= 0); - } else { - tc1 = (tc1 < 0); + if (m2plus > m2minus) { + mp_mul_2d(&mminus, m2plus-m2minus, &mplus); } - mp_add(&r, &mplus, &temp); - tc2 = mp_cmp_mag(&temp, &s); - if (highOK) { - tc2 = (tc2 >= 0); + ++i; + } + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + + if (m2plus > m2minus) { + mp_clear(&mplus); + } + mp_clear_multi(&b, &mminus, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * StrictBignumConversionPowD -- + * + * Converts a double-precision number to a fixed-lengt string of 'ilim' + * digits (or 'ilim1' if log10(d) has been overestimated). The + * denominator in David Gay's conversion algorithm is known to be a power + * of 2**DIGIT_BIT, and hence the division in the main loop may be + * replaced by a digit shift and mask. + * + * Results: + * Returns the string of significant decimal digits, in newly allocated + * memory. + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. + * + *---------------------------------------------------------------------- + */ + +inline static char * +StrictBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ +{ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ + mp_int temp; + + /* + * b = bw * 2**b2 * 5**b5 + */ + + TclBNInitBignumFromWideUInt(&b, bw); + MulPow5(&b, b5, &b); + mp_mul_2d(&b, b2, &b); + + /* + * Adjust if the logarithm was guessed wrong. + */ + + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); + ilim = ilim1; + --k; + } + mp_init(&temp); + + /* + * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * by mp_digit extraction. + */ + + i = 1; + for (;;) { + if (b.used <= sd) { + digit = 0; } else { - tc2 = (tc2 > 0); + digit = b.dp[sd]; + if (b.used > sd+1 || digit >= 10) { + Tcl_Panic("wrong digit!"); + } + --b.used; + mp_clamp(&b); } - if (!tc1) { - if (!tc2) { - *buffer++ = '0' + i; - } else { - c = (char) (i + '1'); - break; + + /* + * Have we converted all the requested digits? + */ + + *s++ = '0' + digit; + if (i == ilim) { + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + s = BumpUp(s, retval, &k); } + while (*--s == '0') { + /* do nothing */ + } + ++s; + break; + } + + /* + * Advance to the next digit. + */ + + mp_mul_d(&b, 10, &b); + ++i; + } + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + + mp_clear_multi(&b, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * ShouldBankerRoundUp -- + * + * Tests whether a digit should be rounded up or down when finishing + * bignum-based floating point conversion. + * + * Results: + * Returns 1 if the number needs to be rounded up, 0 otherwise. + * + *---------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUp( + mp_int *twor, /* 2x the remainder from thd division that + * produced the last digit. */ + mp_int *S, /* Denominator. */ + int isodd) /* Flag == 1 if the last digit is odd. */ +{ + int r = mp_cmp_mag(twor, S); + + switch (r) { + case MP_LT: + return 0; + case MP_EQ: + return isodd; + case MP_GT: + return 1; + } + Tcl_Panic("in ShouldBankerRoundUp, trichotomy fails!"); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ShouldBankerRoundUpToNext -- + * + * Tests whether the remainder is great enough to force rounding to the + * next higher digit. + * + * Results: + * Returns 1 if the number should be rounded up, 0 otherwise. + * + *---------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUpToNext( + mp_int *b, /* Remainder from the division that produced + * the last digit. */ + mp_int *m, /* Numerator of the rounding tolerance. */ + mp_int *S, /* Denominator. */ + int convType, /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would want + * this; I coped it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area needed for the calculation. */ +{ + int r; + + /* + * Compare b and S-m: this is the same as comparing B+m and S. + */ + + mp_add(b, m, temp); + r = mp_cmp_mag(temp, S); + switch(r) { + case MP_LT: + return 0; + case MP_EQ: + if (convType == TCL_DD_STEELE0) { + return 0; } else { - if (!tc2) { - c = (char) (i + '0'); - } else { - mp_mul_2d(&r, 1, &r); - n = mp_cmp_mag(&r, &s); - if (n < 0) { - c = (char) (i + '0'); - } else { - c = (char) (i + '1'); + return isodd; + } + case MP_GT: + return 1; + } + Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ShorteningBignumConversion -- + * + * Convert a floating point number to a variable-length digit string + * using the multiprecision method. + * + * Results: + * Returns the string of digits. + * + * Side effects: + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. + * + *---------------------------------------------------------------------- + */ + +inline static char * +ShorteningBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ +{ + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int mminus; /* 1/2 ulp below the result. */ + mp_int mplus; /* 1/2 ulp above the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int minit = 1; /* Fudge factor for when we misguess k. */ + int i; + int r1; + + /* + * b = bw * 2**b2 * 5**b5 + * S = 2**s2 * 5*s5 + */ + + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set_int(&S, 1); + MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); + + /* + * Handle the case where we guess the position of the decimal point wrong. + */ + + if (mp_cmp_mag(&b, &S) == MP_LT) { + mp_mul_d(&b, 10, &b); + minit = 10; + ilim =ilim1; + --k; + } + + /* + * mminus = 2**m2minus * 5**m5 + */ + + mp_init_set_int(&mminus, minit); + mp_mul_2d(&mminus, m2minus, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); + } + mp_init(&temp); + + /* + * Loop through the digits. + */ + + mp_init(&dig); + i = 1; + for (;;) { + mp_div(&b, &S, &dig, &b); + if (dig.used > 1 || dig.dp[0] >= 10) { + Tcl_Panic("wrong digit!"); + } + digit = dig.dp[0]; + + /* + * Does the current digit leave us with a remainder small enough to + * round to it? + */ + + r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; } } + *s++ = '0' + digit; + break; + } + + /* + * Does the current digit leave us with a remainder large enough to + * commit to rounding up to the next higher digit? + */ + + if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, + dPtr->w.word1 & 1, &temp)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + *s++ = '0' + digit; + break; + } + + /* + * Have we converted all the requested digits? + */ + + *s++ = '0' + digit; + if (i == ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); + } break; } - }; - *buffer++ = c; - *buffer++ = '\0'; + + /* + * Advance to the next digit. + */ + + if (s5 > 0) { + /* + * Can possibly shorten the denominator. + */ + + mp_mul_2d(&b, 1, &b); + mp_mul_2d(&mminus, 1, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 1, &mplus); + } + mp_div_d(&S, 5, &S, NULL); + --s5; + + /* + * IDEA: It might possibly be a win to fall back to int64 + * arithmetic here if S < 2**64/10. But it's a win only for + * a fairly narrow range of magnitudes so perhaps not worth + * bothering. We already know that we shorten the + * denominator by at least 1 mp_digit, perhaps 2, as we do + * the conversion for 17 digits of significance. + * Possible savings: + * 10**26 1 trip through loop before fallback possible + * 10**27 1 trip + * 10**28 2 trips + * 10**29 3 trips + * 10**30 4 trips + * 10**31 5 trips + * 10**32 6 trips + * 10**33 7 trips + * 10**34 8 trips + * 10**35 9 trips + * 10**36 10 trips + * 10**37 11 trips + * 10**38 12 trips + * 10**39 13 trips + * 10**40 14 trips + * 10**41 15 trips + * 10**42 16 trips + * thereafter no gain. + */ + } else { + mp_mul_d(&b, 10, &b); + mp_mul_d(&mminus, 10, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 10, &mplus); + } + } + + ++i; + } /* - * Free memory, and return. + * Endgame - store the location of the decimal point and the end of the + * string. */ - mp_clear_multi(&r, &s, &mplus, &mminus, &temp, NULL); - return k; + if (m2plus > m2minus) { + mp_clear(&mplus); + } + mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; } /* *---------------------------------------------------------------------- * - * AbsoluteValue -- + * StrictBignumConversion -- * - * Splits a 'double' into its absolute value and sign. + * Convert a floating point number to a fixed-length digit string using + * the multiprecision method. * * Results: - * Returns the absolute value. + * Returns the string of digits. * * Side effects: - * Stores the signum in '*signum'. + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. * *---------------------------------------------------------------------- */ -static double -AbsoluteValue( - double v, /* Number to split */ - int *signum) /* (Output) Sign of the number 1=-, 0=+ */ +inline static char * +StrictBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ { + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int g; /* Size of the current digit ground. */ + int i, j; + /* - * Take the absolute value of the number, and report the number's sign. - * Take special steps to preserve signed zeroes in IEEE floating point. - * (We can't use fpclassify, because that's a C9x feature and we still - * have to build on C89 compilers.) + * b = bw * 2**b2 * 5**b5 + * S = 2**s2 * 5*s5 */ -#ifndef IEEE_FLOATING_POINT - if (v >= 0.0) { - *signum = 0; - } else { - *signum = 1; - v = -v; + mp_init_multi(&temp, &dig, NULL); + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set_int(&S, 1); + MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); + + /* + * Handle the case where we guess the position of the decimal point wrong. + */ + + if (mp_cmp_mag(&b, &S) == MP_LT) { + mp_mul_d(&b, 10, &b); + ilim =ilim1; + --k; } -#else - union { - Tcl_WideUInt iv; - double dv; - } bitwhack; - bitwhack.dv = v; - if (n770_fp) { - bitwhack.iv = Nokia770Twiddle(bitwhack.iv); + + /* + * Convert the leading digit. + */ + + i = 0; + mp_div(&b, &S, &dig, &b); + if (dig.used > 1 || dig.dp[0] >= 10) { + Tcl_Panic("wrong digit!"); } - if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { - *signum = 1; - bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63); - if (n770_fp) { - bitwhack.iv = Nokia770Twiddle(bitwhack.iv); + digit = dig.dp[0]; + + /* + * Is a single digit all that was requested? + */ + + *s++ = '0' + digit; + if (++i >= ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); } - v = bitwhack.dv; } else { - *signum = 0; + for (;;) { + /* + * Shift by a group of digits. + */ + + g = ilim - i; + if (g > DIGIT_GROUP) { + g = DIGIT_GROUP; + } + if (s5 >= g) { + mp_div_d(&S, dpow5[g], &S, NULL); + s5 -= g; + } else if (s5 > 0) { + mp_div_d(&S, dpow5[s5], &S, NULL); + mp_mul_d(&b, dpow5[g - s5], &b); + s5 = 0; + } else { + mp_mul_d(&b, dpow5[g], &b); + } + mp_mul_2d(&b, g, &b); + + /* + * As with the shortening bignum conversion, it's possible at this + * point that we will have reduced the denominator to less than + * 2**64/10, at which point it would be possible to fall back to + * to int64 arithmetic. But the potential payoff is tremendously + * less - unless we're working in F format - because we know that + * three groups of digits will always suffice for %#.17e, the + * longest format that doesn't introduce empty precision. + * + * Extract the next group of digits. + */ + + mp_div(&b, &S, &dig, &b); + if (dig.used > 1) { + Tcl_Panic("wrong digit!"); + } + digit = dig.dp[0]; + for (j = g-1; j >= 0; --j) { + int t = itens[j]; + + *s++ = digit / t + '0'; + digit %= t; + } + i += g; + + /* + * Have we converted all the requested digits? + */ + + if (i == ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); + } + break; + } + } } -#endif - return v; + while (*--s == '0') { + /* do nothing */ + } + ++s; + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + + mp_clear_multi(&b, &S, &temp, &dig, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; } /* *---------------------------------------------------------------------- * - * GetIntegerTimesPower -- + * TclDoubleDigits -- * - * Converts a floating point number to an exact integer times a power of - * the floating point radix. + * Core of Tcl's conversion of double-precision floating point numbers to + * decimal. * * Results: - * Returns 1 if it converted the smallest significand, 0 otherwise. + * Returns a newly-allocated string of digits. * * Side effects: - * Initializes the integer value (does not just assign it), and stores - * the exponent. + * Sets *decpt to the index of the character in the string before the + * place that the decimal point should go. If 'endPtr' is not NULL, sets + * endPtr to point to the terminating '\0' byte of the string. Sets *sign + * to 1 if a minus sign should be printed with the number, or 0 if a plus + * sign (or no sign) should appear. + * + * This function is a service routine that produces the string of digits for + * floating-point-to-decimal conversion. It can do a number of things + * according to the 'flags' argument. Valid values for 'flags' include: + * TCL_DD_SHORTEST - This is the default for floating point conversion if + * ::tcl_precision is 0. It constructs the shortest string of + * digits that will reconvert to the given number when scanned. + * For floating point numbers that are exactly between two + * decimal numbers, it resolves using the 'round to even' rule. + * With this value, the 'ndigits' parameter is ignored. + * TCL_DD_STEELE - This value is not recommended and may be removed in + * the future. It follows the conversion algorithm outlined in + * "How to Print Floating-Point Numbers Accurately" by Guy + * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 as + * 9.9999999999999999e22 - which is a 'better' approximation in + * the sense that it will reconvert correctly even if a + * subsequent input conversion is 'round up' or 'round down' + * rather than 'round to nearest', but is surprising otherwise. + * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format + * conversion (or for default floating->string if tcl_precision + * is not 0). It constructs a string of at most 'ndigits' digits, + * choosing the one that is closest to the given number (and + * resolving ties with 'round to even'). It is allowed to return + * fewer than 'ndigits' if the number converts exactly; if the + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it + * also returns fewer digits if the shorter string will still + * reconvert without loss to the given input number. In any case, + * strings of trailing zeroes are suppressed. + * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format + * conversion. It requests that conversion proceed until + * 'ndigits' digits after the decimal point have been converted. + * It is possible for this format to result in a zero-length + * string if the number is sufficiently small. Again, it is + * permissible for TCL_DD_F_FORMAT to return fewer digits for a + * number that converts exactly, and changing the argument to + * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine + * also to return fewer digits if the shorter string will still + * reconvert without loss to the given input number. Strings of + * trailing zeroes are suppressed. + * + * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires + * all calculations to be done in exact arithmetic. Normally, E and F + * format with fewer than about 14 digits will be done with a quick + * floating point approximation and fall back on the exact arithmetic + * only if the input number is close enough to the midpoint between two + * decimal strings that more precision is needed to resolve which string + * is correct. + * + * The value stored in the 'decpt' argument on return may be negative + * (indicating that the decimal point falls to the left of the string) or + * greater than the length of the string. In addition, the value -9999 is used + * as a sentinel to indicate that the string is one of the special values + * "Infinity" and "NaN", and that no decimal point should be inserted. * *---------------------------------------------------------------------- */ -static int -GetIntegerTimesPower( - double v, /* Value to convert */ - mp_int *rPtr, /* (Output) Integer value */ - int *ePtr) /* (Output) Power of FLT_RADIX by which r must - * be multiplied to yield v*/ +char * +TclDoubleDigits( + double dv, /* Number to convert. */ + int ndigits, /* Number of digits requested. */ + int flags, /* Conversion flags. */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + int *sign, /* OUTPUT: 1 if the result is negative. */ + char **endPtr) /* OUTPUT: If not NULL, receives a pointer to + * one character beyond the end of the + * returned string. */ { - double a, f; - int e, i, n; + int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); + /* Type of conversion being performed: + * TCL_DD_SHORTEST0, TCL_DD_STEELE0, + * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ + Double d; /* Union for deconstructing doubles. */ + Tcl_WideUInt bw; /* Integer significand. */ + int be; /* Power of 2 by which b must be multiplied */ + int bbits; /* Number of bits needed to represent b. */ + int denorm; /* Flag == 1 iff the input number was + * denormalized. */ + int k; /* Estimate of floor(log10(d)). */ + int k_check; /* Flag == 1 if d is near enough to a power of + * ten that k must be checked. */ + int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and + * denominator of intermediate results. */ + int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number to + * convert if log10(d) has been + * overestimated. */ + char *retval; /* Return value from this function. */ + int i = -1; + + /* + * Put the input number into a union for bit-whacking. + */ + + d.d = dv; /* - * Develop f and e such that v = f * FLT_RADIX**e, with - * 1.0/FLT_RADIX <= f < 1. + * Handle the cases of negative numbers (by taking the absolute value: + * this includes -Inf and -NaN!), infinity, Not a Number, and zero. */ - f = frexp(v, &e); -#if FLT_RADIX > 2 - n = e % log2FLT_RADIX; - if (n > 0) { - n -= log2FLT_RADIX; - e += 1; - f *= ldexp(1.0, n); + TakeAbsoluteValue(&d, sign); + if ((d.w.word0 & EXP_MASK) == EXP_MASK) { + return FormatInfAndNaN(&d, decpt, endPtr); } - e = (e - n) / log2FLT_RADIX; -#endif - if (f == 1.0) { - f = 1.0 / FLT_RADIX; - e += 1; + if (d.d == 0.0) { + return FormatZero(decpt, endPtr); } /* - * If the original number was denormalized, adjust e and f to be denormal - * as well. + * Unpack the floating point into a wide integer and an exponent. + * Determine the number of bits that the big integer requires, and compute + * a quick approximation (which may be one too high) of ceil(log10(d.d)). */ - if (e < DBL_MIN_EXP) { - n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX; - f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX); - e = DBL_MIN_EXP; - n = (n + DIGIT_BIT - 1) / DIGIT_BIT; - } else { - n = mantDIGIT; - } + denorm = ((d.w.word0 & EXP_MASK) == 0); + DoubleToExpAndSig(d.d, &bw, &be, &bbits); + k = ApproximateLog10(bw, be, bbits); + k = BetterLog10(d.d, k, &k_check); + + /* At this point, we have: + * d is the number to convert. + * bw are significand and exponent: d == bw*2**be, + * bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits + * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 if we + * know that k is exactly ceil(log10(d)) and 1 if we need to check. + * We want a rational number + * r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5), + * with b2, b5, s2, s5 >= 0. Note that the most significant decimal + * digit is floor(r) and that successive digits can be obtained by + * setting r <- 10*floor(r) (or b <= 10 * (b % S)). Find appropriate + * b2, b5, s2, s5. + */ + + ComputeScale(be, k, &b2, &b5, &s2, &s5); + + /* + * Correct an incorrect caller-supplied 'ndigits'. Also determine: + * i = The maximum number of decimal digits that will be returned in the + * formatted string. This is k + 1 + ndigits for F format, 18 for + * shortest and Steele, and ndigits for E format. + * ilim = The number of significant digits to convert if k has been + * guessed correctly. This is -1 for shortest and Steele (which + * stop when all significance has been lost), 'ndigits' for E + * format, and 'k + 1 + ndigits' for F format. + * ilim1 = The minimum number of significant digits to convert if k has + * been guessed 1 too high. This, too, is -1 for shortest and + * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F + * format. + */ + + SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); /* - * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision - * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by - * adjusting e. + * Try to do low-precision conversion in floating point rather than + * resorting to expensive multiprecision arithmetic. */ - a = f; - n = mantDIGIT; - mp_init_size(rPtr, n); - rPtr->used = n; - rPtr->sign = MP_ZPOS; - i = (mantBits % DIGIT_BIT); - if (i == 0) { - i = DIGIT_BIT; + if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) { + retval = QuickConversion(d.d, k, k_check, flags, i, ilim, ilim1, + decpt, endPtr); + if (retval != NULL) { + return retval; + } } - while (n > 0) { - a *= ldexp(1.0, i); - i = DIGIT_BIT; - rPtr->dp[--n] = (mp_digit) a; - a -= (mp_digit) a; + + /* + * For shortening conversions, determine the upper and lower bounds for + * the remainder at which we can stop. + * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the high + * side, and + * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low + * side. + * We may need to increase s2 to put m2plus, m2minus, b2 over a common + * denominator. + */ + + if (flags & TCL_DD_SHORTEN_FLAG) { + int m2minus = b2; + int m2plus; + int m5 = b5; + int len = i; + + /* + * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit + * in the least significant place of the floating point number. + */ + + if (denorm) { + i = be + EXPONENT_BIAS + (FP_PRECISION-1); + } else { + i = 1 + FP_PRECISION - bbits; + } + b2 += i; + s2 += i; + + /* + * Reduce the fractions to lowest terms, since the above calculation + * may have left excess powers of 2 in numerator and denominator. + */ + + CastOutPowersOf2(&b2, &m2minus, &s2); + + /* + * In the special case where bw==1, the nearest floating point number + * to it on the low side is 1/4 ulp below it. Adjust accordingly. + */ + + m2plus = m2minus; + if (!denorm && bw == 1) { + ++b2; + ++s2; + ++m2plus; + } + + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { + /* + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. (This will be true for all numbers in the range + * [1.0e-3 .. 1.0e+24]). + */ + + return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, + m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); + } else if (s5 == 0) { + /* + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. + */ + + if (s2 % DIGIT_BIT != 0) { + int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + + b2 += delta; + m2plus += delta; + m2minus += delta; + s2 += delta; + } + return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, + m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1, + decpt, endPtr); + } else { + /* + * Alas, there's no helpful special case; use full-up bignum + * arithmetic for the conversion. + */ + + return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, + m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); + } + } else { + /* + * Non-shortening conversion. + */ + + int len = i; + + /* + * Reduce numerator and denominator to lowest terms. + */ + + if (b2 >= s2 && s2 > 0) { + b2 -= s2; s2 = 0; + } else if (s2 >= b2 && b2 > 0) { + s2 -= b2; b2 = 0; + } + + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { + /* + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. + */ + + return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); + } else if (s5 == 0) { + /* + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. + */ + + if (s2 % DIGIT_BIT != 0) { + int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + + b2 += delta; + s2 += delta; + } + return StrictBignumConversionPowD(&d, convType, bw, b2, b5, + s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); + } else { + /* + * There are no helpful special cases, but at least we know in + * advance how many digits we will convert. We can run the + * conversion in steps of DIGIT_GROUP digits, so as to have many + * fewer mp_int divisions. + */ + + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); + } } - *ePtr = e - DBL_MANT_DIG; - return (f == 1.0 / FLT_RADIX); } /* @@ -2167,14 +4339,12 @@ TclInitDoubleConversion(void) int x; Tcl_WideUInt u; double d; - #ifdef IEEE_FLOATING_POINT union { double dv; Tcl_WideUInt iv; } bitwhack; #endif - #if defined(__sgi) && defined(_COMPILER_VERSION) union fpc_csr mipsCR; @@ -2189,8 +4359,7 @@ TclInitDoubleConversion(void) maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); - pow10_wide = (Tcl_WideUInt *) - ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); + pow10_wide = ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; @@ -2199,8 +4368,8 @@ TclInitDoubleConversion(void) pow10_wide[i] = u; /* - * Determine how many bits of precision a double has, and how many - * decimal digits that represents. + * Determine how many bits of precision a double has, and how many decimal + * digits that represents. */ if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) { @@ -2211,8 +4380,8 @@ TclInitDoubleConversion(void) d = 1.0; /* - * Initialize a table of powers of ten that can be exactly represented - * in a double. + * Initialize a table of powers of ten that can be exactly represented in + * a double. */ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0)); @@ -2237,6 +4406,11 @@ TclInitDoubleConversion(void) for (i=0; i<8; ++i) { mp_sqr(pow5+i, pow5+i+1); } + mp_init_set_int(pow5_13, 1220703125); + for (i = 1; i < 5; ++i) { + mp_init(pow5_13 + i); + mp_sqr(pow5_13 + i - 1, pow5_13 + i); + } /* * Determine the number of decimal digits to the left and right of the @@ -2249,7 +4423,6 @@ TclInitDoubleConversion(void) + 0.5 * log(10.)) / log(10.)); minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG) * log((double) FLT_RADIX) / log(10.)); - mantDIGIT = (mantBits + DIGIT_BIT-1) / DIGIT_BIT; log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.)); /* @@ -2293,10 +4466,13 @@ TclFinalizeDoubleConversion(void) { int i; - Tcl_Free((char *) pow10_wide); + ckfree(pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } + for (i=0; i < 5; ++i) { + mp_clear(pow5_13 + i); + } } /* @@ -2319,9 +4495,9 @@ TclFinalizeDoubleConversion(void) int Tcl_InitBignumFromDouble( - Tcl_Interp *interp, /* For error message */ - double d, /* Number to convert */ - mp_int *b) /* Place to store the result */ + Tcl_Interp *interp, /* For error message. */ + double d, /* Number to convert. */ + mp_int *b) /* Place to store the result. */ { double fract; int expt; @@ -2378,12 +4554,13 @@ TclBignumToDouble( const mp_int *a) /* Integer to convert. */ { mp_int b; - int bits, shift, i; + int bits, shift, i, lsb; double r; + /* - * Determine how many bits we need, and extract that many from the input. - * Round to nearest unit in the last place. + * We need a 'mantBits'-bit significand. Determine what shift will + * give us that. */ bits = mp_count_bits(a); @@ -2395,17 +4572,54 @@ TclBignumToDouble( return -HUGE_VAL; } } - shift = mantBits + 1 - bits; + shift = mantBits - bits; + + /* + * If shift > 0, shift the significand left by the requisite number of + * bits. If shift == 0, the significand is already exactly 'mantBits' + * in length. If shift < 0, we will need to shift the significand right + * by the requisite number of bits, and round it. If the '1-shift' + * least significant bits are 0, but the 'shift'th bit is nonzero, + * then the significand lies exactly between two values and must be + * 'rounded to even'. + */ + mp_init(&b); - if (shift > 0) { + if (shift == 0) { + mp_copy(a, &b); + } else if (shift > 0) { mp_mul_2d(a, shift, &b); } else if (shift < 0) { - mp_div_2d(a, -shift, &b, NULL); - } else { - mp_copy(a, &b); + lsb = mp_cnt_lsb(a); + if (lsb == -1-shift) { + + /* + * Round to even + */ + + mp_div_2d(a, -shift, &b, NULL); + if (mp_isodd(&b)) { + if (b.sign == MP_ZPOS) { + mp_add_d(&b, 1, &b); + } else { + mp_sub_d(&b, 1, &b); + } + } + } else { + + /* + * Ordinary rounding + */ + + mp_div_2d(a, -1-shift, &b, NULL); + if (b.sign == MP_ZPOS) { + mp_add_d(&b, 1, &b); + } else { + mp_sub_d(&b, 1, &b); + } + mp_div_2d(&b, 1, &b, NULL); + } } - mp_add_d(&b, 1, &b); - mp_div_2d(&b, 1, &b, NULL); /* * Accumulate the result, one mp_digit at a time. @@ -2433,6 +4647,20 @@ TclBignumToDouble( return -r; } } + +/* + *---------------------------------------------------------------------- + * + * TclCeil -- + * + * Computes the smallest floating point number that is at least the + * mp_int argument. + * + * Results: + * Returns the floating point number. + * + *---------------------------------------------------------------------- + */ double TclCeil( @@ -2476,6 +4704,20 @@ TclCeil( mp_clear(&b); return r; } + +/* + *---------------------------------------------------------------------- + * + * TclFloor -- + * + * Computes the largest floating point number less than or equal to the + * mp_int argument. + * + * Results: + * Returns the floating point value. + * + *---------------------------------------------------------------------- + */ double TclFloor( @@ -2535,8 +4777,8 @@ TclFloor( static double BignumToBiasedFrExp( - const mp_int *a, /* Integer to convert */ - int *machexp) /* Power of two */ + const mp_int *a, /* Integer to convert. */ + int *machexp) /* Power of two. */ { mp_int b; int bits; @@ -2600,8 +4842,8 @@ BignumToBiasedFrExp( static double Pow10TimesFrExp( - int exponent, /* Power of 10 to multiply by */ - double fraction, /* Significand of multiplicand */ + int exponent, /* Power of 10 to multiply by. */ + double fraction, /* Significand of multiplicand. */ int *machexp) /* On input, exponent of multiplicand. On * output, exponent of result. */ { @@ -2611,7 +4853,7 @@ Pow10TimesFrExp( if (exponent > 0) { /* - * Multiply by 10**exponent + * Multiply by 10**exponent. */ retval = frexp(retval * pow10vals[exponent&0xf], &j); @@ -2624,7 +4866,7 @@ Pow10TimesFrExp( } } else if (exponent < 0) { /* - * Divide by 10**-exponent + * Divide by 10**-exponent. */ retval = frexp(retval / pow10vals[(-exponent) & 0xf], &j); @@ -2733,26 +4975,27 @@ TclFormatNaN( * * Nokia770Twiddle -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ - +#ifdef IEEE_FLOATING_POINT static Tcl_WideUInt Nokia770Twiddle( - Tcl_WideUInt w) /* Number to transpose */ + Tcl_WideUInt w) /* Number to transpose. */ { return (((w >> 32) & 0xffffffff) | (w << 32)); } +#endif /* *---------------------------------------------------------------------- * * TclNokia770Doubles -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9e2e3aa..04cf4ee 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -32,8 +32,7 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclStringObj.c,v 1.137 2010/04/30 20:52:51 dgp Exp $ */ + */ #include "tclInt.h" #include "tommath.h" @@ -41,9 +40,10 @@ /* * 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 + * impact on performance. If things go well, this mechanism can go away when * post-8.6 development begins. */ + #define COMPAT 0 /* @@ -131,18 +131,19 @@ typedef struct String { Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ STRING_MAXCHARS); \ } +#define stringAttemptAlloc(numChars) \ + (String *) attemptckalloc((unsigned) STRING_SIZE(numChars) ) #define stringAlloc(numChars) \ (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((char *) ptr, (unsigned) STRING_SIZE(numChars) ) + (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((char *) ptr, \ - (unsigned) STRING_SIZE(numChars) ) + (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr)) - + /* * TCL STRING GROWTH ALGORITHM * @@ -151,8 +152,7 @@ typedef struct String { * * Attempt to allocate 2 * (originalLength + appendLength) * On failure: - * attempt to allocate originalLength + 2*appendLength + - * TCL_GROWTH_MIN_ALLOC + * attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH * * This algorithm allows very good performance, as it rapidly increases the * memory allocated for a given string, which minimizes the number of @@ -165,20 +165,20 @@ typedef struct String { * cover the request, but which hopefully will be less than the total * available memory. * - * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very + * The addition of TCL_MIN_GROWTH allows for efficient handling of very * small appends. Without this extra slush factor, a sequence of several small * appends would cause several memory allocations. As long as - * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior. + * TCL_MIN_GROWTH is a reasonable size, we can avoid that behavior. * * The growth algorithm can be tuned by adjusting the following parameters: * - * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when + * TCL_MIN_GROWTH Additional space, in bytes, to allocate when * the double allocation has failed. Default is - * 1024 (1 kilobyte). + * 1024 (1 kilobyte). See tclInt.h. */ -#ifndef TCL_GROWTH_MIN_ALLOC -#define TCL_GROWTH_MIN_ALLOC 1024 +#ifndef TCL_MIN_UNICHAR_GROWTH +#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) #endif static void @@ -187,11 +187,13 @@ GrowStringBuffer( int needed, int flag) { - /* Pre-conditions: + /* + * Pre-conditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->allocated * flag || objPtr->bytes != NULL */ + String *stringPtr = GET_STRING(objPtr); char *ptr = NULL; int attempt; @@ -202,24 +204,29 @@ GrowStringBuffer( if (flag == 0 || stringPtr->allocated > 0) { attempt = 2 * needed; if (attempt >= 0) { - ptr = attemptckrealloc(objPtr->bytes, (unsigned) attempt + 1); + ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { /* * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ + unsigned int limit = INT_MAX - needed; - unsigned int extra = needed - objPtr->length + TCL_GROWTH_MIN_ALLOC; + unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); + attempt = needed + growth; - ptr = attemptckrealloc(objPtr->bytes, (unsigned) attempt + 1); + ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } } if (ptr == NULL) { - /* First allocation - just big enough; or last chance fallback. */ + /* + * First allocation - just big enough; or last chance fallback. + */ + attempt = needed; - ptr = ckrealloc(objPtr->bytes, (unsigned) attempt + 1); + ptr = ckrealloc(objPtr->bytes, attempt + 1); } objPtr->bytes = ptr; stringPtr->allocated = attempt; @@ -230,16 +237,21 @@ GrowUnicodeBuffer( Tcl_Obj *objPtr, int needed) { - /* Pre-conditions: + /* + * Pre-conditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->maxChars * needed < STRING_MAXCHARS */ + String *ptr = NULL, *stringPtr = GET_STRING(objPtr); int attempt; if (stringPtr->maxChars > 0) { - /* Subsequent appends - apply the growth algorithm. */ + /* + * Subsequent appends - apply the growth algorithm. + */ + attempt = 2 * needed; if (attempt >= 0 && attempt <= STRING_MAXCHARS) { ptr = stringAttemptRealloc(stringPtr, attempt); @@ -249,16 +261,21 @@ GrowUnicodeBuffer( * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ + unsigned int limit = STRING_MAXCHARS - needed; unsigned int extra = needed - stringPtr->numChars - + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar); + + TCL_MIN_UNICHAR_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); + attempt = needed + growth; ptr = stringAttemptRealloc(stringPtr, attempt); } } if (ptr == NULL) { - /* First allocation - just big enough; or last chance fallback. */ + /* + * First allocation - just big enough; or last chance fallback. + */ + attempt = needed; ptr = stringRealloc(stringPtr, attempt); } @@ -474,7 +491,10 @@ Tcl_GetCharLength( stringPtr = GET_STRING(objPtr); numChars = stringPtr->numChars; - /* If numChars is unknown, compute it. */ + /* + * If numChars is unknown, compute it. + */ + if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; @@ -482,8 +502,8 @@ Tcl_GetCharLength( #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 + * 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. */ @@ -539,7 +559,10 @@ Tcl_GetUniChar( stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode == 0) { - /* If numChars is unknown, compute it. */ + /* + * If numChars is unknown, compute it. + */ + if (stringPtr->numChars == -1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } @@ -670,14 +693,20 @@ Tcl_GetRange( stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode == 0) { - /* If numChars is unknown, compute it. */ + /* + * If numChars is unknown, compute it. + */ + if (stringPtr->numChars == -1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); - /* Since we know the char length of the result, store it. */ + /* + * Since we know the char length of the result, store it. + */ + SetStringFromAny(NULL, newObjPtr); stringPtr = GET_STRING(newObjPtr); stringPtr->numChars = newObjPtr->length; @@ -729,7 +758,6 @@ Tcl_SetStringObj( */ TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; /* * Free any old string rep, then set the string rep to a copy of the @@ -805,9 +833,9 @@ Tcl_SetObjLength( * Need to enlarge the buffer. */ if (objPtr->bytes == tclEmptyStringRep) { - objPtr->bytes = ckalloc((unsigned) length+1); + objPtr->bytes = ckalloc(length + 1); } else { - objPtr->bytes = ckrealloc(objPtr->bytes, (unsigned) length+1); + objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); } stringPtr->allocated = length; } @@ -833,14 +861,17 @@ Tcl_SetObjLength( stringPtr->maxChars = length; } - /* Mark the new end of the unicode string */ + /* + * Mark the new end of the unicode string + */ + stringPtr->numChars = length; stringPtr->unicode[length] = 0; stringPtr->hasUnicode = 1; /* - * Can only get here when objPtr->bytes == NULL. - * No need to invalidate the string rep. + * Can only get here when objPtr->bytes == NULL. No need to invalidate + * the string rep. */ } } @@ -880,9 +911,10 @@ Tcl_AttemptSetObjLength( if (length < 0) { /* - * Setting to a negative length is nonsense. This is probably the + * Setting to a negative length is nonsense. This is probably the * result of overflowing the signed integer range. */ + return 0; } if (Tcl_IsShared(objPtr)) { @@ -903,12 +935,13 @@ Tcl_AttemptSetObjLength( /* * Need to enlarge the buffer. */ + char *newBytes; if (objPtr->bytes == tclEmptyStringRep) { - newBytes = attemptckalloc((unsigned) length+1); + newBytes = attemptckalloc(length + 1); } else { - newBytes = attemptckrealloc(objPtr->bytes, (unsigned) length+1); + newBytes = attemptckrealloc(objPtr->bytes, length + 1); } if (newBytes == NULL) { return 0; @@ -943,14 +976,17 @@ Tcl_AttemptSetObjLength( stringPtr->maxChars = length; } - /* Mark the new end of the unicode string */ + /* + * Mark the new end of the unicode string. + */ + stringPtr->unicode[length] = 0; stringPtr->numChars = length; stringPtr->hasUnicode = 1; /* - * Can only get here when objPtr->bytes == NULL. - * No need to invalidate the string rep. + * Can only get here when objPtr->bytes == NULL. No need to invalidate + * the string rep. */ } return 1; @@ -1228,13 +1264,23 @@ Tcl_AppendObjToObj( const char *bytes; /* + * Special case: second object is standard-empty is fast case. We know + * that appending nothing to anything leaves that starting anything... + */ + + if (appendObjPtr->bytes == tclEmptyStringRep) { + 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. */ - if (TclIsPureByteArray(objPtr) && TclIsPureByteArray(appendObjPtr)) { + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) + && TclIsPureByteArray(appendObjPtr)) { unsigned char *bytesSrc; int lengthSrc, lengthTotal; @@ -1361,12 +1407,14 @@ AppendUnicodeToUnicodeRep( stringCheckLimits(numChars); if (numChars > stringPtr->maxChars) { + int offset = -1; + /* * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations - * due to the reallocs below. + * stringPtr->unicode array. Force it to follow any relocations due to + * the reallocs below. */ - int offset = -1; + if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode + stringPtr->maxChars) { offset = unicode - stringPtr->unicode; @@ -1375,7 +1423,10 @@ AppendUnicodeToUnicodeRep( GrowUnicodeBuffer(objPtr, numChars); stringPtr = GET_STRING(objPtr); - /* Relocate unicode if needed; see above. */ + /* + * Relocate unicode if needed; see above. + */ + if (offset >= 0) { unicode = stringPtr->unicode + offset; } @@ -1386,7 +1437,7 @@ AppendUnicodeToUnicodeRep( * trailing null. */ - memcpy(stringPtr->unicode + stringPtr->numChars, unicode, + memmove(stringPtr->unicode + stringPtr->numChars, unicode, appendNumChars * sizeof(Tcl_UniChar)); stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; @@ -1427,7 +1478,10 @@ AppendUnicodeToUtfRep( } #if COMPAT - /* Invalidate the unicode rep */ + /* + * Invalidate the unicode rep. + */ + stringPtr->hasUnicode = 0; #endif } @@ -1439,7 +1493,7 @@ AppendUnicodeToUtfRep( * * This function converts the contents of "bytes" to Unicode and appends * the Unicode to the Unicode rep of "objPtr". objPtr must already have a - * valid Unicode rep. numBytes must be non-negative. + * valid Unicode rep. numBytes must be non-negative. * * Results: * None. @@ -1515,22 +1569,30 @@ AppendUtfToUtfRep( stringPtr = GET_STRING(objPtr); if (newLength > stringPtr->allocated) { + int offset = -1; + /* * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations - * due to the reallocs below. + * stringPtr->unicode array. Force it to follow any relocations due to + * the reallocs below. */ - int offset = -1; + if (bytes >= objPtr->bytes && bytes <= objPtr->bytes + objPtr->length) { offset = bytes - objPtr->bytes; } - /* TODO: consider passing flag=1: no overalloc on first append. - * This would make test stringObj-8.1 fail.*/ + /* + * TODO: consider passing flag=1: no overalloc on first append. This + * would make test stringObj-8.1 fail. + */ + GrowStringBuffer(objPtr, newLength, 0); - /* Relocate bytes if needed; see above. */ + /* + * Relocate bytes if needed; see above. + */ + if (offset >= 0) { bytes = objPtr->bytes + offset; } @@ -1543,11 +1605,10 @@ AppendUtfToUtfRep( stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - memcpy(objPtr->bytes + oldLength, bytes, numBytes); + memmove(objPtr->bytes + oldLength, bytes, numBytes); objPtr->bytes[newLength] = 0; objPtr->length = newLength; } - /* *---------------------------------------------------------------------- @@ -1578,6 +1639,7 @@ Tcl_AppendStringsToObjVA( while (1) { const char *bytes = va_arg(argList, char *); + if (bytes == NULL) { break; } @@ -1643,7 +1705,7 @@ Tcl_AppendFormatToObj( int objc, Tcl_Obj *const objv[]) { - const char *span = format, *msg; + const char *span = format, *msg, *errCode; int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; int originalLength, limit; static const char *mixedXPG = @@ -1681,6 +1743,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -1720,18 +1783,21 @@ Tcl_AppendFormatToObj( if (newXpg) { if (gotSequential) { msg = mixedXPG; + errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotXpg = 1; } else { if (gotXpg) { msg = mixedXPG; + errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotSequential = 1; } if ((objIndex < 0) || (objIndex >= objc)) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } @@ -1779,6 +1845,7 @@ Tcl_AppendFormatToObj( } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { @@ -1794,6 +1861,7 @@ Tcl_AppendFormatToObj( } if (width > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } @@ -1814,6 +1882,7 @@ Tcl_AppendFormatToObj( } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &precision) @@ -1871,6 +1940,7 @@ Tcl_AppendFormatToObj( switch (ch) { case '\0': msg = "format string ended in middle of field specifier"; + errCode = "INCOMPLETE"; goto errorMsg; case 's': if (gotPrecision) { @@ -1900,6 +1970,7 @@ Tcl_AppendFormatToObj( case 'u': if (useBig) { msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; goto errorMsg; } case 'd': @@ -2047,6 +2118,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(segment, bytes, toAppend); @@ -2061,8 +2133,7 @@ Tcl_AppendFormatToObj( case 'b': { Tcl_WideUInt bits = (Tcl_WideUInt) 0; Tcl_WideInt numDigits = (Tcl_WideInt) 0; - int length, numBits = 4, base = 16; - int index = 0, shift = 0; + int length, numBits = 4, base = 16, index = 0, shift = 0; Tcl_Obj *pure; char *bytes; @@ -2103,6 +2174,7 @@ Tcl_AppendFormatToObj( } if (numDigits > INT_MAX) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } } else if (!useBig) { @@ -2170,6 +2242,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(segment, pure); @@ -2223,6 +2296,7 @@ Tcl_AppendFormatToObj( p += sprintf(p, "%d", precision); if (precision > INT_MAX - length) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } length += precision; @@ -2239,11 +2313,13 @@ Tcl_AppendFormatToObj( allocSegment = 1; if (!Tcl_AttemptSetObjLength(segment, length)) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } bytes = TclGetString(segment); if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } break; @@ -2252,6 +2328,7 @@ Tcl_AppendFormatToObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); } goto error; } @@ -2283,6 +2360,7 @@ Tcl_AppendFormatToObj( Tcl_DecrRefCount(segment); } msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(appendObj, segment); @@ -2305,6 +2383,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -2317,6 +2396,7 @@ Tcl_AppendFormatToObj( errorMsg: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL); } error: Tcl_SetObjLength(appendObj, originalLength); @@ -2346,6 +2426,7 @@ Tcl_Format( { int result; Tcl_Obj *objPtr = Tcl_NewObj(); + result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv); if (result != TCL_OK) { Tcl_DecrRefCount(objPtr); @@ -2391,7 +2472,6 @@ AppendPrintfToObjVA( } do { switch (*p) { - case '\0': seekingConversion = 0; break; @@ -2444,11 +2524,11 @@ AppendPrintfToObjVA( case -1: case 0: Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( - (long int)va_arg(argList, int))); + (long) va_arg(argList, int))); break; case 1: Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( - va_arg(argList, long int))); + va_arg(argList, long))); break; } break; @@ -2462,7 +2542,7 @@ AppendPrintfToObjVA( seekingConversion = 0; break; case '*': - lastNum = (int)va_arg(argList, int); + lastNum = (int) va_arg(argList, int); Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); p++; break; @@ -2564,8 +2644,8 @@ Tcl_ObjPrintf( * * 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. + * supplied. When sharing rules permit, the returned value might be the + * argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -2573,84 +2653,124 @@ Tcl_ObjPrintf( *--------------------------------------------------------------------------- */ +static void +ReverseBytes( + unsigned char *to, /* Copy bytes into here... */ + unsigned char *from, /* ...from here... */ + 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 { + while (--src >= from) { + *to++ = *src; + } + } +} + Tcl_Obj * TclStringObjReverse( Tcl_Obj *objPtr) { String *stringPtr; - char *src = NULL, *dest = NULL; - Tcl_UniChar *usrc = NULL, *udest = NULL; - Tcl_Obj *resultPtr = NULL; + Tcl_UniChar ch; + + if (TclIsPureByteArray(objPtr)) { + int numBytes; + unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + + if (Tcl_IsShared(objPtr)) { + objPtr = Tcl_NewByteArrayObj(NULL, numBytes); + } + ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); + return objPtr; + } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode == 0) { - if (stringPtr->numChars == -1) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (stringPtr->numChars <= 1) { - return objPtr; - } - if (stringPtr->numChars == objPtr->length) { - /* All one-byte chars. Reverse in objPtr->bytes. */ - if (Tcl_IsShared(objPtr)) { - resultPtr = Tcl_NewObj(); - Tcl_SetObjLength(resultPtr, objPtr->length); - dest = TclGetString(resultPtr); - src = objPtr->bytes + objPtr->length - 1; - while (src >= objPtr->bytes) { - *dest++ = *src--; - } - return resultPtr; + if (stringPtr->hasUnicode) { + Tcl_UniChar *from = Tcl_GetUnicode(objPtr); + Tcl_UniChar *src = from + stringPtr->numChars; + + if (Tcl_IsShared(objPtr)) { + Tcl_UniChar *to; + + /* + * Create a non-empty, pure unicode value, so we can coax + * Tcl_SetObjLength into growing the unicode rep buffer. + */ + + ch = 0; + objPtr = Tcl_NewUnicodeObj(&ch, 1); + Tcl_SetObjLength(objPtr, stringPtr->numChars); + to = Tcl_GetUnicode(objPtr); + while (--src >= from) { + *to++ = *src; } - /* Unshared. Reverse objPtr->bytes in place. */ - dest = objPtr->bytes; - src = dest + objPtr->length - 1; - while (dest < src) { - char tmp = *src; - *src-- = *dest; - *dest++ = tmp; + } else { + /* Reversing in place */ + while (--src > from) { + ch = *src; + *src = *from; + *from++ = ch; } - return objPtr; } - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - if (stringPtr->numChars <= 1) { - return objPtr; } - /* Reverse the Unicode rep. */ - if (Tcl_IsShared(objPtr)) { - Tcl_UniChar ch = 0; + if (objPtr->bytes) { + int numChars = stringPtr->numChars; + int numBytes = objPtr->length; + char *to, *from = objPtr->bytes; - /* - * Create a non-empty, pure unicode value, so we can coax - * Tcl_SetObjLength into growing the unicode rep buffer. - */ - - resultPtr = Tcl_NewUnicodeObj(&ch, 1); - Tcl_SetObjLength(resultPtr, stringPtr->numChars); - udest = Tcl_GetUnicode(resultPtr); - usrc = stringPtr->unicode + stringPtr->numChars - 1; - while (usrc >= stringPtr->unicode) { - *udest++ = *usrc--; + if (Tcl_IsShared(objPtr)) { + objPtr = Tcl_NewObj(); + Tcl_SetObjLength(objPtr, numBytes); } - return resultPtr; - } + to = objPtr->bytes; + + if (numChars < numBytes) { + /* + * 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. + * + * 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. + */ + int bytesInChar = Tcl_UtfToUniChar(from, &ch); + + ReverseBytes((unsigned char *)to, (unsigned char *)from, + bytesInChar); + to += bytesInChar; + from += bytesInChar; + bytesLeft -= bytesInChar; + charCount++; + } - /* Unshared. Reverse objPtr->bytes in place. */ - udest = stringPtr->unicode; - usrc = udest + stringPtr->numChars - 1; - while (udest < usrc) { - Tcl_UniChar tmp = *usrc; - *usrc-- = *udest; - *udest++ = tmp; + from = to = objPtr->bytes; + stringPtr->numChars = charCount; + } + /* Pass 2. Reverse all the bytes. */ + ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); } - TclInvalidateStringRep(objPtr); - stringPtr->allocated = 0; return objPtr; } @@ -2677,6 +2797,7 @@ FillUnicodeRep( * rep. */ { String *stringPtr = GET_STRING(objPtr); + ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length, stringPtr->numChars); } @@ -2745,21 +2866,27 @@ DupStringInternalRep( #if COMPAT==0 if (srcStringPtr->numChars == -1) { /* - * The String struct in the source value holds zero useful data. - * Don't bother copying it. Don't even bother allocating space in - * which to copy it. Just let the copy be untyped. + * The String struct in the source value holds zero useful data. Don't + * bother copying it. Don't even bother allocating space in which to + * copy it. Just let the copy be untyped. */ + return; } if (srcStringPtr->hasUnicode) { int copyMaxChars; + if (srcStringPtr->maxChars / 2 >= srcStringPtr->numChars) { copyMaxChars = 2 * srcStringPtr->numChars; } else { copyMaxChars = srcStringPtr->maxChars; } - copyStringPtr = stringAlloc(copyMaxChars); + copyStringPtr = stringAttemptAlloc(copyMaxChars); + if (copyStringPtr == NULL) { + copyMaxChars = srcStringPtr->numChars; + copyStringPtr = stringAlloc(copyMaxChars); + } copyStringPtr->maxChars = copyMaxChars; memcpy(copyStringPtr->unicode, srcStringPtr->unicode, srcStringPtr->numChars * sizeof(Tcl_UniChar)); @@ -2773,12 +2900,13 @@ DupStringInternalRep( copyStringPtr->numChars = srcStringPtr->numChars; /* - * 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. + * 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->bytes ? copyPtr->length : 0; -#else +#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 @@ -2787,7 +2915,10 @@ DupStringInternalRep( */ if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { - /* Copy the full allocation for the Unicode buffer. */ + /* + * Copy the full allocation for the Unicode buffer. + */ + copyStringPtr = stringAlloc(srcStringPtr->maxChars); copyStringPtr->maxChars = srcStringPtr->maxChars; memcpy(copyStringPtr->unicode, srcStringPtr->unicode, @@ -2798,16 +2929,18 @@ DupStringInternalRep( 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. + * 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 +#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -2839,7 +2972,7 @@ SetStringFromAny( String *stringPtr = stringAlloc(0); /* - * Convert whatever we have into an untyped value. Just A String. + * Convert whatever we have into an untyped value. Just A String. */ (void) TclGetString(objPtr); @@ -2883,6 +3016,7 @@ UpdateStringOfString( Tcl_Obj *objPtr) /* Object with string rep to update. */ { String *stringPtr = GET_STRING(objPtr); + if (stringPtr->numChars == 0) { TclInitStringRep(objPtr, tclEmptyStringRep, 0); } else { @@ -2897,10 +3031,12 @@ ExtendStringRepWithUnicode( const Tcl_UniChar *unicode, int numChars) { + /* + * Pre-condition: this is the "string" Tcl_ObjType. + */ + int i, origLength, size = 0; char *dst, buf[TCL_UTF_MAX]; - - /* Pre-condition: this is the "string" Tcl_ObjType */ String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -2916,7 +3052,10 @@ ExtendStringRepWithUnicode( } size = origLength = objPtr->length; - /* Quick cheap check in case we have more than enough room. */ + /* + * Quick cheap check in case we have more than enough room. + */ + if (numChars <= (INT_MAX - size)/TCL_UTF_MAX && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { goto copyBytes; @@ -2929,12 +3068,15 @@ ExtendStringRepWithUnicode( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - /* Grow space if needed */ + /* + * Grow space if needed. + */ + if (size > stringPtr->allocated) { GrowStringBuffer(objPtr, size, 1); } - copyBytes: + copyBytes: dst = objPtr->bytes + origLength; for (i = 0; i < numChars; i++) { dst += Tcl_UniCharToUtf((int) unicode[i], dst); @@ -2965,7 +3107,7 @@ static void FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree((char *) GET_STRING(objPtr)); + ckfree(GET_STRING(objPtr)); objPtr->typePtr = NULL; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b804b9a..88ada19 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclStubInit.c,v 1.197 2010/09/16 14:49:37 nijtmans Exp $ */ #include "tclInt.h" @@ -41,6 +39,141 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef TclpGetPid +#undef TclSockMinimumBuffers + +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#ifdef _WIN64 +# define TclSockMinimumBuffersOld 0 +#else +#define TclSockMinimumBuffersOld sockMinimumBuffersOld +static int TclSockMinimumBuffersOld(int sock, int size) +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} +#endif + + +#if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS +#define TclWinNToHS winNToHS +static unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif + +#ifdef __WIN32__ +# define TclUnixWaitForFile 0 +# define TclUnixCopyFile 0 +# define TclUnixOpenTemporaryFile 0 +# define TclpReaddir 0 +# define TclpIsAtty 0 +#elif defined(__CYGWIN__) +# define TclpIsAtty TclPlatIsAtty +# define TclWinSetInterfaces (void (*) (int)) doNothing +# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing +# define TclWinFlushDirtyChannels doNothing +# define TclWinResetInterfaces doNothing + +static Tcl_Encoding winTCharEncoding; + +static int +TclpIsAtty(int fd) +{ + return isatty(fd); +} + +int +TclWinGetPlatformId() +{ + /* Don't bother to determine the real platform on cygwin, + * because VER_PLATFORM_WIN32_NT is the only supported platform */ + return 2; /* VER_PLATFORM_WIN32_NT */; +} + +void *TclWinGetTclInstance() +{ + void *hInstance = NULL; + GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + (const char *)&winTCharEncoding, &hInstance); + return hInstance; +} + +int +TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) +{ + return setsockopt((int) s, level, optname, optval, optlen); +} + +int +TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) +{ + return getsockopt((int) s, level, optname, optval, optlen); +} + +struct servent * +TclWinGetServByName(const char *name, const char *proto) +{ + return getservbyname(name, proto); +} + +char * +TclWinNoBackslash(char *path) +{ + char *p; + + for (p = path; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + return path; +} + +int +TclpGetPid(Tcl_Pid pid) +{ + return (int) (size_t) pid; +} + +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} + +char * +Tcl_WinUtfToTChar( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + if (!winTCharEncoding) { + winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + } + return Tcl_UtfToExternalDString(winTCharEncoding, + string, len, dsPtr); +} + +char * +Tcl_WinTCharToUtf( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + if (!winTCharEncoding) { + winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + } + return Tcl_ExternalToUtfDString(winTCharEncoding, + string, len, dsPtr); +} + +#else /* UNIX and MAC */ +# define TclpLocaltime_unix TclpLocaltime +# define TclpGmtime_unix TclpGmtime +#endif /* * WARNING: The contents of this file is automatically generated by the @@ -80,7 +213,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ - 0, /* 24 */ + TclFormatInt, /* 24 */ TclFreePackageInfo, /* 25 */ 0, /* 26 */ 0, /* 27 */ @@ -134,7 +267,7 @@ static const TclIntStubs tclIntStubs = { TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ TclpGetTime, /* 77 */ - TclpGetTimeZone, /* 78 */ + 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ TclpRealloc, /* 81 */ @@ -160,13 +293,13 @@ static const TclIntStubs tclIntStubs = { TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - TclSockMinimumBuffers, /* 104 */ + TclSockMinimumBuffersOld, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ - 0, /* 110 */ + TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ Tcl_AppendExportList, /* 112 */ Tcl_CreateNamespace, /* 113 */ @@ -305,12 +438,14 @@ static const TclIntStubs tclIntStubs = { TclInitRewriteEnsemble, /* 246 */ TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ + TclDoubleDigits, /* 249 */ + TclSetSlaveCancelFlags, /* 250 */ }; static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ @@ -326,38 +461,55 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclpGmtime_unix, /* 12 */ TclpInetNtoa, /* 13 */ TclUnixCopyFile, /* 14 */ + 0, /* 15 */ + 0, /* 16 */ + 0, /* 17 */ + 0, /* 18 */ + 0, /* 19 */ + 0, /* 20 */ + 0, /* 21 */ + 0, /* 22 */ + 0, /* 23 */ + 0, /* 24 */ + 0, /* 25 */ + 0, /* 26 */ + 0, /* 27 */ + 0, /* 28 */ + TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ TclWinConvertWSAError, /* 1 */ TclWinGetServByName, /* 2 */ TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ - 0, /* 5 */ + TclUnixWaitForFile, /* 5 */ TclWinNToHS, /* 6 */ TclWinSetSockOpt, /* 7 */ TclpGetPid, /* 8 */ TclWinGetPlatformId, /* 9 */ - 0, /* 10 */ + TclpReaddir, /* 10 */ TclGetAndDetachPids, /* 11 */ TclpCloseFile, /* 12 */ TclpCreateCommandChannel, /* 13 */ TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ + TclpIsAtty, /* 16 */ + TclUnixCopyFile, /* 17 */ TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ - 0, /* 21 */ + TclpInetNtoa, /* 21 */ TclpCreateTempFile, /* 22 */ - TclpGetTZName, /* 23 */ + 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ TclGetAndDetachPids, /* 0 */ @@ -380,13 +532,24 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ + 0, /* 20 */ + 0, /* 21 */ + 0, /* 22 */ + 0, /* 23 */ + 0, /* 24 */ + 0, /* 25 */ + 0, /* 26 */ + 0, /* 27 */ + 0, /* 28 */ + TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* MACOSX */ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ @@ -460,6 +623,9 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_s_mp_mul_digs, /* 58 */ TclBN_s_mp_sqr, /* 59 */ TclBN_s_mp_sub, /* 60 */ + TclBN_mp_init_set_int, /* 61 */ + TclBN_mp_set_int, /* 62 */ + TclBN_mp_cnt_lsb, /* 63 */ }; static const TclStubHooks tclStubHooks = { @@ -483,7 +649,7 @@ const TclStubs tclStubs = { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ 0, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -492,7 +658,7 @@ const TclStubs tclStubs = { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ 0, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -657,7 +823,7 @@ const TclStubs tclStubs = { #if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#ifdef __WIN32__ /* WIN */ +#if defined(__WIN32__) /* WIN */ 0, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -1125,6 +1291,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ + Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 0197741..a9d0f02 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -9,19 +9,8 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclStubLib.c,v 1.34 2010/08/31 20:48:17 nijtmans Exp $ - */ - -/* - * We need to ensure that we use the stub macros so that this file contains no - * references to any of the stub functions. This will make it possible to - * build an extension that references Tcl_InitStubs but doesn't end up - * including the rest of the stub functions. */ -#define USE_TCL_STUBS - #include "tclInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; @@ -43,9 +32,7 @@ HasStubSupport( if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } - - iPtr->result = - (char *)"This interpreter does not support stubs-enabled extensions."; + iPtr->result = (char *) "interpreter uses an incompatible stubs mechanism"; iPtr->freeProc = TCL_STATIC; return NULL; } @@ -76,7 +63,7 @@ static int isDigit(const int c) * *---------------------------------------------------------------------- */ - +#undef Tcl_InitStubs MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, @@ -85,6 +72,7 @@ Tcl_InitStubs( { const char *actualVersion = NULL; ClientData pkgData = NULL; + const TclStubs *stubsPtr; /* * We can't optimize this check by caching tclStubsPtr because that @@ -92,12 +80,12 @@ Tcl_InitStubs( * times. [Bug 615304] */ - tclStubsPtr = HasStubSupport(interp); - if (!tclStubsPtr) { + stubsPtr = HasStubSupport(interp); + if (!stubsPtr) { return NULL; } - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } @@ -115,19 +103,19 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p) { + if (*p || isDigit(*q)) { /* Construct error message */ - Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; } } else { - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); if (actualVersion == NULL) { return NULL; } } } - tclStubsPtr = (TclStubs *) pkgData; + tclStubsPtr = (TclStubs *)pkgData; if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; diff --git a/generic/tclTest.c b/generic/tclTest.c index b845d72..a8b27fb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,8 +13,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTest.c,v 1.154 2010/09/27 19:42:38 msofer Exp $ */ #undef STATIC_BUILD @@ -23,6 +21,8 @@ #endif #include "tclInt.h" #include "tclOO.h" +#include <math.h> + /* * Required for Testregexp*Cmd */ @@ -75,6 +75,8 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; +TCL_DECLARE_MUTEX(asyncTestMutex) + static TestAsyncHandler *firstHandler = NULL; /* @@ -233,6 +235,9 @@ static int TestdelCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdelassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestdoubledigitsObjCmd(ClientData dummy, + Tcl_Interp* interp, + int objc, Tcl_Obj* const objv[]); static int TestdstringCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestencodingObjCmd(ClientData dummy, @@ -303,9 +308,8 @@ static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestfinexitObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -377,7 +381,8 @@ static Tcl_FSRenameFileProc TestReportRenameFile; static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; -static Tcl_FSLoadFileProc TestReportLoadFile; +static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); static Tcl_FSLinkProc TestReportLink; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; @@ -404,6 +409,14 @@ static int TestHashSystemHashCmd(ClientData clientData, static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestInterpResolverCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +#if defined(HAVE_CPUID) || defined(__WIN32__) +static int TestcpuidCmd(ClientData dummy, + Tcl_Interp* interp, int objc, + Tcl_Obj *const objv[]); +#endif static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -434,7 +447,7 @@ static const Tcl_Filesystem testReportingFilesystem = { TestReportRenameFile, TestReportCopyDirectory, TestReportLstat, - TestReportLoadFile, + (Tcl_FSLoadFileProc *) TestReportLoadFile, NULL /* cwd */, TestReportChdir }; @@ -569,6 +582,8 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd, + NULL, NULL); Tcl_DStringInit(&dstring); Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL, NULL); @@ -616,7 +631,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -658,6 +673,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); +#if defined(HAVE_CPUID) || defined(__WIN32__) + Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, + (ClientData) 0, NULL); +#endif t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, @@ -665,6 +684,8 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); + Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, + NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -785,25 +806,29 @@ TestasyncCmd( if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr = ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->command = ckalloc(strlen(argv[2]) + 1); + strcpy(asyncPtr->command, argv[2]); + Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; nextId++; asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, - (ClientData) asyncPtr); - asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); - strcpy(asyncPtr->command, argv[2]); + INT2PTR(asyncPtr->id)); asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; + Tcl_MutexUnlock(&asyncTestMutex); Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id)); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { + Tcl_MutexLock(&asyncTestMutex); while (firstHandler != NULL) { asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree((char *) asyncPtr); + ckfree(asyncPtr); } + Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; } if (argc != 3) { @@ -812,6 +837,7 @@ TestasyncCmd( if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id != id) { @@ -824,9 +850,10 @@ TestasyncCmd( } Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree((char *) asyncPtr); + ckfree(asyncPtr); break; } + Tcl_MutexUnlock(&asyncTestMutex); } else if (strcmp(argv[1], "mark") == 0) { if (argc != 5) { goto wrongNumArgs; @@ -835,6 +862,7 @@ TestasyncCmd( || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -843,6 +871,7 @@ TestasyncCmd( } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_MutexUnlock(&asyncTestMutex); return code; #ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { @@ -852,19 +881,22 @@ TestasyncCmd( if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { Tcl_ThreadId threadID; if (Tcl_CreateThread(&threadID, AsyncThreadProc, - (ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT, + INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } break; } } + Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, mark, or marklater", NULL); @@ -881,15 +913,29 @@ TestasyncCmd( static int AsyncHandlerProc( - ClientData clientData, /* Pointer to TestAsyncHandler structure. */ + ClientData clientData, /* If of TestAsyncHandler structure. + * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ int code) /* Current return code from command. */ { - TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + TestAsyncHandler *asyncPtr; + int id = PTR2INT(clientData); const char *listArgv[4], *cmd; char string[TCL_INTEGER_SPACE]; + Tcl_MutexLock(&asyncTestMutex); + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) break; + } + Tcl_MutexUnlock(&asyncTestMutex); + + if (!asyncPtr) { + /* Woops - this one was deleted between the AsyncMark and now */ + return TCL_OK; + } + TclFormatInt(string, code); listArgv[0] = asyncPtr->command; listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); @@ -904,7 +950,7 @@ AsyncHandlerProc( * invoked, it's possible. Better error checking is needed here. */ } - ckfree((char *)cmd); + ckfree(cmd); return code; } @@ -927,12 +973,22 @@ AsyncHandlerProc( #ifdef TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - ClientData clientData) /* Parameter is a pointer to a + ClientData clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { - TestAsyncHandler *asyncPtr = clientData; + TestAsyncHandler *asyncPtr; + int id = PTR2INT(clientData); + Tcl_Sleep(1); - Tcl_AsyncMark(asyncPtr->handler); + Tcl_MutexLock(&asyncTestMutex); + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_MutexUnlock(&asyncTestMutex); Tcl_ExitThread(TCL_OK); TCL_THREAD_CREATE_RETURN; } @@ -1522,9 +1578,9 @@ TestdelCmd( return TCL_ERROR; } - dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr = ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, @@ -1543,7 +1599,7 @@ DelCmdProc( Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); ckfree(dPtr->deleteCmd); - ckfree((char *) dPtr); + ckfree(dPtr); return TCL_OK; } @@ -1551,12 +1607,12 @@ static void DelDeleteProc( ClientData clientData) /* String command to evaluate. */ { - DelCmd *dPtr = (DelCmd *) clientData; + DelCmd *dPtr = clientData; Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); - ckfree((char *) dPtr); + ckfree(dPtr); } /* @@ -1594,6 +1650,102 @@ TestdelassocdataCmd( } /* + *----------------------------------------------------------------------------- + * + * TestdoubledigitsCmd -- + * + * This procedure implements the 'testdoubledigits' command. It is + * used to test the low-level floating-point formatting primitives + * in Tcl. + * + * Usage: + * testdoubledigits fpval ndigits type ?shorten" + * + * Parameters: + * fpval - Floating-point value to format. + * ndigits - Digit count to request from Tcl_DoubleDigits + * type - One of 'shortest', 'Steele', 'e', 'f' + * shorten - Indicates that the 'shorten' flag should be passed in. + * + *----------------------------------------------------------------------------- + */ + +static int +TestdoubledigitsObjCmd(ClientData unused, + /* NULL */ + Tcl_Interp* interp, + /* Tcl interpreter */ + int objc, + /* Parameter count */ + Tcl_Obj* const objv[]) + /* Parameter vector */ +{ + static const char* options[] = { + "shortest", + "Steele", + "e", + "f", + NULL + }; + static const int types[] = { + TCL_DD_SHORTEST, + TCL_DD_STEELE, + TCL_DD_E_FORMAT, + TCL_DD_F_FORMAT + }; + + const Tcl_ObjType* doubleType; + double d; + int status; + int ndigits; + int type; + int decpt; + int signum; + char* str; + char* endPtr; + Tcl_Obj* strObj; + Tcl_Obj* retval; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?"); + return TCL_ERROR; + } + status = Tcl_GetDoubleFromObj(interp, objv[1], &d); + if (status != TCL_OK) { + doubleType = Tcl_GetObjType("double"); + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { + status = TCL_OK; + memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); + } + } + if (status != TCL_OK + || Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK + || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type", + TCL_EXACT, &type) != TCL_OK) { + fprintf(stderr, "bad value? %g\n", d); + return TCL_ERROR; + } + type = types[type]; + if (objc > 4) { + if (strcmp(Tcl_GetString(objv[4]), "shorten")) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1)); + return TCL_ERROR; + } + type |= TCL_DD_SHORTEN_FLAG; + } + str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); + strObj = Tcl_NewStringObj(str, endPtr-str); + ckfree(str); + retval = Tcl_NewListObj(1, &strObj); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); + Tcl_ListObjAppendElement(NULL, retval, strObj); + Tcl_SetObjResult(interp, retval); + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * TestdstringCmd -- @@ -1662,11 +1814,11 @@ TestdstringCmd( } 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); } else if (strcmp(argv[2], "free") == 0) { - char *s = (char *) ckalloc(100); + char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char *) ckalloc(100) + 16; + char *s = (char*)ckalloc(100) + 16; strcpy(s, "This is a specially-allocated string"); Tcl_SetResult(interp, s, SpecialFree); } else { @@ -1768,15 +1920,15 @@ TestencodingObjCmd( if (objc != 5) { return TCL_ERROR; } - encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); + encodingPtr = ckalloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + encodingPtr->toUtfCmd = ckalloc(length + 1); memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + encodingPtr->fromUtfCmd = ckalloc(length + 1); memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); string = Tcl_GetStringFromObj(objv[2], &length); @@ -1871,12 +2023,11 @@ static void EncodingFreeProc( ClientData clientData) /* ClientData associated with type. */ { - TclEncoding *encodingPtr; + TclEncoding *encodingPtr = clientData; - encodingPtr = (TclEncoding *) clientData; - ckfree((char *) encodingPtr->toUtfCmd); - ckfree((char *) encodingPtr->fromUtfCmd); - ckfree((char *) encodingPtr); + ckfree(encodingPtr->toUtfCmd); + ckfree(encodingPtr->fromUtfCmd); + ckfree(encodingPtr); } /* @@ -2031,7 +2182,7 @@ TesteventObjCmd( "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent *) ckalloc(sizeof(TestEvent)); + ev = ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; @@ -2889,7 +3040,7 @@ TestlinkCmd( if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + stringVar = ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } @@ -2996,7 +3147,7 @@ TestlinkCmd( if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + stringVar = ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); @@ -3117,7 +3268,7 @@ TestlocaleCmd( "ctype", "numeric", "time", "collate", "monetary", "all", NULL }; - static int lcTypes[] = { + static const int lcTypes[] = { LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, LC_ALL }; @@ -3308,7 +3459,7 @@ CleanupTestSetassocdataTests( ClientData clientData, /* Data to be released. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { - ckfree((char *) clientData); + ckfree(clientData); } /* @@ -3839,10 +3990,8 @@ TestregexpObjCmd( info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } @@ -4007,7 +4156,7 @@ TestsetassocdataCmd( return TCL_ERROR; } - buf = ckalloc((unsigned) strlen(argv[2]) + 1); + buf = ckalloc(strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* @@ -4389,53 +4538,12 @@ TestpanicCmd( */ argString = Tcl_Merge(argc-1, argv+1); - Tcl_Panic(argString); - ckfree((char *)argString); + Tcl_Panic("%s", argString); + ckfree(argString); return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * TestfinexitObjCmd -- - * - * Calls a variant of [exit] including the full finalization path. - * - * Results: - * Error, or doesn't return. - * - * Side effects: - * Exits application. - * - *---------------------------------------------------------------------- - */ - -static int -TestfinexitObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int value; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); - return TCL_ERROR; - } - - if (objc == 1) { - value = 0; - } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Finalize(); - TclpExit(value); - /*NOTREACHED*/ - return TCL_ERROR; /* Better not ever reach this! */ -} - static int TestfileCmd( ClientData dummy, /* Not used. */ @@ -4615,8 +4723,8 @@ GetTimesCmd( fprintf(stderr, "alloc & free 100000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); - ckfree((char *) objPtr); + objPtr = ckalloc(sizeof(Tcl_Obj)); + ckfree(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4624,10 +4732,10 @@ GetTimesCmd( /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); + objv = ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); + objv[i] = ckalloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4637,7 +4745,7 @@ GetTimesCmd( fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - ckfree((char *) objv[i]); + ckfree(objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4663,7 +4771,7 @@ GetTimesCmd( Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - ckfree((char *) objv); + ckfree(objv); /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); @@ -5054,7 +5162,7 @@ TestmainthreadCmd( const char **argv) /* Argument strings. */ { if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; @@ -5211,7 +5319,7 @@ TestChannelCmd( *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - ckfree((char *) curPtr); + ckfree(curPtr); break; } } @@ -5281,7 +5389,7 @@ TestChannelCmd( /* Remember the channel in the pool of detached channels */ - det = (TestChannel *) ckalloc(sizeof(TestChannel)); + det = ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; @@ -5451,7 +5559,7 @@ TestChannelCmd( return TCL_ERROR; } - TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); + TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan)); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -5679,8 +5787,7 @@ TestChannelEventCmd( return TCL_ERROR; } - esPtr = (EventScriptRecord *) ckalloc((unsigned) - sizeof(EventScriptRecord)); + esPtr = ckalloc(sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; @@ -5737,7 +5844,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree((char *) esPtr); + ckfree(esPtr); return TCL_OK; } @@ -5778,7 +5885,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree((char *) esPtr); + ckfree(esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; @@ -6506,6 +6613,62 @@ TestNumUtfCharsCmd( } return TCL_OK; } + +#if defined(HAVE_CPUID) || defined(__WIN32__) +/* + *---------------------------------------------------------------------- + * + * TestcpuidCmd -- + * + * Retrieves CPU ID information. + * + * Usage: + * testwincpuid <eax> + * + * Parameters: + * eax - The value to pass in the EAX register to a CPUID instruction. + * + * Results: + * Returns a four-element list containing the values from the EAX, EBX, + * ECX and EDX registers returned from the CPUID instruction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestcpuidCmd( + ClientData dummy, + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + int status, index, i; + unsigned int regs[4]; + Tcl_Obj *regsObjs[4]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "eax"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { + return TCL_ERROR; + } + status = TclWinCPUID((unsigned) 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]); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); + return TCL_OK; +} +#endif /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag @@ -6623,7 +6786,7 @@ TestNRELevels( ptrdiff_t depth; Tcl_Obj *levels[6]; int i = 0; - TEOV_callback *cbPtr = ((Interp *) interp)->execEnvPtr->callbackPtr; + NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { refDepth = &depth; @@ -6632,11 +6795,11 @@ TestNRELevels( depth = (refDepth - &depth); levels[0] = Tcl_NewIntObj(depth); - levels[1] = Tcl_NewIntObj(((Interp *)interp)->numLevels); + levels[1] = Tcl_NewIntObj(iPtr->numLevels); levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr - - iPtr->execEnvPtr->execStackPtr->stackWords)); + levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr + - iPtr->execEnvPtr->execStackPtr->stackWords); while (cbPtr) { i++; @@ -6953,9 +7116,245 @@ TestconcatobjCmd( } /* + *---------------------------------------------------------------------- + * + * TestparseargsCmd -- + * + * This procedure implements the "testparseargs" command. It is used to + * test that Tcl_ParseArgsObjv does indeed return the right number of + * arguments. In other words, that [Bug 3413857] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparseargsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + static int foo = 0; + int count = objc; + Tcl_Obj **remObjv, *result[3]; + Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, + TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END + }; + + foo = 0; + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { + return TCL_ERROR; + } + result[0] = Tcl_NewIntObj(foo); + result[1] = Tcl_NewIntObj(count); + result[2] = Tcl_NewListObj(count, remObjv); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + ckfree(remObjv); + return TCL_OK; +} + +/** + * Test harness for command and variable resolvers. + */ + +static int +InterpCmdResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Command *rPtr) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? + varFramePtr->procPtr : NULL; + Namespace *ns2NsPtr = (Namespace *) + Tcl_FindNamespace(interp, "::ns2", NULL, 0); + + if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr + || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { + const char *callingCmdName = + Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); + + if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') + && (name[0] == 'z') && (name[1] == '\0')) { + Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, + TCL_GLOBAL_ONLY); + + if (sourceCmdPtr != NULL) { + *rPtr = sourceCmdPtr; + return TCL_OK; + } + } + } + return TCL_CONTINUE; +} + +static int +InterpVarResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Var *rPtr) +{ + /* + * Don't resolve the variable; use standard rules. + */ + + return TCL_CONTINUE; +} + +typedef struct MyResolvedVarInfo { + Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ + Tcl_Var var; + Tcl_Obj *nameObj; +} MyResolvedVarInfo; + +static inline void +HashVarFree( + Tcl_Var var) +{ + if (VarHashRefCount(var) < 2) { + ckfree(var); + } else { + VarHashRefCount(var)--; + } +} + +static void +MyCompiledVarFree( + Tcl_ResolvedVarInfo *vInfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr; + + Tcl_DecrRefCount(resVarInfo->nameObj); + if (resVarInfo->var) { + HashVarFree(resVarInfo->var); + } + ckfree(vInfoPtr); +} + +#define TclVarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static Tcl_Var +MyCompiledVarFetch( + Tcl_Interp *interp, + Tcl_ResolvedVarInfo *vinfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; + Tcl_Var var = resVarInfo->var; + int isNewVar; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + + if (var != NULL) { + if (!(((Var *) var)->flags & VAR_DEAD_HASH)) { + /* + * The cached variable is valid, return it. + */ + + return var; + } + + /* + * The variable is not valid anymore. Clean it up. + */ + + HashVarFree(var); + } + + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, + (char *) resVarInfo->nameObj, &isNewVar); + if (hPtr) { + var = (Tcl_Var) TclVarHashGetValue(hPtr); + } else { + var = NULL; + } + resVarInfo->var = var; + + /* + * Increment the reference counter to avoid ckfree() of the variable in + * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); + */ + + VarHashRefCount(var)++; + return var; +} + +static int +InterpCompiledVarResolver( + Tcl_Interp *interp, + const char *name, + int length, + Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr) +{ + if (*name == 'T') { + MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo)); + + resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; + resVarInfo->vInfo.deleteProc = MyCompiledVarFree; + resVarInfo->var = NULL; + resVarInfo->nameObj = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(resVarInfo->nameObj); + *rPtr = &resVarInfo->vInfo; + return TCL_OK; + } + return TCL_CONTINUE; +} + +static int +TestInterpResolverCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const table[] = { + "down", "up", NULL + }; + int idx; +#define RESOLVER_KEY "testInterpResolver" + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "up|down"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case 1: /* up */ + Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver, + InterpVarResolver, InterpCompiledVarResolver); + break; + case 0: /*down*/ + if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { + Tcl_AppendResult(interp, "could not remove the resolver scheme", + NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 89f42a6..7494beb 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTestObj.c,v 1.38 2010/03/18 20:34:48 dgp Exp $ */ #ifndef USE_TCL_STUBS @@ -22,23 +20,15 @@ #include "tclInt.h" #include "tommath.h" -/* - * An array of Tcl_Obj pointers used in the commands that operate on or get - * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's - * Tcl_Obj *. - */ - -#define NUMBER_OF_OBJECT_VARS 20 -static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS]; /* * Forward declarations for functions defined later in this file: */ -static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex); +static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex); static int GetVariableIndex(Tcl_Interp *interp, const char *string, int *indexPtr); -static void SetVarToObj(int varIndex, Tcl_Obj *objPtr); +static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr); static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestbooleanobjCmd(ClientData dummy, @@ -64,6 +54,27 @@ typedef struct TestString { Tcl_UniChar unicode[2]; } TestString; +#define VARPTR_KEY "TCLOBJTEST_VARPTR" +#define NUMBER_OF_OBJECT_VARS 20 + +static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp) +{ + register int i; + Tcl_Obj **varPtr = (Tcl_Obj **) clientData; + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); + } + Tcl_DeleteAssocData(interp, VARPTR_KEY); + ckfree(varPtr); +} + +static Tcl_Obj **GetVarPtr(Tcl_Interp *interp) +{ + Tcl_InterpDeleteProc *proc; + + return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc); +} + /* *---------------------------------------------------------------------- * @@ -87,7 +98,18 @@ TclObjTest_Init( Tcl_Interp *interp) { register int i; + /* + * An array of Tcl_Obj pointers used in the commands that operate on or get + * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's + * Tcl_Obj *. + */ + Tcl_Obj **varPtr; + varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); + if (!varPtr) { + return TCL_ERROR; + } + Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr); for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { varPtr[i] = NULL; } @@ -144,6 +166,7 @@ TestbignumobjCmd( int index, varIndex; const char *string; mp_int bignumValue, newValue; + Tcl_Obj **varPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -157,6 +180,7 @@ TestbignumobjCmd( if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { return TCL_ERROR; } + varPtr = GetVarPtr(interp); switch (index) { case BIGNUM_SET: @@ -188,7 +212,7 @@ TestbignumobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; @@ -197,7 +221,7 @@ TestbignumobjCmd( Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } break; @@ -207,7 +231,7 @@ TestbignumobjCmd( Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], @@ -226,7 +250,7 @@ TestbignumobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { - SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); } break; @@ -235,7 +259,7 @@ TestbignumobjCmd( Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], @@ -254,7 +278,7 @@ TestbignumobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { - SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); } } @@ -289,6 +313,7 @@ TestbooleanobjCmd( { int varIndex, boolValue; const char *index, *subCmd; + Tcl_Obj **varPtr; if (objc < 3) { wrongNumArgs: @@ -301,6 +326,8 @@ TestbooleanobjCmd( return TCL_ERROR; } + varPtr = GetVarPtr(interp); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "set") == 0) { if (objc != 4) { @@ -321,14 +348,14 @@ TestbooleanobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBooleanObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -336,7 +363,7 @@ TestbooleanobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex], @@ -346,7 +373,7 @@ TestbooleanobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -387,6 +414,7 @@ TestdoubleobjCmd( int varIndex; double doubleValue; const char *index, *subCmd, *string; + Tcl_Obj **varPtr; if (objc < 3) { wrongNumArgs: @@ -394,6 +422,8 @@ TestdoubleobjCmd( return TCL_ERROR; } + varPtr = GetVarPtr(interp); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; @@ -420,14 +450,14 @@ TestdoubleobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetDoubleObj(varPtr[varIndex], doubleValue); } else { - SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -435,7 +465,7 @@ TestdoubleobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], @@ -445,14 +475,14 @@ TestdoubleobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0); } else { - SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0)); + SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue * 10.0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], @@ -462,7 +492,7 @@ TestdoubleobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0); } else { - SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0)); + SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -525,7 +555,7 @@ TestindexobjCmd( } Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); - indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; + indexRep = objv[1]->internalRep.otherValuePtr; indexRep->index = index2; result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); @@ -547,7 +577,7 @@ TestindexobjCmd( return TCL_ERROR; } - argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); + argv = ckalloc((objc-3) * sizeof(char *)); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } @@ -562,16 +592,15 @@ TestindexobjCmd( if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; + indexRep = objv[3]->internalRep.otherValuePtr; if (indexRep->tablePtr == (void *) argv) { - objv[3]->typePtr->freeIntRepProc(objv[3]); - objv[3]->typePtr = NULL; + TclFreeIntRep(objv[3]); } } result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); - ckfree((char *) argv); + ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); } @@ -606,6 +635,7 @@ TestintobjCmd( int intValue, varIndex, i; long longValue; const char *index, *subCmd, *string; + Tcl_Obj **varPtr; if (objc < 3) { wrongNumArgs: @@ -613,6 +643,7 @@ TestintobjCmd( return TCL_ERROR; } + varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; @@ -640,7 +671,7 @@ TestintobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ @@ -655,7 +686,7 @@ TestintobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); } } else if (strcmp(subCmd, "setlong") == 0) { if (objc != 4) { @@ -669,7 +700,7 @@ TestintobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetLongObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varIndex, Tcl_NewLongObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "setmaxlong") == 0) { @@ -680,13 +711,13 @@ TestintobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetLongObj(varPtr[varIndex], maxLong); } else { - SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong)); } } else if (strcmp(subCmd, "ismaxlong") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { @@ -698,7 +729,7 @@ TestintobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -706,7 +737,7 @@ TestintobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } string = Tcl_GetString(varPtr[varIndex]); @@ -728,7 +759,7 @@ TestintobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); } else { - SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX)); } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { Tcl_ResetResult(interp); @@ -741,7 +772,7 @@ TestintobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], @@ -751,14 +782,14 @@ TestintobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue * 10); } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], @@ -768,7 +799,7 @@ TestintobjCmd( if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue / 10); } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -822,11 +853,13 @@ TestlistobjCmd( int cmdIndex; /* Ordinal number of the subcommand */ int first; /* First index in the list */ int count; /* Count of elements in a list */ + Tcl_Obj **varPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); return TCL_ERROR; } + varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; @@ -840,7 +873,7 @@ TestlistobjCmd( if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); } else { - SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3)); + SetVarToObj(varPtr, varIndex, Tcl_NewListObj(objc-3, objv+3)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -850,7 +883,7 @@ TestlistobjCmd( Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -867,7 +900,7 @@ TestlistobjCmd( return TCL_ERROR; } if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } Tcl_ResetResult(interp); return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, @@ -903,6 +936,7 @@ TestobjCmd( int varIndex, destIndex, i; const char *index, *subCmd, *string; const Tcl_ObjType *targetType; + Tcl_Obj **varPtr; if (objc < 2) { wrongNumArgs: @@ -910,6 +944,7 @@ TestobjCmd( return TCL_ERROR; } + varPtr = GetVarPtr(interp); subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "assign") == 0) { if (objc != 4) { @@ -919,14 +954,14 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(destIndex, varPtr[varIndex]); + SetVarToObj(varPtr, destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "convert") == 0) { const char *typeName; @@ -938,7 +973,7 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } typeName = Tcl_GetString(objv[3]); @@ -960,14 +995,14 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "freeallvars") == 0) { if (objc != 2) { @@ -987,7 +1022,7 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_InvalidateStringRep(varPtr[varIndex]); @@ -1000,7 +1035,7 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varIndex, Tcl_NewObj()); + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "objtype") == 0) { const char *typeName; @@ -1027,7 +1062,7 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); @@ -1039,7 +1074,7 @@ TestobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ @@ -1096,6 +1131,7 @@ TeststringobjCmd( #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; TestString *strPtr; + Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "maxchars", "getunicode", @@ -1108,6 +1144,7 @@ TeststringobjCmd( return TCL_ERROR; } + varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; @@ -1126,7 +1163,7 @@ TeststringobjCmd( return TCL_ERROR; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); } /* @@ -1135,7 +1172,7 @@ TeststringobjCmd( */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetString(objv[3]); Tcl_AppendToObj(varPtr[varIndex], string, length); @@ -1146,7 +1183,7 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); } /* @@ -1155,7 +1192,7 @@ TeststringobjCmd( */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } for (i = 3; i < objc; i++) { strings[i-3] = Tcl_GetString(objv[i]); @@ -1173,7 +1210,7 @@ TeststringobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -1182,7 +1219,7 @@ TeststringobjCmd( if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varPtr, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(varPtr[varIndex]); @@ -1202,8 +1239,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = (int) strPtr->allocated; } else { length = -1; @@ -1229,7 +1265,7 @@ TeststringobjCmd( && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetStringObj(varPtr[varIndex], string, length); } else { - SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); + SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -1237,7 +1273,7 @@ TeststringobjCmd( if (objc != 4) { goto wrongNumArgs; } - SetVarToObj(varIndex, objv[3]); + SetVarToObj(varPtr, varIndex, objv[3]); break; case 8: /* setlength */ if (objc != 4) { @@ -1257,8 +1293,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = strPtr->maxChars; } else { length = -1; @@ -1276,7 +1311,7 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); } /* @@ -1285,7 +1320,7 @@ TeststringobjCmd( */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetStringFromObj(varPtr[varIndex], &length); @@ -1307,7 +1342,7 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); } /* @@ -1316,7 +1351,7 @@ TeststringobjCmd( */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); @@ -1359,6 +1394,7 @@ TeststringobjCmd( static void SetVarToObj( + Tcl_Obj **varPtr, int varIndex, /* Designates the assignment variable. */ Tcl_Obj *objPtr) /* Points to object to assign to var. */ { @@ -1431,6 +1467,7 @@ GetVariableIndex( static int CheckIfVarUnset( Tcl_Interp *interp, /* Interpreter for error reporting. */ + Tcl_Obj ** varPtr, int varIndex) /* Index of the test variable to check. */ { if (varPtr[varIndex] == NULL) { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 6e0b670..a3f89f6 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.12 2010/06/16 14:49:50 nijtmans Exp $ */ #ifndef USE_TCL_STUBS diff --git a/generic/tclThread.c b/generic/tclThread.c index 58cc18d..d1f2691 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclThread.c,v 1.25 2009/03/16 00:43:09 mistachkin Exp $ */ #include "tclInt.h" @@ -85,16 +83,17 @@ Tcl_GetThreadData( /* * Initialize the key for this thread. */ + result = TclThreadStorageKeyGet(keyPtr); if (result == NULL) { - result = ckalloc((size_t)size); + result = ckalloc(size); memset(result, 0, (size_t) size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { - result = ckalloc((size_t)size); + result = ckalloc(size); memset(result, 0, (size_t)size); *keyPtr = result; RememberSyncObject(keyPtr, &keyRecord); @@ -180,14 +179,14 @@ RememberSyncObject( if (recPtr->num >= recPtr->max) { recPtr->max += 8; - newList = (void **) ckalloc(recPtr->max * sizeof(void *)); + newList = ckalloc(recPtr->max * sizeof(void *)); for (i=0,j=0 ; i<recPtr->num ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { - ckfree((char *) recPtr->list); + ckfree(recPtr->list); } recPtr->list = newList; recPtr->num = j; @@ -399,7 +398,7 @@ TclFinalizeSynchronization(void) blockPtr = *keyPtr; ckfree(blockPtr); } - ckfree((char *) keyRecord.list); + ckfree(keyRecord.list); keyRecord.list = NULL; } keyRecord.max = 0; @@ -419,7 +418,7 @@ TclFinalizeSynchronization(void) } } if (mutexRecord.list != NULL) { - ckfree((char *) mutexRecord.list); + ckfree(mutexRecord.list); mutexRecord.list = NULL; } mutexRecord.max = 0; @@ -432,7 +431,7 @@ TclFinalizeSynchronization(void) } } if (condRecord.list != NULL) { - ckfree((char *) condRecord.list); + ckfree(condRecord.list); condRecord.list = NULL; } condRecord.max = 0; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 6ea6351..e4261d6 100755 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclThreadAlloc.c,v 1.32 2010/03/05 14:34:04 dkf Exp $ */ #include "tclInt.h" @@ -147,6 +145,26 @@ static Tcl_Mutex *objLockPtr; static Cache sharedCache; static Cache *sharedPtr = &sharedCache; static Cache *firstCachePtr = &sharedCache; + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; + +# define GETCACHE(cachePtr) \ + do { \ + if (!tcachePtr) { \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) +#else +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) +#endif /* *---------------------------------------------------------------------- @@ -310,10 +328,7 @@ TclpAlloc( } #endif - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } + GETCACHE(cachePtr); /* * Increment the requested size to include room for the Block structure. @@ -380,10 +395,7 @@ TclpFree( return; } - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } + GETCACHE(cachePtr); /* * Get the block back from the user pointer and call system free directly @@ -455,10 +467,7 @@ TclpRealloc( } #endif - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = GetCache(); - } + GETCACHE(cachePtr); /* * If the block is not a system block and fits in place, simply return the @@ -532,12 +541,10 @@ TclpRealloc( Tcl_Obj * TclThreadAllocObj(void) { - register Cache *cachePtr = TclpGetAllocCache(); + register Cache *cachePtr; register Tcl_Obj *objPtr; - if (cachePtr == NULL) { - cachePtr = GetCache(); - } + GETCACHE(cachePtr); /* * Get this thread's obj list structure and move or allocate new objs if @@ -606,11 +613,9 @@ void TclThreadFreeObj( Tcl_Obj *objPtr) { - Cache *cachePtr = TclpGetAllocCache(); + Cache *cachePtr; - if (cachePtr == NULL) { - cachePtr = GetCache(); - } + GETCACHE(cachePtr); /* * Get this thread's list and push on the free Tcl_Obj. @@ -807,15 +812,7 @@ LockBucket( Cache *cachePtr, int bucket) { -#if 0 - if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numWaits++; - sharedPtr->buckets[bucket].numWaits++; - } -#else Tcl_MutexLock(bucketInfo[bucket].lockPtr); -#endif cachePtr->buckets[bucket].numLocks++; sharedPtr->buckets[bucket].numLocks++; } diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 6410959..4b09e1c 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclThreadJoin.c,v 1.8 2010/02/24 10:32:17 dkf Exp $ */ #include "tclInt.h" @@ -203,7 +201,7 @@ TclJoinThread( Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); - ckfree((char *) threadPtr); + ckfree(threadPtr); return TCL_OK; } @@ -232,7 +230,7 @@ TclRememberJoinableThread( { JoinableThread *threadPtr; - threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread)); + threadPtr = ckalloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index ea2eeb1..f24e334 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclThreadStorage.c,v 1.21 2009/12/21 23:25:40 nijtmans Exp $ */ #include "tclInt.h" @@ -119,7 +117,7 @@ TSDTableDelete( * and must now be deallocated or they will leak. */ - ckfree((char *) tsdTablePtr->tablePtr[i]); + ckfree(tsdTablePtr->tablePtr[i]); } } diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 8607b15..22b5995 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -11,8 +11,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclThreadTest.c,v 1.35 2009/11/23 20:17:36 nijtmans Exp $ */ #ifndef USE_TCL_STUBS @@ -48,7 +46,7 @@ static Tcl_ThreadDataKey dataKey; * protected by threadMutex. */ -static ThreadSpecificData *threadList; +static ThreadSpecificData *threadList = NULL; /* * The following bit-values are legal for the "flags" field of the @@ -168,7 +166,7 @@ TclThread_Init( */ Tcl_MutexLock(&threadMutex); - if ((long) mainThreadId == 0) { + if (mainThreadId == 0) { mainThreadId = Tcl_GetCurrentThread(); } Tcl_MutexUnlock(&threadMutex); @@ -275,7 +273,7 @@ ThreadObjCmd( } else { result = NULL; } - return ThreadCancel(interp, (Tcl_ThreadId) id, result, flags); + return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags); } case THREAD_CREATE: { const char *script; @@ -339,11 +337,11 @@ ThreadObjCmd( */ if (objc == 2) { - idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewLongObj((long) mainThreadId); + idObj = Tcl_NewLongObj((long)(size_t)mainThreadId); Tcl_MutexUnlock(&threadMutex); } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -368,13 +366,13 @@ ThreadObjCmd( return TCL_ERROR; } - result = Tcl_JoinThread((Tcl_ThreadId) id, &status); + result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { char buf[20]; - sprintf(buf, "%ld", id); + TclFormatInt(buf, id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; @@ -410,7 +408,7 @@ ThreadObjCmd( } arg++; script = Tcl_GetString(objv[arg]); - return ThreadSend(interp, (Tcl_ThreadId) id, script, wait); + return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); } case THREAD_EVENT: { if (objc > 2) { @@ -438,7 +436,7 @@ ThreadObjCmd( ckfree(errorProcString); } proc = Tcl_GetString(objv[2]); - errorProcString = ckalloc(strlen(proc)+1); + errorProcString = ckalloc(strlen(proc) + 1); strcpy(errorProcString, proc); Tcl_MutexUnlock(&threadMutex); return TCL_OK; @@ -515,7 +513,7 @@ ThreadCreate( TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "can't create a new thread", NULL); - ckfree((char *) ctrl.script); + ckfree(ctrl.script); return TCL_ERROR; } @@ -526,7 +524,7 @@ ThreadCreate( Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); - Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id)); + Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id)); return TCL_OK; } @@ -599,7 +597,7 @@ NewTestThread( * eval'ing, for the case that we exit during evaluation */ - threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1); + threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1); strcpy(threadEvalScript, ctrlPtr->script); Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); @@ -625,9 +623,9 @@ NewTestThread( * Clean up. */ - ListRemove(tsdPtr); - Tcl_Release(tsdPtr->interp); Tcl_DeleteInterp(tsdPtr->interp); + Tcl_Release(tsdPtr->interp); + ListRemove(tsdPtr); Tcl_ExitThread(result); TCL_THREAD_CREATE_RETURN; @@ -658,7 +656,7 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); + TclFormatInt(buf, (size_t) Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { @@ -746,6 +744,7 @@ ListRemove( tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = 0; + tsdPtr->interp = NULL; Tcl_MutexUnlock(&threadMutex); } @@ -775,7 +774,7 @@ ThreadList( Tcl_MutexLock(&threadMutex); for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewLongObj((long) tsdPtr->threadId)); + Tcl_NewLongObj((long)(size_t)tsdPtr->threadId)); } Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, listPtr); @@ -843,13 +842,13 @@ ThreadSend( * Create the event for its event queue. */ - threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent)); + threadEventPtr = ckalloc(sizeof(ThreadEvent)); threadEventPtr->script = ckalloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult)); + resultPtr = ckalloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* @@ -932,7 +931,7 @@ ThreadSend( Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - ckfree((char *) resultPtr); + ckfree(resultPtr); return code; } @@ -989,7 +988,8 @@ ThreadCancel( Tcl_MutexUnlock(&threadMutex); Tcl_ResetResult(interp); - return Tcl_CancelEval(tsdPtr->interp, Tcl_NewStringObj(result, -1), 0, flags); + return Tcl_CancelEval(tsdPtr->interp, + (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags); } /* @@ -1085,7 +1085,7 @@ ThreadFreeProc( ClientData clientData) { if (clientData) { - ckfree((char *) clientData); + ckfree(clientData); } } @@ -1113,7 +1113,7 @@ ThreadDeleteEvent( ClientData clientData) /* dummy */ { if (eventPtr->proc == ThreadEventProc) { - ckfree((char *) ((ThreadEvent *) eventPtr)->script); + ckfree(((ThreadEvent *) eventPtr)->script); return 1; } @@ -1150,6 +1150,11 @@ ThreadExitProc( char *threadEvalScript = clientData; ThreadEventResult *resultPtr, *nextPtr; Tcl_ThreadId self = Tcl_GetCurrentThread(); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->interp != NULL) { + ListRemove(tsdPtr); + } Tcl_MutexLock(&threadMutex); @@ -1177,7 +1182,7 @@ ThreadExitProc( } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - ckfree((char *) resultPtr); + ckfree(resultPtr); } else if (resultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. The result diff --git a/generic/tclTimer.c b/generic/tclTimer.c index aaa3493..6b17825 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTimer.c,v 1.42 2010/02/24 10:32:17 dkf Exp $ */ #include "tclInt.h" @@ -129,6 +127,17 @@ static Tcl_ThreadDataKey dataKey; (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ ((long)(t1).usec - (long)(t2).usec)/1000) +#define TCL_TIME_DIFF_MS_CEILING(t1, t2) \ + (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ + ((long)(t1).usec - (long)(t2).usec + 999)/1000) + +/* + * Sleeps under that number of milliseconds don't get double-checked + * and are done in exactly one Tcl_Sleep(). This to limit gettimeofday()s. + */ + +#define SLEEP_OFFLOAD_GETTIMEOFDAY 20 + /* * The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay. * This is used to limit the maximum lag between interp limit and script @@ -173,8 +182,7 @@ static void TimerSetupProc(ClientData clientData, int flags); static ThreadSpecificData * InitTimer(void) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); @@ -205,8 +213,7 @@ static void TimerExitProc( ClientData clientData) /* Not used. */ { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { @@ -215,7 +222,7 @@ TimerExitProc( timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - ckfree((char *) timerHandlerPtr); + ckfree(timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } @@ -288,10 +295,9 @@ TclCreateAbsoluteTimerHandler( ClientData clientData) { register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; - ThreadSpecificData *tsdPtr; + ThreadSpecificData *tsdPtr = InitTimer(); - tsdPtr = InitTimer(); - timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + timerHandlerPtr = ckalloc(sizeof(TimerHandler)); /* * Fill in fields for the event. @@ -367,7 +373,7 @@ Tcl_DeleteTimerHandler( } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } - ckfree((char *) timerHandlerPtr); + ckfree(timerHandlerPtr); return; } } @@ -482,7 +488,7 @@ TimerCheckProc( if (blockTime.sec == 0 && blockTime.usec == 0 && !tsdPtr->timerPending) { tsdPtr->timerPending = 1; - timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event)); + timerEvPtr = ckalloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); } @@ -585,7 +591,7 @@ TimerHandlerEventProc( *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); - ckfree((char *) timerHandlerPtr); + ckfree(timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; @@ -619,7 +625,7 @@ Tcl_DoWhenIdle( Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); - idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); + idlePtr = ckalloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; idlePtr->generation = tsdPtr->idleGeneration; @@ -668,7 +674,7 @@ Tcl_CancelIdleCall( while ((idlePtr->proc == proc) && (idlePtr->clientData == clientData)) { nextPtr = idlePtr->nextPtr; - ckfree((char *) idlePtr); + ckfree(idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { tsdPtr->idleList = idlePtr; @@ -743,7 +749,7 @@ TclServiceIdle(void) tsdPtr->lastIdlePtr = NULL; } idlePtr->proc(idlePtr->clientData); - ckfree((char *) idlePtr); + ckfree(idlePtr); } if (tsdPtr->idleList) { blockTime.sec = 0; @@ -784,7 +790,6 @@ Tcl_AfterObjCmd( AfterAssocData *assocPtr; int length; int index; - char buf[16 + TCL_INTEGER_SPACE]; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; @@ -803,7 +808,7 @@ Tcl_AfterObjCmd( assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { - assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); + assocPtr = ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); @@ -822,9 +827,13 @@ Tcl_AfterObjCmd( &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - Tcl_AppendResult(interp, "bad argument \"", - Tcl_GetString(objv[1]), - "\": must be cancel, idle, info, or an integer", NULL); + const char *arg = Tcl_GetString(objv[1]); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument \"%s\": must be" + " cancel, idle, info, or an integer", arg)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", + arg, NULL); return TCL_ERROR; } } @@ -842,7 +851,7 @@ Tcl_AfterObjCmd( if (objc == 2) { return AfterDelay(interp, ms); } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -922,7 +931,7 @@ Tcl_AfterObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); return TCL_ERROR; } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -938,17 +947,18 @@ Tcl_AfterObjCmd( Tcl_DoWhenIdle(AfterProc, afterPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); break; - case AFTER_INFO: { - Tcl_Obj *resultListPtr; - + case AFTER_INFO: if (objc == 2) { + Tcl_Obj *resultObj = Tcl_NewObj(); + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buf); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( + "after#%d", afterPtr->id)); } } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } if (objc != 3) { @@ -957,17 +967,22 @@ Tcl_AfterObjCmd( } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]), - "\" doesn't exist", NULL); + const char *eventStr = TclGetString(objv[2]); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "event \"%s\" doesn't exist", eventStr)); + Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; - } - resultListPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); + } else { + Tcl_Obj *resultListPtr = Tcl_NewObj(); + + Tcl_ListObjAppendElement(interp, resultListPtr, + afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); + } break; - } default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } @@ -1002,7 +1017,8 @@ AfterDelay( Tcl_Time endTime, now; Tcl_WideInt diff; - Tcl_GetTime(&endTime); + Tcl_GetTime(&now); + endTime = now; endTime.sec += (long)(ms/1000); endTime.usec += ((int)(ms%1000))*1000; if (endTime.usec >= 1000000) { @@ -1011,7 +1027,6 @@ AfterDelay( } do { - Tcl_GetTime(&now); if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { return TCL_ERROR; @@ -1029,7 +1044,7 @@ AfterDelay( } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { - diff = TCL_TIME_DIFF_MS(endTime, now); + diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); #ifndef TCL_WIDE_INT_IS_LONG if (diff > LONG_MAX) { diff = LONG_MAX; @@ -1038,9 +1053,11 @@ AfterDelay( 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_Sleep((long) 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 @@ -1066,6 +1083,7 @@ AfterDelay( return TCL_ERROR; } } + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } @@ -1182,7 +1200,7 @@ AfterProc( */ Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree((char *) afterPtr); + ckfree(afterPtr); } /* @@ -1220,7 +1238,7 @@ FreeAfterPtr( prevPtr->nextPtr = afterPtr->nextPtr; } Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree((char *) afterPtr); + ckfree(afterPtr); } /* @@ -1259,9 +1277,9 @@ AfterCleanupProc( Tcl_CancelIdleCall(AfterProc, afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree((char *) afterPtr); + ckfree(afterPtr); } - ckfree((char *) assocPtr); + ckfree(assocPtr); } /* @@ -1269,5 +1287,7 @@ AfterCleanupProc( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 12fa7cd..ea3abb1 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tclTomMath.decls,v 1.8 2010/09/15 07:33:54 nijtmans Exp $ library tcl @@ -214,3 +212,12 @@ declare 59 { declare 60 { int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) } +declare 61 { + int TclBN_mp_init_set_int(mp_int *a, unsigned long i) +} +declare 62 { + int TclBN_mp_set_int(mp_int *a, unsigned long i) +} +declare 63 { + int TclBN_mp_cnt_lsb(const mp_int *a) +} diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index 0b2df47..dd9edaf 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -15,7 +15,6 @@ #ifndef BN_H_ #define BN_H_ -#include "tclInt.h" #include "tclTomMathDecls.h" #ifndef MODULE_SCOPE #define MODULE_SCOPE extern @@ -831,10 +830,3 @@ MODULE_SCOPE const char *mp_s_rmap; #endif #endif - - -/* $Source: /root/tcl/repos-to-convert/tcl/generic/tclTomMath.h,v $ */ -/* Based on Tom's version 1.8 */ -/* $Revision: 1.14 $ */ -/* $Date: 2010/05/03 14:36:41 $ */ - diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 61e9c07..ef22153 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTomMathDecls.h,v 1.13 2010/08/19 04:26:04 nijtmans Exp $ */ #ifndef _TCLTOMMATHDECLS @@ -65,6 +63,7 @@ #define mp_cmp TclBN_mp_cmp #define mp_cmp_d TclBN_mp_cmp_d #define mp_cmp_mag TclBN_mp_cmp_mag +#define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div @@ -79,6 +78,7 @@ #define mp_init_copy TclBN_mp_init_copy #define mp_init_multi TclBN_mp_init_multi #define mp_init_set TclBN_mp_init_set +#define mp_init_set_int TclBN_mp_init_set_int #define mp_init_size TclBN_mp_init_size #define mp_karatsuba_mul TclBN_mp_karatsuba_mul #define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr @@ -96,6 +96,7 @@ #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_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt @@ -268,10 +269,16 @@ EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); /* 60 */ EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +/* 61 */ +EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); +/* 62 */ +EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); +/* 63 */ +EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); typedef struct TclTomMathStubs { int magic; - const struct TclTomMathStubHooks *hooks; + void *hooks; int (*tclBN_epoch) (void); /* 0 */ int (*tclBN_revision) (void); /* 1 */ @@ -334,6 +341,9 @@ typedef struct TclTomMathStubs { 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_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 */ } TclTomMathStubs; #ifdef __cplusplus @@ -472,6 +482,12 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ #define TclBN_s_mp_sub \ (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ +#define TclBN_mp_init_set_int \ + (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ +#define TclBN_mp_set_int \ + (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ +#define TclBN_mp_cnt_lsb \ + (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclTomMathInt.h b/generic/tclTomMathInt.h index 1b9eb64..831f13f 100644 --- a/generic/tclTomMathInt.h +++ b/generic/tclTomMathInt.h @@ -1,2 +1,3 @@ +#include "tclInt.h" #include "tclTomMath.h" #include "tommath_class.h" diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 694b607..775e86b 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTomMathInterface.c,v 1.16 2010/08/31 20:48:17 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 1f21bee..a3bc4b3 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTomMathStubLib.c,v 1.3 2010/08/31 20:48:17 nijtmans Exp $ */ /* @@ -75,10 +73,10 @@ TclTomMathInitializeStubs( tclTomMathStubsPtr = stubsPtr; return actualVersion; } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s (requested version %s, actual version %s): %s", + packageName, version, actualVersion, errMsg)); return NULL; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2e8759e..519f201 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -10,8 +10,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTrace.c,v 1.60 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" @@ -24,11 +22,11 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NUL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual + char command[1]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 4 - * bytes. */ + * structure, so that it can be larger than 1 + * byte. */ } TraceVarInfo; typedef struct { @@ -58,11 +56,11 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[4]; /* Space for Tcl command to invoke. Actual + char command[1]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 4 - * bytes. */ + * structure, so that it can be larger than 1 + * byte. */ } TraceCommandInfo; /* @@ -115,7 +113,7 @@ static const char *const traceTypeOptions[] = { static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { TraceExecutionObjCmd, TraceCommandObjCmd, - TraceVariableObjCmd, + TraceVariableObjCmd }; /* @@ -368,8 +366,10 @@ Tcl_TraceObjCmd( return TCL_OK; badVarOps: - Tcl_AppendResult(interp, "bad operations \"", flagOps, - "\": should be one or more of rwua", NULL); + 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; } @@ -435,9 +435,11 @@ TraceExecutionObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " enter, leave, enterstep, or leavestep", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } for (i = 0; i < listLen; i++) { @@ -463,9 +465,8 @@ TraceExecutionObjCmd( command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) - ckalloc((unsigned) (sizeof(TraceCommandInfo) - - sizeof(tcmdPtr->command) + length + 1)); + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; @@ -482,7 +483,7 @@ TraceExecutionObjCmd( name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -533,7 +534,7 @@ TraceExecutionObjCmd( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *) tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -544,7 +545,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -677,8 +678,11 @@ TraceCommandObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of delete or rename", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " delete or rename", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } @@ -700,9 +704,8 @@ TraceCommandObjCmd( command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) - ckalloc((unsigned) (sizeof(TraceCommandInfo) - - sizeof(tcmdPtr->command) + length + 1)); + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; @@ -715,7 +718,7 @@ TraceCommandObjCmd( name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -746,7 +749,7 @@ TraceCommandObjCmd( TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -874,8 +877,11 @@ TraceVariableObjCmd( return result; } if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad operation list \"\": must be one or more of" + " array, read, unset, or write", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { @@ -901,9 +907,9 @@ TraceVariableObjCmd( command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *) - ckalloc((unsigned) (sizeof(CombinedTraceVarInfo) - + length + 1 - sizeof(ctvarPtr->traceCmdInfo.command))); + CombinedTraceVarInfo *ctvarPtr = ckalloc( + TclOffset(CombinedTraceVarInfo, traceCmdInfo.command) + + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; if (objv[0] == NULL) { @@ -918,7 +924,7 @@ TraceVariableObjCmd( name = Tcl_GetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { - ckfree((char *) ctvarPtr); + ckfree(ctvarPtr); return TCL_ERROR; } } else { @@ -1112,7 +1118,7 @@ Tcl_TraceCommand( * Set up trace information. */ - tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); + tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & @@ -1121,8 +1127,18 @@ Tcl_TraceCommand( tracePtr->refCount = 1; cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + /* + * Bug 3484621: up the interp's epoch if this is a BC'ed command + */ + + if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){ + Interp *iPtr = (Interp *) interp; + iPtr->compileEpoch++; + } cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } + + return TCL_OK; } @@ -1208,7 +1224,7 @@ Tcl_UntraceCommand( tracePtr->flags = 0; if ((--tracePtr->refCount) <= 0) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } if (hasExecTraces) { @@ -1225,6 +1241,15 @@ Tcl_UntraceCommand( */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; + + /* + * Bug 3484621: up the interp's epoch if this is a BC'ed command + */ + + if (cmdPtr->compileProc != NULL) { + Interp *iPtr = (Interp *) interp; + iPtr->compileEpoch++; + } } } @@ -1276,9 +1301,9 @@ TraceCommandProc( Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { - Tcl_DStringAppend(&cmd, " rename", 7); + TclDStringAppendLiteral(&cmd, " rename"); } else if (flags & TCL_TRACE_DELETE) { - Tcl_DStringAppend(&cmd, " delete", 7); + TclDStringAppendLiteral(&cmd, " delete"); } /* @@ -1315,7 +1340,7 @@ TraceCommandProc( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *) tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -1358,7 +1383,7 @@ TraceCommandProc( tcmdPtr->refCount--; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } } @@ -1450,7 +1475,7 @@ TclCheckExecutionTraces( traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } } } @@ -1693,7 +1718,7 @@ CommandObjTraceDeleted( TraceCommandInfo *tcmdPtr = clientData; if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } } @@ -1776,7 +1801,7 @@ TraceExecutionProc( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *) tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } @@ -1908,7 +1933,7 @@ TraceExecutionProc( } if (call) { if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } } return traceCode; @@ -1972,24 +1997,24 @@ TraceVarProc( #ifndef TCL_REMOVE_OBSOLETE_TRACES if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { if (flags & TCL_TRACE_ARRAY) { - Tcl_DStringAppend(&cmd, " a", 2); + TclDStringAppendLiteral(&cmd, " a"); } else if (flags & TCL_TRACE_READS) { - Tcl_DStringAppend(&cmd, " r", 2); + TclDStringAppendLiteral(&cmd, " r"); } else if (flags & TCL_TRACE_WRITES) { - Tcl_DStringAppend(&cmd, " w", 2); + TclDStringAppendLiteral(&cmd, " w"); } else if (flags & TCL_TRACE_UNSETS) { - Tcl_DStringAppend(&cmd, " u", 2); + TclDStringAppendLiteral(&cmd, " u"); } } else { #endif if (flags & TCL_TRACE_ARRAY) { - Tcl_DStringAppend(&cmd, " array", 6); + TclDStringAppendLiteral(&cmd, " array"); } else if (flags & TCL_TRACE_READS) { - Tcl_DStringAppend(&cmd, " read", 5); + TclDStringAppendLiteral(&cmd, " read"); } else if (flags & TCL_TRACE_WRITES) { - Tcl_DStringAppend(&cmd, " write", 6); + TclDStringAppendLiteral(&cmd, " write"); } else if (flags & TCL_TRACE_UNSETS) { - Tcl_DStringAppend(&cmd, " unset", 6); + TclDStringAppendLiteral(&cmd, " unset"); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } @@ -2025,6 +2050,7 @@ TraceVarProc( } if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } @@ -2134,7 +2160,7 @@ Tcl_CreateObjTrace( iPtr->tracesForbiddingInline++; } - tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr = ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; @@ -2197,8 +2223,7 @@ Tcl_CreateTrace( * command. */ ClientData clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData *data = (StringTraceData *) - ckalloc(sizeof(StringTraceData)); + StringTraceData *data = ckalloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; @@ -2555,7 +2580,7 @@ TclCallVarTraces( char *newPart1; Tcl_DStringInit(&nameCopy); - Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + Tcl_DStringAppend(&nameCopy, part1, p-part1); newPart1 = Tcl_DStringValue(&nameCopy); newPart1[offset] = 0; part1 = newPart1; @@ -2693,7 +2718,8 @@ TclCallVarTraces( if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); } else { - Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *)iPtr, + Tcl_NewStringObj(result, -1)); } Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); @@ -2880,6 +2906,16 @@ Tcl_UntraceVar2( * The code below makes it possible to delete traces while traces are * active: it makes sure that the deleted trace won't be processed by * TclCallVarTraces. + * + * Caveat (Bug 3062331): When an unset trace handler on a variable + * tries to delete a different unset trace handler on the same variable, + * the results may be surprising. When variable unset traces fire, the + * traced variable is already gone. So the TclLookupVar() call above + * will not find that variable, and not finding it will never reach here + * to perform the deletion. This means callers of Tcl_UntraceVar*() + * attempting to delete unset traces from within the handler of another + * unset trace have to account for the possibility that their call to + * Tcl_UntraceVar*() is a no-op. */ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; @@ -3108,7 +3144,7 @@ Tcl_TraceVar2( register VarTrace *tracePtr; int result; - tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr = ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; @@ -3116,7 +3152,7 @@ Tcl_TraceVar2( result = TraceVarEx(interp, part1, part2, tracePtr); if (result != TCL_OK) { - ckfree((char *) tracePtr); + ckfree(tracePtr); } return result; } diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 97b809a..5c88639 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -7,8 +7,6 @@ * * Copyright (c) 1998 by Scriptics Corporation. * All rights reserved. - * - * RCS: @(#) $Id: tclUniData.c,v 1.5 2010/05/27 08:38:07 nijtmans Exp $ */ /* @@ -25,361 +23,521 @@ * to the same alternate page number. */ -static unsigned char pageMap[] = { - 0, 1, 2, 3, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 7, 15, 16, 17, - 18, 19, 20, 21, 22, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 7, 32, - 7, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 47, - 48, 49, 50, 51, 52, 35, 47, 53, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, - 58, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 80, 81, - 84, 85, 80, 86, 87, 88, 89, 90, 91, 92, 35, 93, 94, 95, 35, 96, 97, - 98, 99, 100, 101, 102, 35, 47, 103, 104, 35, 35, 105, 106, 107, 47, - 47, 108, 47, 47, 109, 47, 110, 111, 47, 112, 47, 113, 114, 115, 116, - 114, 47, 117, 118, 35, 47, 47, 119, 90, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 120, 121, 47, 47, 122, - 35, 35, 35, 35, 47, 123, 124, 125, 126, 47, 127, 128, 47, 129, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 7, 7, 7, 7, 130, 7, 7, 131, 132, 133, 134, - 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, - 149, 150, 151, 152, 153, 154, 155, 156, 156, 156, 156, 156, 156, 156, - 157, 158, 159, 160, 161, 162, 35, 35, 35, 160, 163, 164, 165, 166, - 167, 168, 169, 160, 160, 160, 160, 170, 171, 172, 173, 174, 160, 160, - 175, 35, 35, 35, 35, 176, 177, 178, 179, 180, 181, 35, 35, 160, 160, - 160, 160, 160, 160, 160, 160, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 182, 160, 160, 155, 160, 160, 160, 160, 160, 160, 170, 183, 184, 185, - 90, 47, 186, 90, 47, 187, 188, 189, 47, 47, 190, 128, 35, 35, 191, - 192, 193, 194, 192, 195, 196, 197, 160, 160, 160, 198, 160, 160, 199, - 197, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 200, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 201, 35, 35, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 202, 203, 204, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 205, 35, 35, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, - 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, - 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, - 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, - 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 47, 47, 47, 47, 47, 47, 47, 47, 47, 208, 35, 35, 35, 35, - 35, 35, 209, 210, 211, 47, 47, 212, 213, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 214, 215, 47, 216, 47, 217, 218, 35, 219, 220, 221, 47, - 47, 47, 222, 223, 2, 224, 225, 226, 227, 228, 229, 230, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 231, 35, 232, 233, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 208, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 47, 234, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 235, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 207, 207, 207, 236, 207, 207, 207, 207, 207, 207, 207, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, - 35, 35, 35, 35, 35 +static const unsigned short pageMap[] = { + 0, 32, 64, 96, 0, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, + 448, 224, 480, 512, 544, 576, 608, 640, 672, 704, 704, 736, 768, 800, + 832, 864, 896, 928, 960, 992, 224, 1024, 224, 1056, 224, 224, 1088, + 1120, 1152, 1184, 1216, 1248, 1280, 1312, 1344, 1376, 1408, 1344, 1344, + 1440, 1472, 1504, 1536, 1568, 1344, 1344, 1600, 1632, 1664, 1696, 1728, + 1760, 1792, 1792, 1824, 1792, 1856, 1888, 1920, 1952, 1984, 2016, 2048, + 2080, 2112, 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2016, 2400, + 2432, 2464, 2496, 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784, + 2816, 2848, 2752, 2880, 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, + 3168, 1792, 3200, 3232, 3264, 1792, 3296, 3328, 3360, 3392, 3424, 3456, + 3488, 1792, 1344, 3520, 3552, 3584, 3616, 3648, 3680, 3712, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3744, 1344, 3776, 3808, + 3840, 1344, 3872, 1344, 3904, 3936, 3968, 1344, 1344, 4000, 4032, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 4064, 4096, 1344, 1344, 4128, 4160, 4192, + 4224, 4256, 1344, 4288, 4320, 4352, 4384, 1344, 4416, 4448, 1344, 4480, + 1344, 4512, 4544, 4576, 4608, 4640, 1344, 4672, 4704, 4736, 4768, 1344, + 4800, 4832, 4864, 4896, 1792, 1792, 4928, 4960, 4992, 5024, 5056, 5088, + 1344, 5120, 1344, 5152, 5184, 5216, 1792, 1792, 5248, 5280, 5312, 5344, + 5376, 5408, 5440, 5376, 704, 5472, 224, 224, 224, 224, 5504, 224, 224, + 224, 5536, 5568, 5600, 5632, 5664, 5696, 5728, 5760, 5792, 5824, 5856, + 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144, 6176, 6208, 6240, + 6272, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6336, 6368, 4736, + 6400, 6432, 6464, 6496, 6528, 4736, 6560, 6592, 6624, 6656, 6688, 6720, + 6752, 4736, 4736, 4736, 4736, 4736, 6784, 6816, 6848, 4736, 4736, 4736, + 6880, 4736, 4736, 4736, 4736, 6912, 4736, 4736, 6944, 6976, 4736, 7008, + 7040, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 6304, 6304, 6304, + 6304, 7072, 6304, 7104, 7136, 6304, 6304, 6304, 6304, 6304, 6304, 6304, + 6304, 4736, 7168, 7200, 1792, 1792, 1792, 1792, 1792, 7232, 7264, 7296, + 7328, 224, 224, 224, 7360, 7392, 7424, 1344, 7456, 7488, 7520, 7520, + 704, 7552, 7584, 1792, 1792, 7616, 4736, 4736, 7648, 4736, 4736, 4736, + 4736, 4736, 4736, 7680, 7712, 7744, 7776, 3104, 1344, 7808, 4032, 1344, + 7840, 7872, 7904, 1344, 1344, 7936, 7968, 4736, 8000, 8032, 8064, 8096, + 4736, 8064, 8128, 4736, 8032, 4736, 4736, 4736, 4736, 4736, 4736, 4736, + 4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 4512, 4736, 4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8160, + 1792, 8192, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8224, 4736, 8256, 5216, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8288, 8320, 224, 8352, 8384, 1344, 1344, 8416, 8448, 8480, 224, + 8512, 8544, 8576, 1792, 8608, 8640, 8672, 1344, 8704, 8736, 8768, 8800, + 8832, 1632, 8864, 8896, 4544, 1888, 8928, 8960, 1792, 1344, 8992, 9024, + 9056, 1344, 9088, 9120, 9152, 9184, 9216, 1792, 1792, 1792, 1792, 1344, + 9248, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 9280, 9312, 9344, 9376, 9376, 9376, 9376, 9376, 9376, 9376, + 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, + 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, + 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, + 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, + 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, + 9408, 9408, 9408, 9408, 9408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9440, 1344, 1344, 9472, 1792, 9504, 9536, 9568, + 1344, 1344, 9600, 9632, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 9664, 9696, 1344, 9728, 1344, 9760, 9792, 9824, 9856, 9888, + 9920, 1344, 1344, 1344, 9952, 9984, 64, 10016, 10048, 10080, 10112, + 10144, 10176 +#if TCL_UTF_MAX > 3 + ,10208, 10240, 10272, 1792, 1344, 1344, 1344, 7968, 10304, 10336, 10368, + 10400, 10432, 1792, 10464, 10496, 1792, 1792, 1792, 1792, 4544, 1344, + 10528, 1792, 10112, 10560, 10592, 1792, 10624, 1344, 10656, 1792, 10688, + 10720, 10752, 1344, 10784, 10816, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 10848, 10880, 10912, + 1792, 1792, 1792, 1792, 1792, 10944, 10976, 1792, 1792, 1344, 11008, + 1792, 1792, 11040, 11072, 11104, 11136, 1792, 1792, 1792, 1792, 1344, + 11168, 11200, 11232, 1792, 1792, 1792, 1792, 1344, 1344, 11264, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 11296, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 11328, 11360, 11392, 11424, 5056, 11456, + 11488, 11520, 11552, 11584, 11616, 1792, 5056, 11648, 11680, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1344, 11712, 10816, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11744, 1792, 1792, + 1792, 1792, 10368, 10368, 10368, 11776, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 11744, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 11808, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1344, 1344, 11840, 11872, 11904, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 11936, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 7680, 4736, + 11968, 4736, 12000, 12032, 12064, 12096, 1792, 4736, 4736, 12128, 1792, + 1792, 1792, 1792, 1792, 4736, 4736, 12160, 12192, 1792, 1792, 1792, + 1792, 12224, 12256, 12288, 12320, 12352, 12384, 12416, 12448, 12480, + 12512, 12544, 12576, 12608, 12224, 12256, 12640, 12320, 12672, 12704, + 12736, 12448, 12768, 12800, 12832, 12864, 12896, 12928, 12960, 12992, + 13024, 13056, 13088, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 13120, 13152, 13184, 13216, 13248, 13280, 1792, 13312, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 4736, 13344, 4736, 4736, 7648, + 13376, 13408, 1792, 13440, 13472, 4736, 13344, 13504, 1792, 1792, 13536, + 13568, 13504, 13600, 1792, 1792, 1792, 1792, 1792, 4736, 13632, 4736, + 13664, 7648, 4736, 13696, 13728, 4736, 8032, 13760, 4736, 4736, 4736, + 4736, 13792, 4736, 12096, 13824, 13856, 1792, 1792, 1792, 13888, 4736, + 4736, 13920, 1792, 4736, 4736, 13952, 1792, 4736, 4736, 4736, 7648, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 7488, 1792, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4000, 1344, 1344, + 1344, 1344, 1344, 1344, 10784, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 10784 +#endif /* TCL_UTF_MAX > 3 */ }; /* @@ -388,421 +546,795 @@ static unsigned char pageMap[] = { * set of character attributes. */ -static unsigned char groupMap[] = { +static const unsigned char groupMap[] = { 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, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 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, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 5, 7, 6, 7, 1, 2, 3, 4, 4, 4, 4, 14, 14, 11, 14, 15, 16, - 7, 8, 14, 11, 14, 7, 17, 17, 11, 18, 14, 3, 11, 17, 15, 19, 17, 17, - 17, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, 10, 10, 10, 10, 10, 15, + 13, 13, 13, 5, 7, 6, 7, 1, 2, 3, 4, 4, 4, 4, 14, 3, 11, 14, 15, 16, + 7, 17, 14, 11, 14, 7, 18, 18, 11, 19, 3, 3, 11, 18, 15, 20, 18, 18, + 18, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, 10, 10, 10, 10, 10, 21, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 20, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 23, 24, 21, 22, 21, - 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, - 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 25, - 21, 22, 21, 22, 21, 22, 26, 15, 27, 21, 22, 21, 22, 28, 21, 22, 29, - 29, 21, 22, 15, 30, 31, 32, 21, 22, 29, 33, 34, 35, 36, 21, 22, 15, - 15, 35, 37, 15, 38, 21, 22, 21, 22, 21, 22, 39, 21, 22, 39, 15, 15, - 21, 22, 39, 21, 22, 40, 40, 21, 22, 21, 22, 41, 21, 22, 15, 42, 21, - 22, 15, 43, 42, 42, 42, 42, 44, 45, 46, 44, 45, 46, 44, 45, 46, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 47, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 15, 44, 45, 46, 21, 22, 48, 49, 21, 22, 21, 22, 21, 22, 21, 22, 0, - 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 50, 51, 15, 52, 52, 15, 53, 15, - 54, 15, 15, 15, 15, 52, 15, 15, 55, 15, 15, 15, 15, 56, 57, 15, 15, - 15, 15, 15, 57, 15, 15, 58, 15, 15, 59, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 60, 15, 15, 60, 15, 15, 15, 15, 60, 15, 61, 61, 15, 15, - 15, 15, 15, 15, 62, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 63, - 63, 63, 63, 63, 63, 63, 63, 63, 11, 11, 63, 63, 63, 63, 63, 63, 63, - 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 11, - 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 63, 63, - 63, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 65, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, - 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, - 0, 0, 0, 0, 63, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 66, 3, 67, 67, 67, - 0, 68, 0, 69, 69, 15, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 70, 71, - 71, 71, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 72, 13, 13, 13, 13, 13, 13, 13, 13, 13, 73, 74, 74, 0, - 75, 76, 77, 77, 77, 78, 79, 15, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 80, 81, 47, - 15, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, 84, 84, 84, 84, 84, 84, - 84, 84, 84, 84, 84, 84, 84, 84, 84, 10, 10, 10, 10, 10, 10, 10, 10, + 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 22, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 25, 26, 23, 24, 23, + 24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 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, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 27, + 23, 24, 23, 24, 23, 24, 28, 29, 30, 23, 24, 23, 24, 31, 23, 24, 32, + 32, 23, 24, 21, 33, 34, 35, 23, 24, 32, 36, 37, 38, 39, 23, 24, 40, + 21, 38, 41, 42, 43, 23, 24, 23, 24, 23, 24, 44, 23, 24, 44, 21, 21, + 23, 24, 44, 23, 24, 45, 45, 23, 24, 23, 24, 46, 23, 24, 21, 15, 23, + 24, 21, 47, 15, 15, 15, 15, 48, 49, 50, 48, 49, 50, 48, 49, 50, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 51, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 21, 48, 49, 50, 23, 24, 52, 53, 23, 24, 23, 24, 23, 24, 23, 24, 54, + 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 21, 21, 21, 21, 21, 21, 55, 23, 24, 56, 57, 58, 58, 23, 24, + 59, 60, 61, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 62, 63, 64, 65, + 66, 21, 67, 67, 21, 68, 21, 69, 21, 21, 21, 21, 67, 21, 21, 70, 21, + 71, 72, 21, 73, 74, 21, 75, 21, 21, 21, 74, 21, 76, 77, 21, 21, 78, + 21, 21, 21, 21, 21, 21, 21, 79, 21, 21, 80, 21, 21, 80, 21, 21, 21, + 21, 80, 81, 82, 82, 83, 21, 21, 21, 21, 21, 84, 21, 15, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 85, + 11, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 87, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 23, 24, 23, + 24, 85, 11, 23, 24, 0, 0, 85, 42, 42, 42, 3, 0, 0, 0, 0, 0, 11, 11, + 88, 3, 89, 89, 89, 0, 90, 0, 91, 91, 21, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 92, 93, 93, 93, 21, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 94, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 95, 96, 96, 97, 98, 99, 100, 100, 100, 101, 102, 103, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 104, 105, 106, 21, 107, 108, 7, 23, 24, 109, 23, 24, + 21, 54, 54, 54, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, + 110, 110, 110, 110, 110, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 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, + 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, 13, 13, 13, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, - 81, 81, 81, 81, 21, 22, 14, 64, 64, 64, 64, 0, 85, 85, 0, 0, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, - 22, 77, 21, 22, 21, 22, 0, 0, 21, 22, 0, 0, 21, 22, 0, 0, 0, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 0, 0, 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, + 13, 13, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 23, 24, 14, 86, 86, 86, 86, 86, 111, 111, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 112, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 113, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 0, 85, 3, 3, 3, 3, + 3, 3, 0, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 21, 0, + 3, 8, 0, 0, 0, 0, 4, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 8, 86, 3, 86, 86, 3, 86, 86, 3, 86, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3, + 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0, + 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 86, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 15, 86, 86, 86, + 86, 86, 86, 86, 17, 14, 86, 86, 86, 86, 86, 86, 85, 85, 86, 86, 14, + 86, 86, 86, 86, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 14, + 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 17, 15, 86, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 0, 0, 63, 3, 3, 3, 3, 3, 3, 0, 87, 87, 87, 87, 87, 87, 87, 87, 87, - 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, - 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 15, 0, 3, 8, 0, 0, - 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64, 64, 3, 64, 3, 64, - 64, 3, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 3, 3, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 0, 0, 0, 0, 0, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 64, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 42, 64, - 64, 64, 64, 64, 64, 64, 85, 85, 64, 64, 64, 64, 64, 64, 63, 63, 64, - 64, 14, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42, - 42, 14, 14, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 88, 42, - 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, - 64, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64, - 64, 64, 89, 89, 89, 89, 64, 0, 0, 42, 64, 64, 64, 64, 0, 0, 0, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 64, 3, 3, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, - 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 0, 0, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0, 0, 42, - 42, 42, 42, 0, 0, 64, 0, 89, 89, 89, 64, 64, 64, 64, 0, 0, 89, 89, - 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 42, 42, - 0, 42, 42, 42, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42, - 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 0, 0, 0, 0, 64, 0, 0, 42, - 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, - 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 0, 0, - 64, 0, 89, 89, 89, 64, 64, 0, 0, 0, 0, 64, 64, 0, 0, 64, 64, 64, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 0, 0, 0, 0, 0, - 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 64, 64, 42, 42, 42, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 89, 0, 42, 42, 42, 42, 42, 42, 42, - 0, 42, 0, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, - 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89, - 64, 64, 64, 64, 64, 0, 64, 64, 89, 0, 89, 89, 64, 0, 0, 42, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 0, 0, 0, 0, 0, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, - 42, 0, 0, 42, 42, 42, 42, 0, 0, 64, 42, 89, 64, 89, 64, 64, 64, 0, - 0, 0, 89, 89, 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89, 0, - 0, 0, 0, 42, 42, 0, 42, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89, - 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42, 0, 42, 42, 42, 42, - 0, 0, 0, 42, 42, 0, 42, 0, 42, 42, 0, 0, 0, 42, 42, 0, 0, 0, 42, 42, - 42, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 0, 0, - 0, 89, 89, 64, 89, 89, 0, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 89, 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, - 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 89, 89, - 89, 89, 0, 64, 64, 64, 0, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 64, - 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, - 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, - 42, 42, 0, 0, 0, 0, 89, 64, 89, 89, 89, 89, 89, 0, 64, 89, 89, 0, 89, - 89, 64, 64, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 0, 0, 0, 0, 0, 0, 42, 0, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 89, 89, 89, 64, 64, - 64, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0, - 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 0, 0, 0, 0, 89, 89, 89, 64, - 64, 64, 0, 64, 0, 89, 89, 89, 89, 89, 89, 89, 89, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 3, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 4, 42, 42, - 42, 42, 42, 42, 63, 64, 64, 64, 64, 64, 64, 64, 64, 3, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 42, 42, 0, 42, 0, 0, 42, 42, - 0, 42, 0, 0, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 42, 42, 42, - 42, 42, 42, 0, 42, 42, 42, 0, 42, 0, 42, 0, 0, 42, 42, 0, 42, 42, 42, - 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 0, 64, 64, 42, 0, 0, 42, 42, - 42, 42, 42, 0, 63, 0, 64, 64, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 0, 0, 42, 42, 0, 0, 42, 14, 14, 14, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 64, 64, 14, 14, 14, - 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 14, 64, 14, 64, 14, 64, 5, 6, 5, 6, 89, 89, 42, 42, 42, - 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 89, 64, 64, 64, 64, 64, 3, 64, 64, 42, - 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 64, 14, 14, 14, 14, 14, 14, 0, 0, - 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 42, - 42, 42, 42, 42, 0, 42, 42, 0, 89, 64, 64, 64, 64, 89, 64, 0, 0, 0, - 64, 64, 89, 64, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, - 3, 3, 3, 3, 3, 42, 42, 42, 42, 42, 42, 89, 89, 64, 64, 0, 0, 0, 0, - 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, - 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, - 77, 77, 77, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 0, 0, 0, 0, 3, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, - 0, 0, 0, 0, 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42, - 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, - 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, - 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, - 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0, - 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, - 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 3, 42, 42, 42, 42, 42, - 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 5, 6, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 3, 3, 3, 90, 90, 90, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64, 64, 89, 89, 89, 89, 89, - 89, 89, 89, 64, 89, 89, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 3, 3, 3, 3, 3, 3, 3, 4, 3, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, - 3, 3, 3, 3, 8, 3, 3, 3, 3, 88, 88, 88, 88, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, - 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21, - 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 15, 15, - 15, 15, 15, 91, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, - 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 0, - 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, - 93, 93, 93, 92, 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0, - 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, - 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 92, - 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0, 0, 15, 92, 15, - 92, 15, 92, 15, 92, 0, 93, 0, 93, 0, 93, 0, 93, 92, 92, 92, 92, 92, - 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 94, 94, 95, 95, 95, 95, - 96, 96, 97, 97, 98, 98, 99, 99, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, - 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92, 92, - 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92, - 92, 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 15, 101, 15, - 0, 15, 15, 93, 93, 102, 102, 103, 11, 104, 11, 11, 11, 15, 101, 15, - 0, 15, 15, 105, 105, 105, 105, 103, 11, 11, 11, 92, 92, 15, 15, 0, - 0, 15, 15, 93, 93, 106, 106, 0, 11, 11, 11, 92, 92, 15, 15, 15, 107, - 15, 15, 93, 93, 108, 108, 109, 11, 11, 11, 0, 0, 15, 101, 15, 0, 15, - 15, 110, 110, 111, 111, 103, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 88, 88, 88, 88, 8, 8, 8, 8, 8, 8, 3, 3, 16, 19, 5, 16, 16, - 19, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 112, 113, 88, 88, 88, 88, 88, 2, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 19, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, - 5, 6, 0, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, 88, 88, 17, - 0, 0, 0, 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 86, 86, 86, 86, 86, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 85, 85, 14, 3, 3, 3, 85, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, + 86, 86, 86, 85, 86, 86, 86, 86, 86, 86, 86, 86, 86, 85, 86, 86, 86, + 85, 86, 86, 86, 86, 86, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - 64, 64, 64, 85, 85, 85, 85, 64, 85, 85, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 77, - 14, 14, 14, 14, 77, 14, 14, 15, 77, 77, 77, 15, 15, 77, 77, 77, 15, - 14, 77, 14, 14, 14, 77, 77, 77, 77, 77, 14, 14, 14, 14, 14, 14, 77, - 14, 114, 14, 77, 14, 115, 116, 77, 77, 14, 15, 77, 77, 14, 77, 15, - 42, 42, 42, 42, 15, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, - 117, 117, 117, 117, 117, 118, 118, 118, 118, 118, 118, 118, 118, 118, - 118, 118, 118, 118, 118, 118, 118, 90, 90, 90, 90, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 86, 86, 86, 116, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 86, 116, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 86, + 86, 86, 116, 116, 116, 116, 86, 116, 116, 15, 86, 86, 86, 86, 86, 86, + 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 3, 3, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 3, 85, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, + 15, 15, 15, 15, 0, 86, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 86, 15, 116, 116, 116, 86, + 86, 86, 86, 0, 0, 116, 116, 0, 0, 116, 116, 86, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 116, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 86, 86, 0, 0, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, + 0, 0, 0, 0, 0, 86, 86, 116, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 0, 15, 15, 0, 15, 15, 0, 0, 86, 0, 116, 116, 116, 86, 86, 0, 0, + 0, 0, 86, 86, 0, 0, 86, 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 86, 86, 15, 15, 15, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, + 116, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, + 15, 15, 0, 0, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 0, 86, 86, + 116, 0, 116, 116, 86, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, + 15, 0, 0, 86, 15, 116, 86, 116, 86, 86, 86, 86, 0, 0, 116, 116, 0, + 0, 116, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0, 86, 116, 0, 0, 0, 0, 15, 15, + 0, 15, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 0, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, + 15, 15, 0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, + 116, 86, 116, 116, 0, 0, 0, 116, 116, 116, 0, 116, 116, 116, 86, 0, + 0, 15, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, + 4, 14, 0, 0, 0, 0, 0, 0, 116, 116, 116, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 0, 15, 86, 86, + 86, 116, 116, 116, 116, 0, 86, 86, 86, 0, 86, 86, 86, 86, 0, 0, 0, + 0, 0, 0, 0, 86, 86, 0, 15, 15, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, + 18, 18, 18, 18, 14, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 86, 15, 116, 86, 116, + 116, 116, 116, 116, 0, 86, 116, 116, 0, 116, 116, 86, 86, 0, 0, 0, + 0, 0, 0, 0, 116, 116, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 86, 86, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 116, + 116, 116, 86, 86, 86, 86, 0, 116, 116, 116, 0, 116, 116, 116, 86, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 14, 15, 15, 15, 15, 15, 15, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 0, 0, 0, 0, 116, 116, 116, + 86, 86, 86, 0, 86, 0, 116, 116, 116, 116, 116, 116, 116, 116, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 3, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, + 4, 15, 15, 15, 15, 15, 15, 85, 86, 86, 86, 86, 86, 86, 86, 86, 3, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 0, + 15, 15, 0, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 0, 15, 0, 0, 15, 15, 0, 15, + 15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 0, 86, 86, 15, 0, 0, + 15, 15, 15, 15, 15, 0, 85, 0, 86, 86, 86, 86, 86, 86, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, 14, 14, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, 14, 86, 86, 14, + 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 14, 86, 14, 86, 14, 86, 5, 6, 5, 6, 116, 116, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 3, + 86, 86, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 0, 14, 14, 14, 14, 14, 14, 14, 14, 86, 14, 14, 14, + 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, 3, 3, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 86, 86, + 86, 86, 116, 86, 86, 86, 86, 86, 86, 116, 86, 86, 116, 116, 86, 86, + 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, + 15, 15, 116, 116, 86, 86, 15, 15, 15, 15, 86, 86, 86, 15, 116, 116, + 116, 15, 15, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, 86, 86, + 86, 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, + 116, 86, 86, 116, 116, 116, 116, 116, 116, 86, 15, 116, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 116, 116, 116, 86, 14, 14, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 0, 117, 0, 0, 0, 0, 0, 117, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 3, 85, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 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, 118, 118, 118, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 3, 3, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, + 0, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, + 116, 86, 86, 86, 86, 86, 86, 86, 116, 116, 116, 116, 116, 116, 116, + 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, + 3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, + 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86, + 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116, + 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, + 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116, + 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86, + 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, + 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, + 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, + 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116, + 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116, + 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, + 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, + 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86, + 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21, + 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124, + 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124, + 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, + 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123, + 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, + 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123, + 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123, + 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126, + 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123, + 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123, + 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, + 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, + 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133, + 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136, + 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137, + 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138, + 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140, + 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, + 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, + 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, + 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18, + 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100, + 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100, + 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100, + 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21, + 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147, + 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, + 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, + 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, + 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 150, 150, 150, 150, 150, 150, 150, 150, + 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, + 150, 150, 150, 150, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, + 151, 151, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 119, 119, 119, 119, 119, 119, - 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, - 119, 119, 119, 119, 119, 119, 120, 120, 120, 120, 120, 120, 120, 120, - 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, - 120, 120, 120, 120, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 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, 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, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 7, 7, 7, 7, 7, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, + 5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, + 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 0, 0, 0, 114, 114, 114, 114, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 0, 23, 24, 152, 153, 154, 155, 156, 23, 24, 23, 24, + 23, 24, 157, 158, 159, 160, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, + 21, 85, 85, 161, 161, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, + 24, 23, 24, 86, 86, 86, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, + 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, + 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, + 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 0, 162, 0, 0, 0, + 0, 0, 162, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 85, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6, + 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 8, 8, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 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, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 2, 3, 3, 3, 14, 85, 15, 118, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, + 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 86, 86, 86, 86, 116, 116, 8, 85, 85, 85, 85, + 85, 14, 14, 118, 118, 118, 85, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 86, 86, 11, 11, 85, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 3, 85, 85, 85, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14, + 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 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, 0, 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, - 14, 14, 14, 14, 14, 0, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, 0, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 3, 3, 3, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 15, 86, 111, 111, 111, 3, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 3, 85, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15, + 15, 15, 15, 15, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 86, + 86, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 85, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24, + 23, 24, 163, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 85, 11, 11, 23, + 24, 164, 21, 0, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 165, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, 85, 21, 15, 15, 15, 15, + 15, 15, 15, 86, 15, 15, 15, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 116, 116, 86, 86, 116, 14, 14, 14, 14, 0, 0, 0, 0, 18, 18, + 18, 18, 18, 18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 116, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 86, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 86, 116, 116, 86, 86, 86, 86, 116, 116, 86, + 116, 116, 116, 116, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 85, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 86, 86, 86, 86, 86, 86, 116, 116, 86, 86, 116, 116, 86, + 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 86, 15, 15, 15, 15, 15, + 15, 15, 15, 86, 116, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, + 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 85, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 116, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 86, + 86, 86, 15, 15, 86, 86, 15, 15, 15, 15, 15, 86, 86, 15, 86, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 85, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, + 86, 86, 116, 116, 3, 3, 15, 85, 85, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 116, 116, 86, 116, 116, 86, 116, 116, + 3, 116, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, + 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, + 166, 166, 166, 166, 166, 166, 166, 166, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15, + 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15, + 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 5, + 6, 3, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, + 6, 5, 6, 3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, + 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, 3, 3, 3, 4, + 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, + 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 5, + 6, 3, 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 85, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, + 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, + 15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0 +#if TCL_UTF_MAX > 3 + ,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 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, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 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, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 18, + 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 2, 3, 3, 3, 14, 63, 42, 90, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, - 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 90, 90, 90, 90, 90, - 90, 90, 90, 90, 64, 64, 64, 64, 64, 64, 8, 63, 63, 63, 63, 63, 14, - 14, 90, 90, 90, 0, 0, 0, 14, 14, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, - 11, 11, 63, 63, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 12, 63, - 63, 63, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 14, 14, 17, 17, 17, - 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 118, 15, 15, 15, 15, 15, 15, 15, 15, 118, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 15, 15, 15, 15, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 118, 118, 118, 118, 118, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 168, 168, 168, 168, 168, 168, 168, 168, 168, + 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, + 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, + 168, 168, 168, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 15, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 86, 86, 86, 0, 86, 86, 0, 0, 0, 0, 0, 86, 86, 86, 86, 15, 15, + 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 0, 86, 86, 86, 0, 0, 0, 0, 86, 18, 18, 18, 18, 18, 18, 18, 18, + 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 3, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, + 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 116, 86, 116, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, + 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 86, + 86, 86, 86, 116, 116, 86, 86, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86, 86, + 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, 86, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 15, 15, + 15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, + 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 116, 86, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 118, 118, 118, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, + 86, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 116, 116, 86, 86, 86, 14, 14, 14, 116, + 116, 116, 116, 116, 116, 17, 17, 17, 17, 17, 17, 17, 17, 86, 86, 86, + 86, 86, 86, 86, 86, 14, 14, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, 86, 86, 86, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 86, 86, 86, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, + 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 0, + 100, 100, 0, 0, 100, 0, 0, 100, 100, 0, 0, 100, 100, 100, 100, 0, 100, + 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 0, 21, 0, 21, 21, + 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100, 100, 100, 0, 0, + 100, 100, 100, 100, 100, 100, 100, 100, 0, 100, 100, 100, 100, 100, + 100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100, + 100, 100, 0, 100, 100, 100, 100, 100, 0, 100, 0, 0, 0, 100, 100, 100, + 100, 100, 100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 0, 0, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, + 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, + 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 21, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 15, 15, 15, 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, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 0, 14, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, + 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 121, 121, 121, 121, 121, 121, 121, - 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, - 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 122, 122, 122, - 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 122, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 42, 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 7, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, - 42, 0, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, - 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 0, 0, 0, 0, 3, 3, 3, 3, 12, 12, 12, - 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, - 0, 3, 4, 3, 3, 0, 0, 0, 0, 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 0, 0, 88, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 12, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 63, - 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, - 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, - 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, - 42, 42, 42, 42, 0, 0, 42, 42, 42, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, - 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 14, - 14, 42, 17, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 123, 123, 123, - 126, 126, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 89, 64, 14, 14, 14, - 14, 14, 0, 0, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77, - 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77, - 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77, 77, 15, 15, 77, - 15, 15, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 15, 9, 9, 9, 42, 42, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 88, 0, 88, 88, 88, 88, 88, 88, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 122, 122, - 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, - 122 + 0 +#endif /* TCL_UTF_MAX > 3 */ }; /* @@ -818,40 +1350,43 @@ static unsigned char groupMap[] = { * 101 = sub delta for upper, sub 1 for title * 110 = sub delta for upper, add delta for lower * - * Bits 8-21 Reserved for future use. - * - * Bits 22-31 Case delta: delta for case conversions. This should be the + * Bits 8-31 Case delta: delta for case conversions. This should be the * highest field so we can easily sign extend. */ -static int groups[] = { - 0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 134217793, 28, 19, 134217858, - 29, 2, 23, 11, 1178599554, 24, -507510654, 4194369, 4194434, -834666431, - 973078658, -507510719, 1258291330, 880803905, 864026689, 859832385, - 331350081, 847249473, 851443777, 868220993, -406847358, 884998209, - 876609601, 893386817, 897581121, 914358337, 910164033, 918552641, - 5, -234880894, 8388705, 4194499, 8388770, 331350146, -406847423, - -234880959, 880803970, 864026754, 859832450, 847249538, 851443842, - 868221058, 876609666, 884998274, 893386882, 897581186, 914358402, - 910164098, 918552706, 4, 6, -352321402, 159383617, 155189313, - 268435521, 264241217, 159383682, 155189378, 130023554, 268435586, - 264241282, 260046978, 239075458, 1, 197132418, 226492546, 360710274, - 335544450, -251658175, 402653314, 335544385, 7, 201326657, 201326722, - 16, 8, 10, 247464066, -33554302, -33554367, -310378366, -360710014, - -419430270, -536870782, -469761918, -528482174, -33554365, -37748606, - -310378431, -37748669, 155189378, -360710079, -419430335, -29359998, - -469761983, -29360063, -536870847, -528482239, 13, 14, -1463812031, - -801111999, -293601215, 67108938, 67109002, 109051997, 109052061, - 18, 17, 8388673, 12582977, 8388738, 12583042 +static const int groups[] = { + 0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 8257, 28, 19, 8322, 29, + 5, 23, 16, 11, -190078, 24, 2, -30846, 321, 386, -50879, 59522, + -30911, 76930, -49790, 53825, 52801, 52545, 20289, 51777, 52033, + 53057, -24702, 54081, 53569, -41598, 54593, -33150, 54849, 55873, + 55617, 56129, -14206, 609, 451, 674, 20354, -24767, -14271, -33215, + 2763585, -41663, 2762817, -2768510, -49855, 17729, 18241, -2760318, + -2759550, -2760062, 53890, 52866, 52610, 51842, 52098, 53122, + -10823550, -10830718, 53634, 54146, -2750078, -2751614, 54658, + 54914, -2745982, 55938, 17794, 55682, 18306, 56194, 4, 6, -21370, + 9793, 9537, 16449, 16193, 9858, 9602, 8066, 16514, 16258, 2113, + 16002, 14722, 1, 12162, 13954, 2178, 22146, 20610, -1662, -15295, + 24706, -1727, 20545, 7, 3905, 3970, 12353, 12418, 8, 1859649, + 10, -9044862, -976254, 15234, -1949375, -1918, -1983, -18814, + -21886, -25470, -32638, -28542, -32126, -1981, -2174, -18879, + -2237, 1844610, -21951, -25535, -28607, -32703, -32191, 13, 14, + -1924287, -2145983, -2115007, 7233, 7298, 4170, 4234, 6749, 6813, + -2750143, -976319, -2746047, 2763650, 2762882, -2759615, -2751679, + -2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -10830783, + 18, 17, 10305, 10370 }; +#if TCL_UTF_MAX > 3 +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= 0x2fa20) +#else +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0) +#endif + /* * The following constants are used to determine the category of a * Unicode character. */ -#define UNICODE_CATEGORY_MASK 0X1F - enum { UNASSIGNED, UPPERCASE_LETTER, @@ -891,14 +1426,13 @@ enum { * to do sign extension on right shifts. */ -#define GetCaseType(info) (((info) & 0xE0) >> 5) -#define GetCategory(info) ((info) & 0x1F) -#define GetDelta(info) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22))) +#define GetCaseType(info) (((info) & 0xe0) >> 5) +#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f) +#define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ -#define GetUniCharInfo(ch) (groups[groupMap[(pageMap[(((int)(ch)) & 0xffff) >> OFFSET_BITS] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))]]) - +#define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 31e52ba..4b5b37b 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -7,8 +7,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUtf.c,v 1.40 2009/09/07 07:28:38 das Exp $ */ #include "tclInt.h" @@ -28,28 +26,27 @@ #define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \ | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1<<OTHER_LETTER)) +#define CONTROL_BITS ((1 << CONTROL) | (1 << FORMAT) | (1 << PRIVATE_USE)) + #define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER) #define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \ | (1 << PARAGRAPH_SEPARATOR)) -#define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION) - -#define PRINT_BITS (ALPHA_BITS | DIGIT_BITS | SPACE_BITS | \ - (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \ - (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \ - (1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \ - (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ - (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ - (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \ - (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \ - (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)) +#define WORD_BITS (ALPHA_BITS | DIGIT_BITS | (1 << CONNECTOR_PUNCTUATION)) #define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \ (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION)) +#define GRAPH_BITS (WORD_BITS | PUNCT_BITS | \ + (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \ + (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \ + (1 << OTHER_NUMBER) | \ + (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \ + (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)) + /* * Unicode characters less than this value are represented by themselves in * UTF-8 strings. @@ -1129,10 +1126,9 @@ Tcl_UniCharToUpper( int info = GetUniCharInfo(ch); if (GetCaseType(info) & 0x04) { - return (Tcl_UniChar) (ch - GetDelta(info)); - } else { - return ch; + ch -= GetDelta(info); } + return (Tcl_UniChar) ch; } /* @@ -1158,10 +1154,9 @@ Tcl_UniCharToLower( int info = GetUniCharInfo(ch); if (GetCaseType(info) & 0x02) { - return (Tcl_UniChar) (ch + GetDelta(info)); - } else { - return ch; + ch += GetDelta(info); } + return (Tcl_UniChar) ch; } /* @@ -1192,12 +1187,11 @@ Tcl_UniCharToTitle( * Subtract or add one depending on the original case. */ - return (Tcl_UniChar) (ch + ((mode & 0x4) ? -1 : 1)); + ch += ((mode & 0x4) ? -1 : 1); } else if (mode == 0x4) { - return (Tcl_UniChar) (ch - GetDelta(info)); - } else { - return ch; + ch -= GetDelta(info); } + return (Tcl_UniChar) ch; } /* @@ -1331,9 +1325,7 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - - return (((ALPHA_BITS | DIGIT_BITS) >> category) & 1); + return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } /* @@ -1356,8 +1348,7 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((ALPHA_BITS >> category) & 1); + return ((ALPHA_BITS >> GetCategory(ch)) & 1); } /* @@ -1380,7 +1371,7 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == CONTROL); + return ((CONTROL_BITS >> GetCategory(ch)) & 1); } /* @@ -1403,7 +1394,7 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { - return (GetUniCharInfo(ch)&UNICODE_CATEGORY_MASK) == DECIMAL_DIGIT_NUMBER; + return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } /* @@ -1426,8 +1417,7 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return (((PRINT_BITS >> category) & 1) && ((unsigned char) ch != ' ')); + return ((GRAPH_BITS >> GetCategory(ch)) & 1); } /* @@ -1450,7 +1440,7 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == LOWERCASE_LETTER); + return (GetCategory(ch) == LOWERCASE_LETTER); } /* @@ -1473,8 +1463,7 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((PRINT_BITS >> category) & 1); + return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } /* @@ -1497,8 +1486,7 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((PUNCT_BITS >> category) & 1); + return ((PUNCT_BITS >> GetCategory(ch)) & 1); } /* @@ -1521,18 +1509,18 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { - register int category; - /* * If the character is within the first 127 characters, just use the * standard C function, otherwise consult the Unicode table. */ - if (ch < 0x80) { + if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return isspace(UCHAR(ch)); /* INTL: ISO space */ + } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b + || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) { + return 1; } else { - category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - return ((SPACE_BITS >> category) & 1); + return ((SPACE_BITS >> GetCategory(ch)) & 1); } } @@ -1556,7 +1544,7 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { - return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == UPPERCASE_LETTER); + return (GetCategory(ch) == UPPERCASE_LETTER); } /* @@ -1579,9 +1567,7 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { - register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); - - return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1); + return ((WORD_BITS >> GetCategory(ch)) & 1); } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index fb4e20b..13e54ec 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -10,11 +10,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUtil.c,v 1.117 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" +#include "tclParse.h" #include <math.h> /* @@ -27,31 +26,71 @@ static ProcessGlobalValue executableName = { }; /* - * The following values are used in the flags returned by Tcl_ScanElement and - * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and - * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps - * with any of the values below. - * - * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in - * braces (e.g. it contains unmatched braces, or - * ends in a backslash character, or user just - * doesn't want braces); handle all special - * characters by adding backslashes. - * USE_BRACES - 1 means the string contains a special - * character that can be handled simply by - * enclosing the entire argument in braces. - * BRACES_UNMATCHED - 1 means that braces aren't properly matched in - * the argument. + * The following values are used in the flags arguments of Tcl*Scan*Element + * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so: + * +#define TCL_DONT_USE_BRACES 1 +#define TCL_DONT_QUOTE_HASH 8 + * + * Those are public flag bits which callers of the public routines + * Tcl_Convert*Element() can use to indicate: + * + * TCL_DONT_USE_BRACES - 1 means the caller is insisting that brace + * quoting not be used when converting the list + * element. * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash * character ('#') should *not* be quoted. This * is appropriate when the caller can guarantee * the element is not the first element of a * list, so [eval] cannot mis-parse the element * as a comment. + * + * The remaining values which can be carried by the flags of these routines + * are for internal use only. Make sure they do not overlap with the public + * values above. + * + * The Tcl*Scan*Element() routines make a determination which of 4 modes of + * conversion is most appropriate for Tcl*Convert*Element() to perform, and + * sets two bits of the flags value to indicate the mode selected. + * + * CONVERT_NONE The element needs no quoting. Its literal string is + * suitable as is. + * CONVERT_BRACE The conversion should be enclosing the literal string + * in braces. + * CONVERT_ESCAPE The conversion should be using backslashes to escape + * any characters in the string that require it. + * CONVERT_MASK A mask value used to extract the conversion mode from + * the flags argument. + * Also indicates a strange conversion mode where all + * special characters are escaped with backslashes + * *except for braces*. This is a strange and unnecessary + * case, but it's part of the historical way in which + * lists have been formatted in Tcl. To experiment with + * removing this case, set the value of COMPAT to 0. + * + * One last flag value is used only by callers of TclScanElement(). The flag + * value produced by a call to Tcl*Scan*Element() will never leave this bit + * set. + * + * CONVERT_ANY The caller of TclScanElement() declares it can make no + * promise about what public flags will be passed to the + * matching call of TclConvertElement(). As such, + * TclScanElement() has to determine the worst case + * destination buffer length over all possibilities, and + * in other cases this means an overestimate of the + * required size. + * + * For more details, see the comments on the Tcl*Scan*Element and + * Tcl*Convert*Element routines. */ -#define USE_BRACES 2 -#define BRACES_UNMATCHED 4 +#define COMPAT 1 +#define CONVERT_NONE 0 +#define CONVERT_BRACE 2 +#define CONVERT_ESCAPE 4 +#define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) +#define CONVERT_ANY 16 /* * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to @@ -88,6 +127,322 @@ const Tcl_ObjType tclEndOffsetType = { }; /* + * * STRING REPRESENTATION OF LISTS * * * + * + * The next several routines implement the conversions of strings to and from + * Tcl lists. To understand their operation, the rules of parsing and + * generating the string representation of lists must be known. Here we + * describe them in one place. + * + * A list is made up of zero or more elements. Any string is a list if it is + * made up of alternating substrings of element-separating ASCII whitespace + * and properly formatted elements. + * + * The ASCII characters which can make up the whitespace between list elements + * are: + * + * \u0009 \t TAB + * \u000A \n NEWLINE + * \u000B \v VERTICAL TAB + * \u000C \f FORM FEED + * \u000D \r CARRIAGE RETURN + * \u0020 SPACE + * + * NOTE: differences between this and other places where Tcl defines a role + * for "whitespace". + * + * * Unlike command parsing, here NEWLINE is just another whitespace + * character; its role as a command terminator in a script has no + * importance here. + * + * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not + * considered to be a whitespace character. + * + * * Other Unicode whitespace characters (recognized by [string is space] + * or Tcl_UniCharIsSpace()) do not play any role as element separators + * in Tcl lists. + * + * * The NUL byte ought not appear, as it is not in strings properly + * encoded for Tcl, but if it is present, it is not treated as + * separating whitespace, or a string terminator. It is just another + * character in a list element. + * + * The interpretaton of a formatted substring as a list element follows rules + * similar to the parsing of the words of a command in a Tcl script. Backslash + * substitution plays a key role, and is defined exactly as it is in command + * parsing. The same routine, TclParseBackslash() is used in both command + * parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever change + * for command parsing, the interpretation of strings as lists also changes. + * + * Backslash substitution replaces an "escape sequence" of one or more + * characters starting with + * \u005c \ BACKSLASH + * with a single character. The one character escape sequent case happens only + * when BACKSLASH is the last character in the string. In all other cases, the + * escape sequence is at least two characters long. + * + * The formatted substrings are interpreted as element values according to the + * following cases: + * + * * If the first character of a formatted substring is + * \u007b { OPEN BRACE + * then the end of the substring is the matching + * \u007d } CLOSE BRACE + * character, where matching is determined by counting nesting levels, and + * not including any brace characters that are contained within a backslash + * escape sequence in the nesting count. Having found the matching brace, + * all characters between the braces are the string value of the element. + * If no matching close brace is found before the end of the string, the + * string is not a Tcl list. If the character following the close brace is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a Tcl + * command only in its treatment of the backslash-newline sequence. In a + * list element, the literal characters in the backslash-newline sequence + * become part of the element value. In a script word, conversion to a + * single SPACE character is done. + * + * NOTE: Most list element values can be represented by a formatted + * substring using brace quoting. The exceptions are any element value that + * includes an unbalanced brace not in a backslash escape sequence, and any + * value that ends with a backslash not itself in a backslash escape + * sequence. + * + * * If the first character of a formatted substring is + * \u0022 " QUOTE + * then the end of the substring is the next QUOTE character, not counting + * any QUOTE characters that are contained within a backslash escape + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. Having found the limits of the + * substring, the element value is produced by performing backslash + * substitution on the character sequence between the open and close QUOTEs. + * + * NOTE: Any element value can be represented by this style of formatting, + * given suitable choice of backslash escape sequences. + * + * * All other formatted substrings are terminated by the next element + * separating whitespace character in the string. Having found the limits + * of the substring, the element value is produced by performing backslash + * substitution on it. + * + * NOTE: Any element value can be represented by this style of formatting, + * given suitable choice of backslash escape sequences, with one exception. + * The empty string cannot be represented as a list element without the use + * of either braces or quotes to delimit it. + * + * This collection of parsing rules is implemented in the routine + * TclFindElement(). + * + * In order to produce lists that can be parsed by these rules, we need the + * ability to distinguish between characters that are part of a list element + * value from characters providing syntax that define the structure of the + * list. This means that our code that generates lists must at a minimum be + * able to produce escape sequences for the 10 characters identified above + * that have significance to a list parser. + * + * * * CANONICAL LISTS * * * * * + * + * In addition to the basic rules for parsing strings into Tcl lists, there + * are additional properties to be met by the set of list values that are + * generated by Tcl. Such list values are often said to be in "canonical + * form": + * + * * When any canonical list is evaluated as a Tcl script, it is a script of + * either zero commands (an empty list) or exactly one command. The command + * word is exactly the first element of the list, and each argument word is + * exactly one of the following elements of the list. This means that any + * characters that have special meaning during script evaluation need + * special treatment when canonical lists are produced: + * + * * Whitespace between elements may not include NEWLINE. + * * The command terminating character, + * \u003b ; SEMICOLON + * must be BRACEd, QUOTEd, or escaped so that it does not terminate the + * command prematurely. + * * Any of the characters that begin substitutions in scripts, + * \u0024 $ DOLLAR + * \u005b [ OPEN BRACKET + * \u005c \ BACKSLASH + * need to be BRACEd or escaped. + * * In any list where the first character of the first element is + * \u0023 # HASH + * that HASH character must be BRACEd, QUOTEd, or escaped so that it + * does not convert the command into a comment. + * * Any list element that contains the character sequence BACKSLASH + * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character + * must be represented by an escape sequence, and unless QUOTEs are + * used, the NEWLINE must be as well. + * + * * It is also guaranteed that one can use a canonical list as a building + * block of a larger script within command substitution, as in this example: + * set script "puts \[[list $cmd $arg]]"; eval $script + * To support this usage, any appearance of the character + * \u005d ] CLOSE BRACKET + * in a list element must be BRACEd, QUOTEd, or escaped. + * + * * Finally it is guaranteed that enclosing a canonical list in braces + * produces a new value that is also a canonical list. This new list has + * length 1, and its only element is the original canonical list. This same + * guarantee also makes it possible to construct scripts where an argument + * word is given a list value by enclosing the canonical form of that list + * in braces: + * set script "puts {[list $one $two $three]}"; eval $script + * This sort of coding was once fairly common, though it's become more + * idiomatic to see the following instead: + * set script [list puts [list $one $two $three]]; eval $script + * In order to support this guarantee, every canonical list must have + * balance when counting those braces that are not in escape sequences. + * + * Within these constraints, the canonical list generation routines + * TclScanElement() and TclConvertElement() attempt to generate the string for + * any list that is easiest to read. When an element value is itself + * acceptable as the formatted substring, it is usually used (CONVERT_NONE). + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is + * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There + * are some exceptions to both of these preferences for reasons of code + * simplicity, efficiency, and continuation of historical habits. Canonical + * lists never use the QUOTE formatting to delimit their elements because that + * form of quoting does not nest, which makes construction of nested lists far + * too much trouble. Canonical lists always use only a single SPACE character + * for element-separating whitespace. + * + * * * FUTURE CONSIDERATIONS * * * + * + * When a list element requires quoting or escaping due to a CLOSE BRACKET + * character or an internal QUOTE character, a strange formatting mode is + * recommended. For example, if the value "a{b]c}d" is converted by the usual + * modes: + * + * CONVERT_BRACE: a{b]c}d => {a{b]c}d} + * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d + * + * we get perfectly usable formatted list elements. However, this is not what + * Tcl releases have been producing. Instead, we have: + * + * CONVERT_MASK: a{b]c}d => a{b\]c}d + * + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect + * can be seen replacing ] with " in this example. There does not appear to be + * any functional or aesthetic purpose for this strange additional mode. The + * sole purpose I can see for preserving it is to keep generating the same + * formatted lists programmers have become accustomed to, and perhaps written + * tests to expect. That is, compatibility only. The additional code + * complexity required to support this mode is significant. The lines of code + * supporting it are delimited in the routines below with #if COMPAT + * directives. This makes it easy to experiment with eliminating this + * formatting mode simply with "#define COMPAT 0" above. I believe this is + * worth considering. + * + * Another consideration is the treatment of QUOTE characters in list + * elements. TclConvertElement() must have the ability to produce the escape + * sequence \" so that when a list element begins with a QUOTE we do not + * confuse that first character with a QUOTE used as list syntax to define + * list structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like the way + * we handle HASH which also needs quoting and escaping only in particular + * situations. Following up this could increase the set of list elements that + * can use the CONVERT_NONE formatting mode. + * + * More speculative is that the demands of canonical list form require brace + * balance for the list as a whole, while the current implementation achieves + * this by establishing brace balance for every element. + * + * Finally, a reminder that the rules for parsing and formatting lists are + * closely tied together with the rules for parsing and evaluating scripts, + * and will need to evolve in sync. + */ + +/* + *---------------------------------------------------------------------- + * + * TclMaxListLength -- + * + * Given 'bytes' pointing to 'numBytes' bytes, scan through them and + * count the number of whitespace runs that could be list element + * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a + * full list parser. Typically used to get a quick and dirty overestimate + * of length size in order to allocate space for an actual list parser to + * operate with. + * + * Results: + * Returns the largest number of list elements that could possibly be in + * this string, interpreted as a Tcl list. If 'endPtr' is not NULL, + * writes a pointer to the end of the string scanned there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMaxListLength( + const char *bytes, + int numBytes, + const char **endPtr) +{ + int count = 0; + + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + /* Empty string case - quick exit */ + goto done; + } + + /* + * No list element before leading white space. + */ + + count += 1 - TclIsSpaceProc(*bytes); + + /* + * Count white space runs as potential element separators. + */ + + while (numBytes) { + if ((numBytes == -1) && (*bytes == '\0')) { + break; + } + if (TclIsSpaceProc(*bytes)) { + /* + * Space run started; bump count. + */ + + count++; + do { + bytes++; + numBytes -= (numBytes != -1); + } while (numBytes && TclIsSpaceProc(*bytes)); + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + break; + } + + /* + * (*bytes) is non-space; return to counting state. + */ + } + bytes++; + numBytes -= (numBytes != -1); + } + + /* + * No list element following trailing white space. + */ + + count -= TclIsSpaceProc(bytes[-1]); + + done: + if (endPtr) { + *endPtr = bytes; + } + return count; +} + +/* *---------------------------------------------------------------------- * * TclFindElement -- @@ -107,13 +462,18 @@ const Tcl_ObjType tclEndOffsetType = { * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of characters in the element. If - * the element is in braces, then *elementPtr will point to the character + * *sizePtr is filled in with the number of bytes in the element. If the + * element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, - * and both *elementPtr and *termPtr will point just after the last - * character in the list. Note: this function does NOT collapse backslash - * sequences. + * and both *elementPtr and *nextPtr will point just after the last + * character in the list. If literalPtr is non-NULL, *literalPtr is set + * to a boolean value indicating whether the substring returned as the + * values of **elementPtr and *sizePtr is the literal value of a list + * element. If not, a call to TclCopyAndCollapse() is needed to produce + * the actual value of the list element. Note: this function does NOT + * collapse backslash sequences, but uses *literalPtr to tell callers + * when it is required for them to do so. * * Side effects: * None. @@ -137,8 +497,12 @@ TclFindElement( * argument (next arg or end of list). */ int *sizePtr, /* If non-zero, fill in with size of * element. */ - int *bracePtr) /* If non-zero, fill in with non-zero/zero to - * indicate that arg was/wasn't in braces. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal list element and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ { const char *p = list; const char *elemStart; /* Points to first byte of first element. */ @@ -147,6 +511,7 @@ TclFindElement( int inQuotes = 0; int size = 0; /* lint. */ int numChars; + int literal = 1; const char *p2; /* @@ -156,7 +521,7 @@ TclFindElement( */ limit = (list + listLength); - while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ + while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } if (p == limit) { /* no element found */ @@ -172,9 +537,6 @@ TclFindElement( p++; } elemStart = p; - if (bracePtr != 0) { - *bracePtr = openBraces; - } /* * Find element's end (a space, close brace, or the end of the string). @@ -204,8 +566,7 @@ TclFindElement( } else if (openBraces == 1) { size = (p - elemStart); p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space. */ + if ((p >= limit) || TclIsSpaceProc(*p)) { goto done; } @@ -215,14 +576,15 @@ TclFindElement( if (interp != NULL) { p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ + while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -234,7 +596,17 @@ TclFindElement( */ case '\\': - Tcl_UtfBackslash(p, &numChars, NULL); + if (openBraces == 0) { + /* + * A backslash sequence not within a brace quoted element + * means the value of the element is different from the + * substring we are parsing. A call to TclCopyAndCollapse() is + * needed to produce the element value. Inform the caller. + */ + + literal = 0; + } + TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; @@ -263,8 +635,7 @@ TclFindElement( if (inQuotes) { size = (p - elemStart); p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space */ + if ((p >= limit) || TclIsSpaceProc(*p)) { goto done; } @@ -274,14 +645,15 @@ TclFindElement( if (interp != NULL) { p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ + while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -297,14 +669,18 @@ TclFindElement( if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open brace in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open brace in list", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open quote in list", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open quote in list", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + NULL); } return TCL_ERROR; } @@ -312,7 +688,7 @@ TclFindElement( } done: - while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ + while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } *elementPtr = elemStart; @@ -320,6 +696,9 @@ TclFindElement( if (sizePtr != 0) { *sizePtr = size; } + if (literalPtr != 0) { + *literalPtr = literal; + } return TCL_OK; } @@ -328,14 +707,13 @@ TclFindElement( * * TclCopyAndCollapse -- * - * Copy a string and eliminate any backslashes that aren't in braces. + * Copy a string and substitute all backslash escape sequences * * Results: - * Count characters get copied from src to dst. Along the way, if - * backslash sequences are found outside braces, the backslashes are - * eliminated in the copy. After scanning count chars from source, a null - * character is placed at the end of dst. Returns the number of - * characters that got copied. + * Count bytes get copied from src to dst. Along the way, backslash + * sequences are substituted in the copy. After scanning count bytes from + * src, a null character is placed at the end of dst. Returns the number + * of bytes that got written to dst. * * Side effects: * None. @@ -345,26 +723,29 @@ TclFindElement( int TclCopyAndCollapse( - int count, /* Number of characters to copy from src. */ + int count, /* Number of byte to copy from src. */ const char *src, /* Copy from here... */ char *dst) /* ... to here. */ { - register char c; - int numRead; int newCount = 0; - int backslashCount; - for (c = *src; count > 0; src++, c = *src, count--) { + while (count > 0) { + char c = *src; + if (c == '\\') { - backslashCount = Tcl_UtfBackslash(src, &numRead, dst); + int numRead; + int backslashCount = TclParseBackslash(src, count, &numRead, dst); + dst += backslashCount; newCount += backslashCount; - src += numRead-1; - count -= numRead-1; + src += numRead; + count -= numRead; } else { *dst = c; dst++; newCount++; + src++; + count--; } } *dst = 0; @@ -409,76 +790,55 @@ Tcl_SplitList( const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { - const char **argv, *l, *element; + const char **argv, *end, *element; char *p; - int length, size, i, result, elSize, brace; + int length, size, i, result, elSize; /* - * Figure out how much space to allocate. There must be enough space for - * both the array of pointers and also for a copy of the list. To estimate - * the number of pointers needed, count the number of space characters in - * the list. + * Allocate enough space to work in. A (const char *) for each (possible) + * list element plus one more for terminating NULL, plus as many bytes as + * in the original string value, plus one more for a terminating '\0'. + * Space used to hold element separating white space in the original + * string gets re-purposed to hold '\0' characters in the argv array. */ - for (size = 2, l = list; *l != 0; l++) { - if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ - size++; - - /* - * Consecutive space can only count as a single list delimiter. - */ - - while (1) { - char next = *(l + 1); + size = TclMaxListLength(list, -1, &end) + 1; + length = end - list; + argv = ckalloc((size * sizeof(char *)) + length + 1); - if (next == '\0') { - break; - } - l++; - if (isspace(UCHAR(next))) { /* INTL: ISO space. */ - continue; - } - break; - } - } - } - length = l - list; - argv = (const char **) ckalloc((unsigned) - ((size * sizeof(char *)) + length + 1)); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { const char *prevList = list; + int literal; result = TclFindElement(interp, list, length, &element, &list, - &elSize, &brace); + &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL); - } - ckfree((char *) argv); + ckfree(argv); return result; } if (*element == 0) { break; } if (i >= size) { - ckfree((char *) argv); + ckfree(argv); if (interp != NULL) { - Tcl_SetResult(interp, "internal error in Tcl_SplitList", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "internal error in Tcl_SplitList", -1)); + Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", + NULL); } return TCL_ERROR; } argv[i] = p; - if (brace) { + if (literal) { memcpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; } else { - TclCopyAndCollapse(elSize, element, p); - p += elSize+1; + p += 1 + TclCopyAndCollapse(elSize, element, p); } } @@ -491,128 +851,49 @@ Tcl_SplitList( /* *---------------------------------------------------------------------- * - * TclMarkList -- - * - * Marks the locations within a string where list elements start and - * computes where they end. + * Tcl_ScanElement -- * - * Results - * The return value is normally TCL_OK, which means that the list was - * successfully split up. If TCL_ERROR is returned, it means that "list" - * didn't have proper list structure; the interp's result will contain a - * more detailed error message. + * This function is a companion function to Tcl_ConvertElement. It scans + * a string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. * - * *argvPtr will be filled in with the address of an array whose elements - * point to the places where the elements of list start, in order. - * *argcPtr will get filled in with the number of valid elements in the - * array. *argszPtr will get filled in with the address of an array whose - * elements are the lengths of the elements of the list, in order. - * Note: *argvPtr, *argcPtr and *argszPtr are only modified if the - * function returns normally. + * Results: + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertElement to produce a valid list element from + * src. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertElement when doing the actual conversion. * * Side effects: - * Memory is allocated. + * None. * *---------------------------------------------------------------------- */ int -TclMarkList( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, no error message is left. */ - const char *list, /* Pointer to string with list structure. */ - const char *end, /* Pointer to first char after the list. */ - int *argcPtr, /* Pointer to location to fill in with the - * number of elements in the list. */ - const int **argszPtr, /* Pointer to place to store length of list - * elements. */ - const char ***argvPtr) /* Pointer to place to store pointer to array - * of pointers to list elements. */ +Tcl_ScanElement( + register const char *src, /* String to convert to list element. */ + register int *flagPtr) /* Where to store information to guide + * Tcl_ConvertCountedElement. */ { - const char **argv, *l, *element; - int *argn, length, size, i, result, elSize, brace; - - /* - * Figure out how much space to allocate. There must be enough space for - * the array of pointers and lengths. To estimate the number of pointers - * needed, count the number of whitespace characters in the list. - */ - - for (size=2, l=list ; l!=end ; l++) { - if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ - size++; - - /* - * Consecutive space can only count as a single list delimiter. - */ - - while (1) { - char next = *(l + 1); - - if ((l+1) == end) { - break; - } - l++; - if (isspace(UCHAR(next))) { /* INTL: ISO space. */ - continue; - } - break; - } - } - } - length = l - list; - argv = (const char **) ckalloc((unsigned) size * sizeof(char *)); - argn = (int *) ckalloc((unsigned) size * sizeof(int *)); - - for (i = 0; list != end; i++) { - const char *prevList = list; - - result = TclFindElement(interp, list, length, &element, &list, - &elSize, &brace); - length -= (list - prevList); - if (result != TCL_OK) { - ckfree((char *) argv); - ckfree((char *) argn); - return result; - } - if (*element == 0) { - break; - } - if (i >= size) { - ckfree((char *) argv); - ckfree((char *) argn); - if (interp != NULL) { - Tcl_SetResult(interp, "internal error in TclMarkList", - TCL_STATIC); - } - return TCL_ERROR; - } - argv[i] = element; - argn[i] = elSize; - } - - argv[i] = NULL; - argn[i] = 0; - *argvPtr = argv; - *argszPtr = argn; - *argcPtr = i; - return TCL_OK; + return Tcl_ScanCountedElement(src, -1, flagPtr); } /* *---------------------------------------------------------------------- * - * Tcl_ScanElement -- + * Tcl_ScanCountedElement -- * - * This function is a companion function to Tcl_ConvertElement. It scans - * a string to see what needs to be done to it (e.g. add backslashes or - * enclosing braces) to make the string into a valid Tcl list element. + * This function is a companion function to Tcl_ConvertCountedElement. It + * scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a valid Tcl + * list element. If length is -1, then the string is scanned from src up + * to the first null byte. * * Results: - * The return value is an overestimate of the number of characters that - * will be needed by Tcl_ConvertElement to produce a valid list element - * from string. The word at *flagPtr is filled in with a value needed by - * Tcl_ConvertElement when doing the actual conversion. + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertCountedElement to produce a valid list element + * from src. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. @@ -621,30 +902,42 @@ TclMarkList( */ int -Tcl_ScanElement( - register const char *string,/* String to convert to list element. */ - register int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ +Tcl_ScanCountedElement( + const char *src, /* String to convert to Tcl list element. */ + int length, /* Number of bytes in src, or -1. */ + int *flagPtr) /* Where to store information to guide + * Tcl_ConvertElement. */ { - return Tcl_ScanCountedElement(string, -1, flagPtr); + int flags = CONVERT_ANY; + int numBytes = TclScanElement(src, length, &flags); + + *flagPtr = flags; + return numBytes; } /* *---------------------------------------------------------------------- * - * Tcl_ScanCountedElement -- + * TclScanElement -- * - * This function is a companion function to Tcl_ConvertCountedElement. It - * scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned up to the - * first null byte. + * This function is a companion function to TclConvertElement. It scans a + * string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. If + * length is -1, then the string is scanned from src up to the first null + * byte. A NULL value for src is treated as an empty string. The incoming + * value of *flagPtr is a report from the caller what additional flags it + * will pass to TclConvertElement(). * * Results: - * The return value is an overestimate of the number of characters that - * will be needed by Tcl_ConvertCountedElement to produce a valid list - * element from string. The word at *flagPtr is filled in with a value - * needed by Tcl_ConvertCountedElement when doing the actual conversion. + * The recommended formatting mode for the element is determined and a + * value is written to *flagPtr indicating that recommendation. This + * recommendation is combined with the incoming flag values in *flagPtr + * set by the caller to determine how many bytes will be needed by + * TclConvertElement() in which to write the formatted element following + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be an + * overestimate, but so long as the caller passes the same flags to + * TclConvertElement(), it will be large enough. * * Side effects: * None. @@ -653,115 +946,269 @@ Tcl_ScanElement( */ int -Tcl_ScanCountedElement( - const char *string, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in string, or -1. */ +TclScanElement( + const char *src, /* String to convert to Tcl list element. */ + int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags, nestingLevel; - register const char *p, *lastChar; - - /* - * This function and Tcl_ConvertElement together do two things: - * - * 1. They produce a proper list, one that will yield back the argument - * strings when evaluated or when disassembled with Tcl_SplitList. This - * is the most important thing. - * - * 2. They try to produce legible output, which means minimizing the use - * of backslashes (using braces instead). However, there are some - * situations where backslashes must be used (e.g. an element like - * "{abc": the leading brace will have to be backslashed. For each - * element, one of three things must be done: - * - * (a) Use the element as-is (it doesn't contain any special - * characters). This is the most desirable option. - * - * (b) Enclose the element in braces, but leave the contents alone. - * This happens if the element contains embedded space, or if it - * contains characters with special interpretation ($, [, ;, or \), - * or if it starts with a brace or double-quote, or if there are no - * characters in the element. - * - * (c) Don't enclose the element in braces, but add backslashes to - * prevent special interpretation of special characters. This is a - * last resort used when the argument would normally fall under - * case (b) but contains unmatched braces. It also occurs if the - * last character of the argument is a backslash or if the element - * contains a backslash followed by newline. - * - * The function figures out how many bytes will be needed to store the - * result (actually, it overestimates). It also collects information about - * the element in the form of a flags word. - * - * Note: list elements produced by this function and - * Tcl_ConvertCountedElement must have the property that they can be - * enclosing in curly braces to make sub-lists. This means, for example, - * that we must not leave unmatched curly braces in the resulting list - * element. This property is necessary in order for functions like - * Tcl_DStringStartSublist to work. - */ + const char *p = src; + int nestingLevel = 0; /* Brace nesting count */ + int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something + * needs protection or escape. */ + int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some + * reason bare or brace-quoted form fails. */ + int extra = 0; /* Count of number of extra bytes needed for + * formatted element, assuming we use escape + * sequences in formatting. */ + int bytesNeeded; /* Buffer length computed to complete the + * element formatting in the selected mode. */ +#if COMPAT + int preferEscape = 0; /* Use preferences to track whether to use */ + int preferBrace = 0; /* CONVERT_MASK mode. */ + int braceCount = 0; /* Count of all braces '{' '}' seen. */ +#endif /* COMPAT */ + + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + /* + * Empty string element must be brace quoted. + */ - nestingLevel = 0; - flags = 0; - if (string == NULL) { - string = ""; - } - if (length == -1) { - length = strlen(string); + *flagPtr = CONVERT_BRACE; + return 2; } - lastChar = string + length; - p = string; - if ((p == lastChar) || (*p == '{') || (*p == '"')) { - flags |= USE_BRACES; + + if ((*p == '{') || (*p == '"')) { + /* + * Must escape or protect so leading character of value is not + * misinterpreted as list element delimiting syntax. + */ + + forbidNone = 1; +#if COMPAT + preferBrace = 1; +#endif /* COMPAT */ } - for (; p < lastChar; p++) { + + while (length) { + if (CHAR_TYPE(*p) != TYPE_NORMAL) { switch (*p) { - case '{': + case '{': /* TYPE_BRACE */ +#if COMPAT + braceCount++; +#endif /* COMPAT */ + extra++; /* Escape '{' => '\{' */ nestingLevel++; break; - case '}': + case '}': /* TYPE_BRACE */ +#if COMPAT + braceCount++; +#endif /* COMPAT */ + extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { - flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + + requireEscape = 1; } break; - case '[': - case '$': - case ';': - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - flags |= USE_BRACES; + case ']': /* TYPE_CLOSE_BRACK */ + case '"': /* TYPE_SPACE */ +#if COMPAT + forbidNone = 1; + extra++; /* Escapes all just prepend a backslash */ + preferEscape = 1; break; - case '\\': - if ((p+1 == lastChar) || (p[1] == '\n')) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; - } else { - int size; +#else + /* FLOW THROUGH */ +#endif /* COMPAT */ + case '[': /* TYPE_SUBS */ + case '$': /* TYPE_SUBS */ + case ';': /* TYPE_COMMAND_END */ + case ' ': /* TYPE_SPACE */ + case '\f': /* TYPE_SPACE */ + case '\n': /* TYPE_COMMAND_END */ + case '\r': /* TYPE_SPACE */ + case '\t': /* TYPE_SPACE */ + case '\v': /* TYPE_SPACE */ + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ +#if COMPAT + preferBrace = 1; +#endif /* COMPAT */ + break; + case '\\': /* TYPE_SUBS */ + extra++; /* Escape '\' => '\\' */ + if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { + /* + * Final backslash. Cannot format with brace quoting. + */ + + requireEscape = 1; + break; + } + if (p[1] == '\n') { + extra++; /* Escape newline => '\n', one byte longer */ + + /* + * Backslash newline sequence. Brace quoting not permitted. + */ - Tcl_UtfBackslash(p, &size, NULL); - p += size-1; - flags |= USE_BRACES; + requireEscape = 1; + length -= (length > 0); + p++; + break; } + if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { + extra++; /* Escape sequences all one byte longer. */ + length -= (length > 0); + p++; + } + forbidNone = 1; +#if COMPAT + preferBrace = 1; +#endif /* COMPAT */ + break; + case '\0': /* TYPE_SUBS */ + if (length == -1) { + goto endOfString; + } + /* TODO: Panic on improper encoding? */ break; } + } + length -= (length > 0); + p++; } + + endOfString: if (nestingLevel != 0) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + + requireEscape = 1; } - *flagPtr = flags; /* - * Allow enough space to backslash every character plus leave two spaces - * for braces. + * We need at least as many bytes as are in the element value... */ - return 2*(p-string) + 2; + bytesNeeded = p - src; + + if (requireEscape) { + /* + * We must use escape sequences. Add all the extra bytes needed to + * have room to create them. + */ + + bytesNeeded += extra; + + /* + * Make room to escape leading #, if needed. + */ + + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + bytesNeeded++; + } + *flagPtr = CONVERT_ESCAPE; + goto overflowCheck; + } + if (*flagPtr & CONVERT_ANY) { + /* + * The caller has not let us know what flags it will pass to + * TclConvertElement() so compute the max size we might need for any + * possible choice. Normally the formatting using escape sequences is + * the longer one, and a minimum "extra" value of 2 makes sure we + * don't request too small a buffer in those edge cases where that's + * not true. + */ + + if (extra < 2) { + extra = 2; + } + *flagPtr &= ~CONVERT_ANY; + *flagPtr |= TCL_DONT_USE_BRACES; + } + if (forbidNone) { + /* + * We must request some form of quoting of escaping... + */ + +#if COMPAT + if (preferEscape && !preferBrace) { + /* + * If we are quoting solely due to ] or internal " characters use + * the CONVERT_MASK mode where we escape all special characters + * except for braces. "extra" counted space needed to escape + * braces too, so substract "braceCount" to get our actual needs. + */ + + bytesNeeded += (extra - braceCount); + /* Make room to escape leading #, if needed. */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + bytesNeeded++; + } + + /* + * If the caller reports it will direct TclConvertElement() to + * use full escapes on the element, add back the bytes needed to + * escape the braces. + */ + + if (*flagPtr & TCL_DONT_USE_BRACES) { + bytesNeeded += braceCount; + } + *flagPtr = CONVERT_MASK; + goto overflowCheck; + } +#endif /* COMPAT */ + if (*flagPtr & TCL_DONT_USE_BRACES) { + /* + * If the caller reports it will direct TclConvertElement() to + * use escapes, add the extra bytes needed to have room for them. + */ + + bytesNeeded += extra; + + /* + * Make room to escape leading #, if needed. + */ + + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + bytesNeeded++; + } + } else { + /* + * Add 2 bytes for room for the enclosing braces. + */ + + bytesNeeded += 2; + } + *flagPtr = CONVERT_BRACE; + goto overflowCheck; + } + + /* + * So far, no need to quote or escape anything. + */ + + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* + * If we need to quote a leading #, make room to enclose in braces. + */ + + bytesNeeded += 2; + } + *flagPtr = CONVERT_NONE; + + overflowCheck: + if (bytesNeeded < 0) { + Tcl_Panic("TclScanElement: string length overflow"); + } + return bytesNeeded; } /* @@ -822,125 +1269,191 @@ Tcl_ConvertCountedElement( char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { - register char *p = dst; - register const char *lastChar; + int numBytes = TclConvertElement(src, length, dst, flags); + dst[numBytes] = '\0'; + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclConvertElement -- + * + * This is a companion function to TclScanElement. Given the information + * produced by TclScanElement, this function converts a string to a list + * element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclConvertElement( + register const char *src, /* Source information for list element. */ + int length, /* Number of bytes in src, or -1. */ + char *dst, /* Place to put list-ified element. */ + int flags) /* Flags produced by Tcl_ScanElement. */ +{ + int conversion = flags & CONVERT_MASK; + char *p = dst; /* - * See the comment block at the beginning of the Tcl_ScanElement code for - * details of how this works. + * Let the caller demand we use escape sequences rather than braces. */ - if (src && length == -1) { - length = strlen(src); + if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { + conversion = CONVERT_ESCAPE; } - if ((src == NULL) || (length == 0)) { - p[0] = '{'; - p[1] = '}'; - p[2] = 0; - return 2; + + /* + * No matter what the caller demands, empty string must be braced! + */ + + if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { + src = tclEmptyStringRep; + length = 0; + conversion = CONVERT_BRACE; } - lastChar = src + length; + + /* + * Escape leading hash as needed and requested. + */ + if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { - flags |= USE_BRACES; + if (conversion == CONVERT_ESCAPE) { + p[0] = '\\'; + p[1] = '#'; + p += 2; + src++; + length -= (length > 0); + } else { + conversion = CONVERT_BRACE; + } + } + + /* + * No escape or quoting needed. Copy the literal string value. + */ + + if (conversion == CONVERT_NONE) { + if (length == -1) { + /* TODO: INT_MAX overflow? */ + while (*src) { + *p++ = *src++; + } + return p - dst; + } else { + memcpy(dst, src, length); + return length; + } } - if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + + /* + * Formatted string is original string enclosed in braces. + */ + + if (conversion == CONVERT_BRACE) { *p = '{'; p++; - for (; src != lastChar; src++, p++) { - *p = *src; + if (length == -1) { + /* TODO: INT_MAX overflow? */ + while (*src) { + *p++ = *src++; + } + } else { + memcpy(p, src, length); + p += length; } *p = '}'; p++; - } else { - if (*src == '{') { - /* - * Can't have a leading brace unless the whole element is enclosed - * in braces. Add a backslash before the brace. Furthermore, this - * may destroy the balance between open and close braces, so set - * BRACES_UNMATCHED. - */ + return p - dst; + } - p[0] = '\\'; - p[1] = '{'; - p += 2; - src++; - flags |= BRACES_UNMATCHED; - } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { - /* - * Leading '#' could be seen by [eval] as the start of a comment, - * if on the first element of a list, so quote it. - */ + /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ - p[0] = '\\'; - p[1] = '#'; - p += 2; - src++; - } - for (; src != lastChar; src++) { - switch (*src) { - case ']': - case '[': - case '$': - case ';': - case ' ': - case '\\': - case '"': - *p = '\\'; - p++; - break; - case '{': - case '}': - /* - * It may not seem necessary to backslash braces, but it is. - * The reason for this is that the resulting list element may - * actually be an element of a sub-list enclosed in braces - * (e.g. if Tcl_DStringStartSublist has been invoked), so - * there may be a brace mismatch if the braces aren't - * backslashed. - */ + /* + * Formatted string is original string converted to escape sequences. + */ - if (flags & BRACES_UNMATCHED) { - *p = '\\'; - p++; - } - break; - case '\f': - *p = '\\'; - p++; - *p = 'f'; - p++; - continue; - case '\n': - *p = '\\'; - p++; - *p = 'n'; - p++; - continue; - case '\r': - *p = '\\'; - p++; - *p = 'r'; - p++; - continue; - case '\t': - *p = '\\'; - p++; - *p = 't'; - p++; - continue; - case '\v': + for ( ; length; src++, length -= (length > 0)) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': +#if COMPAT + if (conversion == CONVERT_ESCAPE) +#endif /* COMPAT */ + { *p = '\\'; p++; - *p = 'v'; - p++; - continue; } - *p = *src; + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + case '\0': + if (length == -1) { + return p - dst; + } + + /* + * If we reach this point, there's an embedded NULL in the string + * range being processed, which should not happen when the + * encoding rules for Tcl strings are properly followed. If the + * day ever comes when we stop tolerating such things, this is + * where to put the Tcl_Panic(). + */ + + break; } + *p = *src; + p++; } - *p = '\0'; - return p-dst; + return p - dst; } /* @@ -968,12 +1481,22 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; - int numChars; - char *result; - char *dst; - int i; +#define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + int i, bytesNeeded = 0; + char *result, *dst; + const int maxFlags = UINT_MAX / sizeof(int); + + /* + * Handle empty list case first, so logic of the general case can be + * simpler. + */ + + if (argc == 0) { + result = ckalloc(1); + result[0] = '\0'; + return result; + } /* * Pass 1: estimate space, gather flags. @@ -981,35 +1504,51 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; + } else if (argc > maxFlags) { + /* + * We cannot allocate a large enough flag array to format this list in + * one pass. We could imagine converting this routine to a multi-pass + * implementation, but for sizeof(int) == 4, the limit is a max of + * 2^30 list elements and since each element is at least one byte + * formatted, and requires one byte space between it and the next one, + * that a minimum space requirement of 2^31 bytes, which is already + * INT_MAX. If we tried to format a list of > maxFlags elements, we're + * just going to overflow the size limits on the formatted string + * anyway, so just issue that same panic early. + */ + + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + flagPtr = ckalloc(argc * sizeof(int)); } - numChars = 1; for (i = 0; i < argc; i++) { - numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); + bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } } + if (bytesNeeded > INT_MAX - argc + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += argc; /* * Pass two: copy into the result area. */ - result = (char *) ckalloc((unsigned) numChars); + result = ckalloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { - numChars = Tcl_ConvertElement(argv[i], dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); - dst += numChars; + flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); + dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]); *dst = ' '; dst++; } - if (dst == result) { - *dst = 0; - } else { - dst[-1] = 0; - } + dst[-1] = 0; if (flagPtr != localFlags) { - ckfree((char *) flagPtr); + ckfree(flagPtr); } return result; } @@ -1051,6 +1590,167 @@ Tcl_Backslash( /* *---------------------------------------------------------------------- * + * TclTrimRight -- + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the right side of the first string + * all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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 */ +{ + 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; + } + + /* + * Outer loop: iterate over string to be trimmed. + */ + + do { + Tcl_UniChar ch1; + const char *q = trim; + int bytesLeft = numTrim; + + p = Tcl_UtfPrev(p, bytes); + pInc = TclUtfToUniChar(p, &ch1); + + /* + * Inner loop: scan trim string for match to current character. + */ + + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* + * No match; trim task done; *p is last non-trimmed char. + */ + + p += pInc; + break; + } + } while (p > bytes); + + return numBytes - (p - bytes); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * The number of bytes to be removed from the start of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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 */ +{ + 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; + } + + /* + * Outer loop: iterate over string to be trimmed. + */ + + do { + Tcl_UniChar ch1; + int pInc = TclUtfToUniChar(p, &ch1); + const char *q = trim; + int bytesLeft = numTrim; + + /* + * Inner loop: scan trim string for match to current character. + */ + + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* + * No match; trim task done; *p is first non-trimmed char. + */ + + break; + } + + p += pInc; + numBytes -= pInc; + } while (numBytes); + + return p - bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. @@ -1067,56 +1767,97 @@ Tcl_Backslash( *---------------------------------------------------------------------- */ +/* The whitespace characters trimmed during [concat] operations */ +#define CONCAT_WS " \f\v\r\t\n" +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) + char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { - int totalSize, i; - char *p; - char *result; + int i, needSpace = 0, bytesNeeded = 0; + char *result, *p; + + /* + * Dispose of the empty result corner case first to simplify later code. + */ - for (totalSize = 1, i = 0; i < argc; i++) { - totalSize += strlen(argv[i]) + 1; - } - result = (char *) ckalloc((unsigned) totalSize); if (argc == 0) { - *result = '\0'; + result = (char *) ckalloc(1); + result[0] = '\0'; return result; } - for (p = result, i = 0; i < argc; i++) { - const char *element; - int length; + /* + * First allocate the result buffer at the size required. + */ + + for (i = 0; i < argc; i++) { + bytesNeeded += strlen(argv[i]); + if (bytesNeeded < 0) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + } + if (bytesNeeded + argc - 1 < 0) { /* - * Clip white space off the front and back of the string to generate a - * neater result, and ignore any empty elements. + * Panic test could be tighter, but not going to bother for this + * legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + + /* + * All element bytes + (argc - 1) spaces + 1 terminating NULL. + */ + + result = ckalloc((unsigned) (bytesNeeded + argc)); + + for (p = result, i = 0; i < argc; i++) { + int trim, elemLength; + const char *element; + element = argv[i]; - while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ - element++; - } - for (length = strlen(element); - (length > 0) - && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ - && ((length < 2) || (element[length-2] != '\\')); - length--) { - /* Null loop body. */ - } - if (length == 0) { + elemLength = strlen(argv[i]); + + /* + * Trim away the leading whitespace. + */ + + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + element += trim; + elemLength -= trim; + + /* + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. + */ + + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; + + /* + * If we're left with empty element after trimming, do nothing. + */ + + if (elemLength == 0) { continue; } - memcpy(p, element, (size_t) length); - p += length; - *p = ' '; - p++; - } - if (p != result) { - p[-1] = 0; - } else { - *p = 0; + + /* + * Append to the result with space if needed. + */ + + if (needSpace) { + *p++ = ' '; + } + memcpy(p, element, (size_t) elemLength); + p += elemLength; + needSpace = 1; } + *p = '\0'; return result; } @@ -1143,64 +1884,39 @@ Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ { - int allocSize, finalSize, length, elemLength, i; - char *p; + int i, elemLength, needSpace = 0, bytesNeeded = 0; const char *element; - char *concatStr; Tcl_Obj *objPtr, *resPtr; /* * Check first to see if all the items are of list type or empty. If so, * we will concat them together as lists, and return a list object. This - * is only valid when the lists have no current string representation, - * since we don't know what the original type was. An original string rep - * may have lost some whitespace info when converted which could be - * important. + * is only valid when the lists are in canonical form. */ for (i = 0; i < objc; i++) { - List *listRepPtr; + int length; objPtr = objv[i]; - if (objPtr->typePtr != &tclListType) { - TclGetString(objPtr); - if (objPtr->length) { - break; - } else { - continue; - } + if (TclListObjIsCanonical(objPtr)) { + continue; } - listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { + Tcl_GetStringFromObj(objPtr, &length); + if (length > 0) { break; } } if (i == objc) { - Tcl_Obj **listv; - int listc; - resPtr = NULL; for (i = 0; i < objc; i++) { - /* - * Tcl_ListObjAppendList could be used here, but this saves us a - * bit of type checking (since we've already done it). Use of - * INT_MAX tells us to always put the new stuff on the end. It - * will be set right in Tcl_ListObjReplace. - * Note that all objs at this point are either lists or have an - * empty string rep. - */ - objPtr = objv[i]; - if (objPtr->bytes && !objPtr->length) { + if (objPtr->bytes && objPtr->length == 0) { continue; } - TclListObjGetElements(NULL, objPtr, &listc, &listv); - if (listc) { - if (resPtr) { - Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv); - } else { - resPtr = TclListObjCopy(NULL, objPtr); - } + if (resPtr) { + Tcl_ListObjAppendList(NULL, resPtr, objPtr); + } else { + resPtr = TclListObjCopy(NULL, objPtr); } } if (!resPtr) { @@ -1212,81 +1928,69 @@ Tcl_ConcatObj( /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. + * + * First try to pre-allocate the size required. */ - allocSize = 0; for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &length); - if ((element != NULL) && (length > 0)) { - allocSize += (length + 1); + element = TclGetStringFromObj(objv[i], &elemLength); + bytesNeeded += elemLength; + if (bytesNeeded < 0) { + break; } } - if (allocSize == 0) { - allocSize = 1; /* enough for the NULL byte at end */ - } /* - * Allocate storage for the concatenated result. Note that allocSize is - * one more than the total number of characters, and so includes room for - * the terminating NULL byte. + * Does not matter if this fails, will simply try later to build up the + * string with each Append reallocating as needed with the usual string + * append algorithm. When that fails it will report the error. */ - concatStr = ckalloc((unsigned) allocSize); + TclNewObj(resPtr); + Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); + Tcl_SetObjLength(resPtr, 0); - /* - * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put a - * null byte at the end. - */ + for (i = 0; i < objc; i++) { + int trim; + + element = TclGetStringFromObj(objv[i], &elemLength); - finalSize = 0; - if (objc == 0) { - *concatStr = '\0'; - } else { - p = concatStr; - for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) && (UCHAR(*element) < 127) - && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ - element++; - elemLength--; - } + /* + * Trim away the leading whitespace. + */ - /* - * Trim trailing white space. But, be careful not to trim a space - * character if it is preceded by a backslash: in this case it - * could be significant. - */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + element += trim; + elemLength -= trim; - while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) - && isspace(UCHAR(element[elemLength-1])) - /* INTL: ISO C space. */ - && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { - elemLength--; - } - if (elemLength == 0) { - continue; /* nothing left of this element */ - } - memcpy(p, element, (size_t) elemLength); - p += elemLength; - *p = ' '; - p++; - finalSize += (elemLength + 1); + /* + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. + */ + + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; + + /* + * If we're left with empty element after trimming, do nothing. + */ + + if (elemLength == 0) { + continue; } - if (p != concatStr) { - p[-1] = 0; - finalSize -= 1; /* we overwrote the final ' ' */ - } else { - *p = 0; + + /* + * Append to the result with space if needed. + */ + + if (needSpace) { + Tcl_AppendToObj(resPtr, " ", 1); } + Tcl_AppendToObj(resPtr, element, elemLength); + needSpace = 1; } - - TclNewObj(objPtr); - objPtr->bytes = concatStr; - objPtr->length = finalSize; - return objPtr; + return resPtr; } /* @@ -1683,6 +2387,7 @@ TclByteArrayMatch( /* * Matches ranges of form [a-z] or [z-a]. */ + break; } } else if (startChar == ch1) { @@ -1729,9 +2434,9 @@ TclByteArrayMatch( * * TclStringMatchObj -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. This is the generic multi-type handler - * for the various matching algorithms. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. This is the generic multi-type handler for the various + * matching algorithms. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The @@ -1835,8 +2540,6 @@ Tcl_DStringAppend( * at end. */ { int newSize; - char *dst; - const char *end; if (length < 0) { length = strlen(bytes); @@ -1852,13 +2555,12 @@ Tcl_DStringAppend( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } @@ -1866,18 +2568,46 @@ Tcl_DStringAppend( * Copy the new string into the buffer at the end of the old one. */ - for (dst = dsPtr->string + dsPtr->length, end = bytes+length; - bytes < end; bytes++, dst++) { - *dst = *bytes; - } - *dst = '\0'; + memcpy(dsPtr->string + dsPtr->length, bytes, length); dsPtr->length += length; + dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } /* *---------------------------------------------------------------------- * + * TclDStringAppendObj, TclDStringAppendDString -- + * + * Simple wrappers round Tcl_DStringAppend that make it easier to append + * from particular sources of strings. + * + *---------------------------------------------------------------------- + */ + +char * +TclDStringAppendObj( + Tcl_DString *dsPtr, + Tcl_Obj *objPtr) +{ + int length; + char *bytes = Tcl_GetStringFromObj(objPtr, &length); + + return Tcl_DStringAppend(dsPtr, bytes, length); +} + +char * +TclDStringAppendDString( + Tcl_DString *dsPtr, + Tcl_DString *toAppendPtr) +{ + return Tcl_DStringAppend(dsPtr, Tcl_DStringValue(toAppendPtr), + Tcl_DStringLength(toAppendPtr)); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DStringAppendElement -- * * Append a list element to the current value of a dynamic string. @@ -1899,12 +2629,11 @@ Tcl_DStringAppendElement( const char *element) /* String to append. Must be * null-terminated. */ { - int newSize, flags, strSize; - char *dst; - - strSize = ((element== NULL) ? 0 : strlen(element)); - newSize = Tcl_ScanCountedElement(element, strSize, &flags) - + dsPtr->length + 1; + char *dst = dsPtr->string + dsPtr->length; + int needSpace = TclNeedSpace(dsPtr->string, dst); + int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + int newSize = dsPtr->length + needSpace + + TclScanElement(element, -1, &flags); /* * Allocate a larger buffer for the string if the current one isn't large @@ -1917,14 +2646,14 @@ Tcl_DStringAppendElement( if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } + dst = dsPtr->string + dsPtr->length; } /* @@ -1932,8 +2661,7 @@ Tcl_DStringAppendElement( * the end, with a space, if needed. */ - dst = dsPtr->string + dsPtr->length; - if (TclNeedSpace(dsPtr->string, dst)) { + if (needSpace) { *dst = ' '; dst++; dsPtr->length++; @@ -1946,7 +2674,8 @@ Tcl_DStringAppendElement( flags |= TCL_DONT_QUOTE_HASH; } - dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags); + dsPtr->length += TclConvertElement(element, -1, dst, flags); + dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -1999,13 +2728,12 @@ Tcl_DStringSetLength( dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = ckalloc((unsigned) dsPtr->spaceAvl); + char *newString = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, - (size_t) dsPtr->spaceAvl); + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } dsPtr->length = length; @@ -2068,23 +2796,8 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Interp *iPtr = (Interp *) interp; Tcl_ResetResult(interp); - - if (dsPtr->string != dsPtr->staticSpace) { - iPtr->result = dsPtr->string; - iPtr->freeProc = TCL_DYNAMIC; - } else if (dsPtr->length < TCL_RESULT_SIZE) { - iPtr->result = iPtr->resultSpace; - strcpy(iPtr->result, dsPtr->string); - } else { - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); - } - - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = '\0'; + Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } /* @@ -2120,6 +2833,39 @@ 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: + * + * 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. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + 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->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeIntRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ @@ -2132,7 +2878,7 @@ Tcl_DStringGetResult( dsPtr->string = iPtr->result; dsPtr->spaceAvl = dsPtr->length+1; } else { - dsPtr->string = (char *) ckalloc((unsigned) dsPtr->length+1); + dsPtr->string = ckalloc(dsPtr->length+1); memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); iPtr->freeProc(iPtr->result); } @@ -2143,7 +2889,7 @@ Tcl_DStringGetResult( dsPtr->string = dsPtr->staticSpace; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = (char *) ckalloc((unsigned) dsPtr->length+1); + dsPtr->string = ckalloc(dsPtr->length+1); dsPtr->spaceAvl = dsPtr->length + 1; } memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); @@ -2156,6 +2902,64 @@ Tcl_DStringGetResult( /* *---------------------------------------------------------------------- * + * TclDStringToObj -- + * + * This function moves a dynamic string's contents to a new Tcl_Obj. Be + * aware that this function does *not* check that the encoding of the + * contents of the dynamic string is correct; this is the caller's + * responsibility to enforce. + * + * Results: + * The newly-allocated untyped (i.e., typePtr==NULL) Tcl_Obj with a + * reference count of zero. + * + * Side effects: + * The string is "moved" to the object. dsPtr is reinitialized to an + * empty string; it does not need to be Tcl_DStringFree'd after this if + * not used further. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDStringToObj( + Tcl_DString *dsPtr) +{ + Tcl_Obj *result; + + if (dsPtr->length == 0) { + TclNewObj(result); + } else if (dsPtr->string == dsPtr->staticSpace) { + /* + * Static buffer, so must copy. + */ + + TclNewStringObj(result, dsPtr->string, dsPtr->length); + } else { + /* + * Dynamic buffer, so transfer ownership and reset. + */ + + TclNewObj(result); + result->bytes = dsPtr->string; + result->length = dsPtr->length; + } + + /* + * Re-establish the DString as empty with no buffer allocated. + */ + + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->length = 0; + dsPtr->staticSpace[0] = '\0'; + + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DStringStartSublist -- * * This function adds the necessary information to a dynamic string @@ -2176,9 +2980,9 @@ Tcl_DStringStartSublist( Tcl_DString *dsPtr) /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { - Tcl_DStringAppend(dsPtr, " {", -1); + TclDStringAppendLiteral(dsPtr, " {"); } else { - Tcl_DStringAppend(dsPtr, "{", -1); + TclDStringAppendLiteral(dsPtr, "{"); } } @@ -2204,7 +3008,7 @@ void Tcl_DStringEndSublist( Tcl_DString *dsPtr) /* Dynamic string. */ { - Tcl_DStringAppend(dsPtr, "}", -1); + TclDStringAppendLiteral(dsPtr, "}"); } /* @@ -2239,125 +3043,148 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char buffer[TCL_DOUBLE_SPACE]; - Tcl_UniChar ch; - - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + char *digits; + char *end; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* - * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal - * significand and exponent, then format it in E or F format as - * appropriate. If *precisionPtr != 0, use the native sprintf and then add - * a trailing ".0" if there is no decimal point in the rep. + * Handle NaN. */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } - if (*precisionPtr == 0) { + /* + * Handle infinities. + */ + + if (TclIsInfinite(value)) { /* - * Handle NaN. + * Remember to copy the terminating NUL too. */ - - if (TclIsNaN(value)) { - TclFormatNaN(value, dst); - return; + + if (value < 0) { + memcpy(dst, "-Inf", 5); + } else { + memcpy(dst, "Inf", 4); } + return; + } + /* + * Ordinary (normal and denormal) values. + */ + + if (*precisionPtr == 0) { + digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + &exponent, &signum, &end); + } else { /* - * Handle infinities. + * There are at least two possible interpretations for tcl_precision. + * + * The first is, "choose the decimal representation having + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". + * + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." + * + * Tcl 8.4 implements the first of these, which gives rise to + * anomalies in formatting: + * + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 + * + * For human readability, it appears better to choose the second rule, + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). + * + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. */ - if (TclIsInfinite(value)) { - if (value < 0) { - strcpy(dst, "-Inf"); - } else { - strcpy(dst, "Inf"); + digits = TclDoubleDigits(value, *precisionPtr, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + &exponent, &signum, &end); + } + if (signum) { + *dst++ = '-'; + } + p = digits; + if (exponent < -4 || exponent > 16) { + /* + * E format for numbers < 1e-3 or >= 1e17. + */ + + *dst++ = *p++; + c = *p; + if (c != '\0') { + *dst++ = '.'; + while (c != '\0') { + *dst++ = c; + c = *++p; } - return; } /* - * Ordinary (normal and denormal) values. + * Tcl 8.4 appears to format with at least a two-digit exponent; + * preserve that behaviour when tcl_precision != 0 */ - exponent = TclDoubleDigits(buffer, value, &signum); - if (signum) { - *dst++ = '-'; - } - p = buffer; - if (exponent < -3 || exponent > 17) { - /* - * E format for numbers < 1e-3 or >= 1e17. - */ - - *dst++ = *p++; - c = *p; - if (c != '\0') { - *dst++ = '.'; - while (c != '\0') { - *dst++ = c; - c = *++p; - } - } - sprintf(dst, "e%+d", exponent-1); + if (*precisionPtr == 0) { + sprintf(dst, "e%+d", exponent); } else { - /* - * F format for others. - */ - - if (exponent <= 0) { - *dst++ = '0'; - } - c = *p; - while (exponent-- > 0) { - if (c != '\0') { - *dst++ = c; - c = *++p; - } else { - *dst++ = '0'; - } - } - *dst++ = '.'; - if (c == '\0') { - *dst++ = '0'; - } else { - while (++exponent < 0) { - *dst++ = '0'; - } - while (c != '\0') { - *dst++ = c; - c = *++p; - } - } - *dst++ = '\0'; + sprintf(dst, "e%+03d", exponent); } } else { /* - * tcl_precision is supplied, pass it to the native sprintf. + * F format for others. */ - - sprintf(dst, "%.*g", *precisionPtr, value); - - /* - * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. Check for - * ASCII specifically to speed up the function. - */ - - for (p = dst; *p != 0;) { - if (UCHAR(*p) < 0x80) { - c = *p++; + + if (exponent < 0) { + *dst++ = '0'; + } + c = *p; + while (exponent-- >= 0) { + if (c != '\0') { + *dst++ = c; + c = *++p; } else { - p += Tcl_UtfToUniChar(p, &ch); - c = UCHAR(ch); + *dst++ = '0'; + } + } + *dst++ = '.'; + if (c == '\0') { + *dst++ = '0'; + } else { + while (++exponent < -1) { + *dst++ = '0'; } - if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ - return; + while (c != '\0') { + *dst++ = c; + c = *++p; } } - p[0] = '.'; - p[1] = '0'; - p[2] = 0; + *dst++ = '\0'; } + ckfree(digits); } /* @@ -2508,6 +3335,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -2527,6 +3355,94 @@ TclNeedSpace( /* *---------------------------------------------------------------------- * + * TclFormatInt -- + * + * This procedure formats an integer into a sequence of decimal digit + * characters in a buffer. If the integer is negative, a minus sign is + * inserted at the start of the buffer. A null character is inserted at + * the end of the formatted characters. It is the caller's responsibility + * to ensure that enough storage is available. This procedure has the + * effect of sprintf(buffer, "%ld", n) but is faster as proven in + * benchmarks. This is key to UpdateStringOfInt, which is a common path + * for a lot of code (e.g. int-indexed arrays). + * + * Results: + * An integer representing the number of characters formatted, not + * including the terminating \0. + * + * Side effects: + * The formatted characters are written into the storage pointer to by + * the "buffer" argument. + * + *---------------------------------------------------------------------- + */ + +int +TclFormatInt( + char *buffer, /* Points to the storage into which the + * formatted characters are written. */ + long n) /* The integer to format. */ +{ + long intVal; + int i; + int numFormatted, j; + const char *digits = "0123456789"; + + /* + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } + + /* + * Check whether "n" is the maximum negative value. This is -2^(m-1) for + * an m-bit word, and has no positive equivalent; negating it produces the + * same value. + */ + + intVal = -n; /* [Bug 3390638] Workaround for*/ + if (n == -n || intVal == n) { /* broken compiler optimizers. */ + return sprintf(buffer, "%ld", n); + } + + /* + * Generate the characters of the result backwards in the buffer. + */ + + intVal = (n < 0? -n : n); + i = 0; + buffer[0] = '\0'; + do { + i++; + buffer[i] = digits[intVal % 10]; + intVal = intVal/10; + } while (intVal > 0); + if (n < 0) { + i++; + buffer[i] = '-'; + } + numFormatted = i; + + /* + * Now reverse the characters. + */ + + for (j = 0; j < i; j++, i--) { + char tmp = buffer[i]; + + buffer[i] = buffer[j]; + buffer[j] = tmp; + } + return numFormatted; +} + +/* + *---------------------------------------------------------------------- + * * TclGetIntForIndex -- * * This function returns an integer corresponding to the list index held @@ -2584,7 +3500,7 @@ TclGetIntForIndex( * Leading whitespace is acceptable in an index. */ - while (length && isspace(UCHAR(*bytes))) { /* INTL: ISO space. */ + while (length && TclIsSpaceProc(*bytes)) { bytes++; length--; } @@ -2597,7 +3513,7 @@ TclGetIntForIndex( if ((savedOp != '+') && (savedOp != '-')) { goto parseError; } - if (isspace(UCHAR(opPtr[1]))) { + if (TclIsSpaceProc(opPtr[1])) { goto parseError; } *opPtr = '\0'; @@ -2623,16 +3539,10 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - /* - * The result might not be empty; this resets it which should be both - * a cheap operation, and of little problem because this is an - * error-generation path anyway. - */ - bytes = Tcl_GetString(objPtr); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } @@ -2667,10 +3577,10 @@ static void UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { - char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; + char buffer[TCL_INTEGER_SPACE + 5]; register int len; - strcpy(buffer, "end"); + memcpy(buffer, "end", 4); len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; @@ -2724,9 +3634,8 @@ SetEndOffsetFromAny( if ((*bytes != 'e') || (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -2744,8 +3653,8 @@ SetEndOffsetFromAny( * after "end-" to Tcl_GetInt, then reverse for offset. */ - if (isspace(UCHAR(bytes[4]))) { - return TCL_ERROR; + if (TclIsSpaceProc(bytes[4])) { + goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -2758,10 +3667,10 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?[+-]integer?", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; @@ -2810,7 +3719,7 @@ TclCheckBadOctal( * zero. Try to generate a meaningful error message. */ - while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + while (TclIsSpaceProc(*p)) { p++; } if (*p == '+' || *p == '-') { @@ -2823,7 +3732,7 @@ TclCheckBadOctal( while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; } - while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + while (TclIsSpaceProc(*p)) { p++; } if (*p == '\0') { @@ -2837,8 +3746,8 @@ TclCheckBadOctal( * be added to an existing error message as extra info. */ - Tcl_AppendResult(interp, " (looks like invalid octal number)", - NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", -1); } return 1; } @@ -2865,7 +3774,8 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2893,12 +3803,12 @@ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { - Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) - Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); + Tcl_HashTable **tablePtrPtr = + Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); + *tablePtrPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; @@ -2922,11 +3832,11 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - ckfree((char *) tablePtr); + ckfree(tablePtr); } /* @@ -2944,7 +3854,7 @@ static void FreeProcessGlobalValue( ClientData clientData) { - ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; + ProcessGlobalValue *pgvPtr = clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; @@ -2989,10 +3899,10 @@ TclSetProcessGlobalValue( if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { - Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); - pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); + pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -3008,8 +3918,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3058,8 +3967,7 @@ TclGetProcessGlobalValue( Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); - pgvPtr->value = ckalloc((unsigned) - Tcl_DStringLength(&newValue) + 1); + pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); @@ -3273,9 +4181,9 @@ TclReToGlob( Tcl_DString *dsPtr, int *exactPtr) { - int anchorLeft, anchorRight, lastIsStar; + int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; - const char *msg, *p, *strEnd; + const char *msg, *p, *strEnd, *code; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); @@ -3286,9 +4194,10 @@ TclReToGlob( if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to - * backslash escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to backslash + * escape every character and have * at each end. */ + Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; @@ -3312,8 +4221,8 @@ TclReToGlob( } /* - * At most, the glob pattern has length reStrLen + 2 to account - * for possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account for + * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); @@ -3323,15 +4232,16 @@ TclReToGlob( * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent - * multiple instances. Simpler than checking that the last star - * may be escaped. + * Keep track of the last char being an unescaped star to prevent multiple + * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; + code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; + numStars = 0; if (*p == '^') { anchorLeft = 1; @@ -3384,6 +4294,7 @@ TclReToGlob( break; default: msg = "invalid escape sequence"; + code = "BADESCAPE"; goto invalidGlob; } break; @@ -3395,6 +4306,7 @@ TclReToGlob( if (!lastIsStar) { *dsStr++ = '*'; lastIsStar = 1; + numStars++; } continue; } else if (p[1] == '+') { @@ -3402,6 +4314,7 @@ TclReToGlob( *dsStr++ = '?'; *dsStr++ = '*'; lastIsStar = 1; + numStars++; continue; } } @@ -3410,6 +4323,7 @@ TclReToGlob( case '$': if (p+1 != strEnd) { msg = "$ not anchor"; + code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; @@ -3417,14 +4331,25 @@ TclReToGlob( case '*': case '+': case '?': case '|': case '^': case '{': case '}': case '(': case ')': case '[': case ']': msg = "unhandled RE special char"; + code = "UNHANDLED"; goto invalidGlob; - break; default: *dsStr++ = *p; break; } lastIsStar = 0; } + if (numStars > 1) { + /* + * Heuristic: if >1 non-anchoring *, the risk is large that glob + * matching is slower than the RE engine, so report invalid. + */ + + msg = "excessive recursive glob backtrack potential"; + code = "OVERCOMPLEX"; + goto invalidGlob; + } + if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; } @@ -3434,22 +4359,12 @@ TclReToGlob( *exactPtr = (anchorLeft && anchorRight); } -#if 0 - fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", - reStrLen, reStr, - Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); - fflush(stderr); -#endif return TCL_OK; invalidGlob: -#if 0 - fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", - reStrLen, reStr, msg, *p); - fflush(stderr); -#endif if (interp != NULL) { - Tcl_AppendResult(interp, msg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; diff --git a/generic/tclVar.c b/generic/tclVar.c index 3370f9d..1c01e41 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,11 +15,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclVar.c,v 1.205 2010/09/27 17:36:48 msofer Exp $ */ #include "tclInt.h" +#include "tclOOInt.h" /* * Prototypes for the variable hash key methods. @@ -296,7 +295,7 @@ CleanupVar( && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { - ckfree((char *) varPtr); + ckfree(varPtr); } else { VarHashDeleteEntry(varPtr); } @@ -305,7 +304,7 @@ CleanupVar( TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { - ckfree((char *) arrayPtr); + ckfree(arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } @@ -662,7 +661,7 @@ TclObjLookupVarEx( len2 = len1 - i - 2; len1 = i; - newPart2 = ckalloc((unsigned) (len2+1)); + newPart2 = ckalloc(len2 + 1); memcpy(newPart2, part2, (unsigned) len2); *(newPart2+len2) = '\0'; part2 = newPart2; @@ -705,7 +704,6 @@ TclObjLookupVarEx( */ TclFreeIntRep(part1Ptr); - part1Ptr->typePtr = NULL; varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); @@ -765,7 +763,7 @@ TclObjLookupVarEx( } donePart1: -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); @@ -1026,8 +1024,7 @@ TclLookupSimpleVar( tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *) - ckalloc(sizeof(TclVarHashTable)); + tablePtr = ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); varFramePtr->varTablePtr = tablePtr; } @@ -1139,7 +1136,7 @@ TclLookupArrayElement( } TclSetVarArray(arrayPtr); - tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); + tablePtr = ckalloc(sizeof(TclVarHashTable)); arrayPtr->value.tablePtr = tablePtr; if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { @@ -1830,6 +1827,7 @@ TclPtrSetVar( Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; int result; + int cleanupOnEarlyError = (newValuePtr->refCount == 0); /* * If the variable is in a hashtable and its hPtr field is NULL, then we @@ -1895,7 +1893,7 @@ TclPtrSetVar( varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ /* * Can't happen now! */ @@ -2001,7 +1999,7 @@ TclPtrSetVar( return resultPtr; earlyError: - if (newValuePtr->refCount == 0) { + if (cleanupOnEarlyError) { Tcl_DecrRefCount(newValuePtr); } goto cleanup; @@ -2364,7 +2362,6 @@ TclPtrUnsetVar( if (part1Ptr->typePtr == &tclNsVarNameType) { TclFreeIntRep(part1Ptr); - part1Ptr->typePtr = NULL; } #endif @@ -2673,13 +2670,14 @@ Tcl_AppendObjCmd( /* * Note that we do not need to increase the refCount of the Var * pointers: should a trace delete the variable, the return value - * of TclPtrSetVar will be NULL, and we will not access the - * variable again. + * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not + * access the variable again. */ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1); - if (varValuePtr == NULL) { + if ((varValuePtr == NULL) || + (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { return TCL_ERROR; } } @@ -2992,8 +2990,7 @@ TclArraySet( } } TclSetVarArray(varPtr); - varPtr->value.tablePtr = (TclVarHashTable *) - ckalloc(sizeof(TclVarHashTable)); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); return TCL_OK; } @@ -3068,7 +3065,8 @@ ArrayStartSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); return TCL_ERROR; } @@ -3077,25 +3075,22 @@ ArrayStartSearchCmd( * Make a new array search with a free name. */ - searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + searchPtr = ckalloc(sizeof(ArraySearch)); hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); if (isNew) { searchPtr->id = 1; - Tcl_AppendResult(interp, "s-1-", varName, NULL); varPtr->flags |= VAR_SEARCH_ACTIVE; searchPtr->nextPtr = NULL; } else { - char string[TCL_INTEGER_SPACE]; - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - TclFormatInt(string, searchPtr->id); - Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); searchPtr->nextPtr = Tcl_GetHashValue(hPtr); } 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; } @@ -3166,8 +3161,8 @@ ArrayAnyMoreCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3272,8 +3267,8 @@ ArrayNextElementCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3382,8 +3377,8 @@ ArrayDoneSearchCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -3419,7 +3414,7 @@ ArrayDoneSearchCmd( } } } - ckfree((char *) searchPtr); + ckfree(searchPtr); return TCL_OK; } @@ -4025,8 +4020,8 @@ ArrayStatsCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(interp, "\"", TclGetString(varNameObj), - "\" isn't an array", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", TclGetString(varNameObj), NULL); return TCL_ERROR; @@ -4034,7 +4029,8 @@ ArrayStatsCmd( stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); if (stats == NULL) { - Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error reading array statistics", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); @@ -4226,18 +4222,18 @@ TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap arrayImplMap[] = { - {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL}, - {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL}, - {"exists", ArrayExistsCmd, NULL, NULL, NULL}, - {"get", ArrayGetCmd, NULL, NULL, NULL}, - {"names", ArrayNamesCmd, NULL, NULL, NULL}, - {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL}, - {"set", ArraySetCmd, NULL, NULL, NULL}, - {"size", ArraySizeCmd, NULL, NULL, NULL}, - {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL}, - {"statistics", ArrayStatsCmd, NULL, NULL, NULL}, - {"unset", ArrayUnsetCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0}, + {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0}, + {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, + {"get", ArrayGetCmd, NULL, NULL, NULL, 0}, + {"names", ArrayNamesCmd, NULL, NULL, NULL, 0}, + {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0}, + {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, + {"size", ArraySizeCmd, NULL, NULL, NULL, 0}, + {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0}, + {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0}, + {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "array", arrayImplMap); @@ -4323,10 +4319,10 @@ ObjMakeUpvar( || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - TclGetString(myNamePtr), "\": upvar won't create " + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create " "namespace variable that refers to procedure variable", - NULL); + TclGetString(myNamePtr))); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } @@ -4424,9 +4420,10 @@ TclPtrObjMakeUpvar( * myName looks like an array reference. */ - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable " - "that looks like an array element", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "bad variable name \"%s\": upvar won't create a" + " scalar variable that looks like an array element", + myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; @@ -4453,15 +4450,15 @@ TclPtrObjMakeUpvar( } if (varPtr == otherPtr) { - Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( + "can't upvar from variable to itself", -1)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" has traces: can't use for upvar", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { @@ -4475,8 +4472,8 @@ TclPtrObjMakeUpvar( */ if (!TclIsVarLink(varPtr)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", NULL); + Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( + "variable \"%s\" already exists", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); return TCL_ERROR; } @@ -4974,8 +4971,8 @@ Tcl_UpvarObjCmd( * for this particular case. */ - Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); return TCL_ERROR; } @@ -4984,8 +4981,8 @@ Tcl_UpvarObjCmd( * We've now finished with parsing levels; skip to the variable names. */ - objc -= hasLevel+1; - objv += hasLevel+1; + objc -= hasLevel + 1; + objv += hasLevel + 1; /* * Iterate over each (other variable, local variable) pair. Divide the @@ -5066,8 +5063,8 @@ SetArraySearchObj( return TCL_OK; syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return TCL_ERROR; } @@ -5132,10 +5129,9 @@ ParseSearchId( */ if (strcmp(string+offset, varName) != 0) { - Tcl_AppendResult(interp, "search identifier \"", string, - "\" isn't for variable \"", varName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + string, varName)); goto badLookup; } @@ -5159,7 +5155,8 @@ ParseSearchId( } } } - Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", string)); badLookup: Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; @@ -5196,7 +5193,7 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; - ckfree((char *) searchPtr); + ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); @@ -5479,13 +5476,13 @@ DeleteArray( TclClearVarNamespaceVar(elPtr); } VarHashDeleteTable(varPtr->value.tablePtr); - ckfree((char *) varPtr->value.tablePtr); + ckfree(varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * - * TclTclObjVarErrMsg -- + * TclObjVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. @@ -5699,7 +5696,7 @@ DupParsedVarName( if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); elemLen = strlen(elem); - elemCopy = ckalloc(elemLen+1); + elemCopy = ckalloc(elemLen + 1); memcpy(elemCopy, elem, elemLen); *(elemCopy + elemLen) = '\0'; elem = elemCopy; @@ -5732,7 +5729,7 @@ UpdateParsedVarName( len2 = strlen(part2); totalLen = len1 + len2 + 2; - p = ckalloc((unsigned) totalLen + 1); + p = ckalloc(totalLen + 1); objPtr->bytes = p; objPtr->length = totalLen; @@ -5900,8 +5897,8 @@ ObjFindNamespaceVar( Tcl_DecrRefCount(simpleNamePtr); } if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown variable \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } return (Tcl_Var) varPtr; @@ -6090,7 +6087,7 @@ TclInfoVarsCmd( } } } - } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { + } else if (iPtr->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1); } @@ -6276,17 +6273,21 @@ AppendLocals( { Interp *iPtr = (Interp *) interp; Var *varPtr; - int i, localVarCt; + int i, localVarCt, added; Tcl_Obj **varNamePtr, *objNamePtr; const char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; + Tcl_HashTable addedTable; const char *pattern = patternPtr? TclGetString(patternPtr) : NULL; 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++) { /* @@ -6298,6 +6299,9 @@ AppendLocals( varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + } } } varPtr++; @@ -6308,7 +6312,7 @@ AppendLocals( */ if (localVarTablePtr == NULL) { - return; + goto objectVars; } /* @@ -6322,9 +6326,13 @@ AppendLocals( && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), + &added); + } } } - return; + goto objectVars; } /* @@ -6340,9 +6348,41 @@ AppendLocals( varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + } + } + } + } + + objectVars: + if (!includeLinks) { + return; + } + + if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *contextPtr = iPtr->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + + if (mPtr->declaringObjectPtr) { + FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } + } + } else { + FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } } } } + Tcl_DeleteHashTable(&addedTable); } /* @@ -6368,7 +6408,7 @@ AllocVarEntry( Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = (Var *) ckalloc(sizeof(VarInHash)); + varPtr = ckalloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; @@ -6390,7 +6430,7 @@ FreeVarEntry( if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == 1)) { - ckfree((char *) varPtr); + ckfree(varPtr); } else { VarHashInvalidateEntry(varPtr); TclSetVarUndefined(varPtr); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8937648..9c1176e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -5,20 +5,28 @@ * * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2009 Donal K. Fellows + * Copyright (c) 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclZlib.c,v 1.38 2010/06/21 11:25:26 nijtmans Exp $ */ #include "tclInt.h" #ifdef HAVE_ZLIB #include <zlib.h> +#include "tclIO.h" + +/* + * The version of the zlib "package" that this implements. Note that this + * thoroughly supersedes the versions included with tclkit, which are "1.1", + * so this is at least "2.0" (there's no general *commitment* to have the same + * interface, even if that is mostly true). + */ + +#define TCL_ZLIB_VERSION "2.0" /* * Magic flags used with wbits fields to indicate that we're handling the gzip @@ -66,8 +74,27 @@ typedef struct { int wbits; /* The encoded compression mode, so we can * restart the stream if necessary. */ Tcl_Command cmd; /* Token for the associated Tcl command. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ + int flags; /* Miscellaneous flag bits. */ + GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header + * structure. */ } ZlibStreamHandle; +#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary + * in the low-level engine at the next + * opportunity. */ + +/* + * Macros to make it clearer in some of the twiddlier accesses what is + * happening. + */ + +#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW) +#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET) +#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET) + /* * Structure used for stacked channel compression and decompression. */ @@ -80,6 +107,11 @@ typedef struct { * for compression on output, or * TCL_ZLIB_STREAM_INFLATE for decompression * on input. */ + int format; /* What format of data is going on the wire. + * Needed so that the correct [fconfigure] + * options can be enabled. */ + int readAheadLimit; /* The maximum number of bytes to read from + * the underlying stream in one go. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -92,6 +124,10 @@ typedef struct { GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ + Tcl_DString decompressed; /* Buffer for decompression results. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibChannelData; /* @@ -108,46 +144,57 @@ typedef struct { #define OUT_HEADER 0x4 /* - * Size of buffers allocated by default. Should be enough... + * Size of buffers allocated by default, and the range it can be set to. The + * same sorts of values apply to streams, except with different limits (they + * permit byte-level activity). Channels always use bytes unless told to use + * larger buffers. */ #define DEFAULT_BUFFER_SIZE 4096 - -/* - * Time to wait (in milliseconds) before flushing the channel when reading - * data through the transform. - */ - -#define TRANSFORM_FLUSH_DELAY 5 +#define MIN_NONSTREAM_BUFFER_SIZE 16 +#define MAX_BUFFER_SIZE 65536 /* * Prototypes for private procedures defined later in this file: */ -static Tcl_CmdDeleteProc ZlibStreamCmdDelete; -static Tcl_DriverBlockModeProc ZlibTransformBlockMode; -static Tcl_DriverCloseProc ZlibTransformClose; -static Tcl_DriverGetHandleProc ZlibTransformGetHandle; -static Tcl_DriverGetOptionProc ZlibTransformGetOption; -static Tcl_DriverHandlerProc ZlibTransformHandler; -static Tcl_DriverInputProc ZlibTransformInput; -static Tcl_DriverOutputProc ZlibTransformOutput; -static Tcl_DriverSetOptionProc ZlibTransformSetOption; -static Tcl_DriverWatchProc ZlibTransformWatch; -static Tcl_ObjCmdProc ZlibCmd; -static Tcl_ObjCmdProc ZlibStreamCmd; - -static void ConvertError(Tcl_Interp *interp, int code); -static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); -static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, - GzipHeader *headerPtr, int *extraSizePtr); -static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, - int mode, int format, int level, - Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr); -static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); -static void ZlibTransformTimerKill(ZlibChannelData *cd); -static void ZlibTransformTimerRun(ClientData clientData); -static void ZlibTransformTimerSetup(ZlibChannelData *cd); +static Tcl_CmdDeleteProc ZlibStreamCmdDelete; +static Tcl_DriverBlockModeProc ZlibTransformBlockMode; +static Tcl_DriverCloseProc ZlibTransformClose; +static Tcl_DriverGetHandleProc ZlibTransformGetHandle; +static Tcl_DriverGetOptionProc ZlibTransformGetOption; +static Tcl_DriverHandlerProc ZlibTransformEventHandler; +static Tcl_DriverInputProc ZlibTransformInput; +static Tcl_DriverOutputProc ZlibTransformOutput; +static Tcl_DriverSetOptionProc ZlibTransformSetOption; +static Tcl_DriverWatchProc ZlibTransformWatch; +static Tcl_ObjCmdProc ZlibCmd; +static Tcl_ObjCmdProc ZlibStreamCmd; +static Tcl_ObjCmdProc ZlibStreamAddCmd; +static Tcl_ObjCmdProc ZlibStreamHeaderCmd; +static Tcl_ObjCmdProc ZlibStreamPutCmd; + +static void ConvertError(Tcl_Interp *interp, int code, + uLong adler); +static Tcl_Obj * ConvertErrorToList(int code, uLong adler); +static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); +static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, + GzipHeader *headerPtr, int *extraSizePtr); +static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static inline int ResultCopy(ZlibChannelData *cd, char *buf, + int toRead); +static int ResultGenerate(ZlibChannelData *cd, int n, int flush, + int *errorCodePtr); +static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, + int mode, int format, int level, int limit, + Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, + Tcl_Obj *compDictObj); +static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); +static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); +static void ZlibTransformTimerRun(ClientData clientData); /* * Type of zlib-based compressing and decompressing channels. @@ -167,7 +214,7 @@ static const Tcl_ChannelType zlibChannelType = { NULL, /* close2Proc */ ZlibTransformBlockMode, NULL, /* flushProc */ - ZlibTransformHandler, + ZlibTransformEventHandler, NULL, /* wideSeekProc */ NULL, NULL @@ -193,38 +240,139 @@ static void ConvertError( Tcl_Interp *interp, /* Interpreter to store the error in. May be * NULL, in which case nothing happens. */ - int code) /* The zlib error code. */ + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { + const char *codeStr, *codeStr2 = NULL; + char codeStrBuf[TCL_INTEGER_SPACE]; + if (interp == NULL) { return; } - if (code == Z_ERRNO) { + switch (code) { + /* + * Firstly, the case that is *different* because it's really coming + * from the OS and is just being reported via zlib. It should be + * really uncommon because Tcl handles all I/O rather than delegating + * it to zlib, but proving it can't happen is hard. + */ + + case Z_ERRNO: Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1)); - } else { - const char *codeStr, *codeStr2 = NULL; - char codeStrBuf[TCL_INTEGER_SPACE]; - - switch (code) { - case Z_STREAM_ERROR: codeStr = "STREAM"; break; - case Z_DATA_ERROR: codeStr = "DATA"; break; - case Z_MEM_ERROR: codeStr = "MEM"; break; - case Z_BUF_ERROR: codeStr = "BUF"; break; - case Z_VERSION_ERROR: codeStr = "VERSION"; break; - default: - codeStr = "unknown"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + return; /* - * Tricky point! We might pass NULL twice here (and will when the - * error type is known). + * Normal errors/conditions, some of which have additional detail and + * some which don't. (This is not defined by array lookup because zlib + * error codes are sometimes negative.) */ - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); + case Z_STREAM_ERROR: + codeStr = "STREAM"; + break; + case Z_DATA_ERROR: + codeStr = "DATA"; + break; + case Z_MEM_ERROR: + codeStr = "MEM"; + break; + case Z_BUF_ERROR: + codeStr = "BUF"; + break; + case Z_VERSION_ERROR: + codeStr = "VERSION"; + break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + + /* + * Anything else is bad news; it's unexpected. Convert to generic + * error. + */ + + default: + codeStr = "UNKNOWN"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%d", code); + break; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + + /* + * Tricky point! We might pass NULL twice here (and will when the error + * type is known). + */ + + Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); +} + +static Tcl_Obj * +ConvertErrorToList( + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ +{ + Tcl_Obj *objv[4]; + + TclNewLiteralStringObj(objv[0], "TCL"); + TclNewLiteralStringObj(objv[1], "ZLIB"); + switch (code) { + case Z_STREAM_ERROR: + TclNewLiteralStringObj(objv[2], "STREAM"); + return Tcl_NewListObj(3, objv); + case Z_DATA_ERROR: + TclNewLiteralStringObj(objv[2], "DATA"); + return Tcl_NewListObj(3, objv); + case Z_MEM_ERROR: + TclNewLiteralStringObj(objv[2], "MEM"); + return Tcl_NewListObj(3, objv); + case Z_BUF_ERROR: + TclNewLiteralStringObj(objv[2], "BUF"); + return Tcl_NewListObj(3, objv); + case Z_VERSION_ERROR: + TclNewLiteralStringObj(objv[2], "VERSION"); + return Tcl_NewListObj(3, objv); + case Z_ERRNO: + TclNewLiteralStringObj(objv[2], "POSIX"); + objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + return Tcl_NewListObj(4, objv); + case Z_NEED_DICT: + TclNewLiteralStringObj(objv[2], "NEED_DICT"); + objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler); + return Tcl_NewListObj(4, objv); + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + + /* + * Catch-all. Should be unreachable because all cases are already + * listed above. + */ + + default: + TclNewLiteralStringObj(objv[2], "UNKNOWN"); + TclNewIntObj(objv[3], code); + return Tcl_NewListObj(4, objv); } } @@ -296,7 +444,9 @@ GenerateHeader( NULL); headerPtr->nativeCommentBuf[len] = '\0'; headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { @@ -314,7 +464,9 @@ GenerateHeader( headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { @@ -355,7 +507,7 @@ GenerateHeader( * ExtractHeader -- * * Take the values out of a gzip header and store them in a dictionary. - * SetValue is a helper function. + * SetValue is a helper macro. * * Results: * None. @@ -366,18 +518,8 @@ GenerateHeader( *---------------------------------------------------------------------- */ -static inline void -SetValue( - Tcl_Obj *dictObj, - const char *key, - Tcl_Obj *value) -{ - Tcl_Obj *keyObj = Tcl_NewStringObj(key, -1); - - Tcl_IncrRefCount(keyObj); - Tcl_DictObjPut(NULL, dictObj, keyObj, value); - TclDecrRefCount(keyObj); -} +#define SetValue(dictObj, key, value) \ + Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) static void ExtractHeader( @@ -401,9 +543,7 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, &tmp); - SetValue(dictObj, "comment", Tcl_NewStringObj(Tcl_DStringValue(&tmp), - Tcl_DStringLength(&tmp))); - Tcl_DStringFree(&tmp); + SetValue(dictObj, "comment", TclDStringToObj(&tmp)); } SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); if (headerPtr->name != Z_NULL) { @@ -420,9 +560,7 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, &tmp); - SetValue(dictObj, "filename", Tcl_NewStringObj(Tcl_DStringValue(&tmp), - Tcl_DStringLength(&tmp))); - Tcl_DStringFree(&tmp); + SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); @@ -440,6 +578,34 @@ ExtractHeader( } } +static int +SetInflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return inflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + +static int +SetDeflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return deflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + /* *---------------------------------------------------------------------- * @@ -478,6 +644,7 @@ Tcl_ZlibStreamInit( ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; Tcl_CmdInfo cmdinfo; + GzipHeader *gzHeaderPtr = NULL; switch (mode) { case TCL_ZLIB_STREAM_DEFLATE: @@ -492,6 +659,15 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + if (dictObj) { + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + if (GenerateHeader(interp, dictObj, gzHeaderPtr, + NULL) != TCL_OK) { + ckfree(gzHeaderPtr); + return TCL_ERROR; + } + } break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -518,6 +694,14 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + gzHeaderPtr->header.name = (Bytef *) + gzHeaderPtr->nativeFilenameBuf; + gzHeaderPtr->header.name_max = MAXPATHLEN - 1; + gzHeaderPtr->header.comment = (Bytef *) + gzHeaderPtr->nativeCommentBuf; + gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1; break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -536,7 +720,7 @@ Tcl_ZlibStreamInit( " TCL_ZLIB_STREAM_INFLATE"); } - zshPtr = (ZlibStreamHandle *) ckalloc(sizeof(ZlibStreamHandle)); + zshPtr = ckalloc(sizeof(ZlibStreamHandle)); zshPtr->interp = interp; zshPtr->mode = mode; zshPtr->format = format; @@ -544,7 +728,11 @@ Tcl_ZlibStreamInit( zshPtr->wbits = wbits; zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; + zshPtr->compDictObj = NULL; + zshPtr->flags = 0; + zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); + zshPtr->stream.adler = 1; /* * No output buffer available yet @@ -553,12 +741,20 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = deflateSetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } else { e = inflateInit2(&zshPtr->stream, wbits); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = inflateGetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, zshPtr->stream.adler); goto error; } @@ -567,17 +763,17 @@ Tcl_ZlibStreamInit( */ if (interp != NULL) { - if (Tcl_Eval(interp, "incr ::tcl::zlib::cmdcounter") != TCL_OK) { + if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) { goto error; } Tcl_DStringInit(&cmdname); - Tcl_DStringAppend(&cmdname, "::tcl::zlib::streamcmd_", -1); - Tcl_DStringAppend(&cmdname, Tcl_GetString(Tcl_GetObjResult(interp)), - -1); + TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_"); + TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), &cmdinfo) == 1) { - Tcl_SetResult(interp, - "BUG: Stream command name already exists", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "BUG: Stream command name already exists", -1)); + Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); Tcl_DStringFree(&cmdname); goto error; } @@ -618,8 +814,15 @@ Tcl_ZlibStreamInit( } return TCL_OK; - error: - ckfree((char *) zshPtr); + + error: + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } + ckfree(zshPtr); return TCL_ERROR; } @@ -726,8 +929,14 @@ ZlibStreamCleanup( if (zshPtr->currentInput) { Tcl_DecrRefCount(zshPtr->currentInput); } + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } - ckfree((char *) zshPtr); + ckfree(zshPtr); } /* @@ -778,12 +987,24 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && HaveDictToSet(zshPtr)) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } + } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } + } } if (e != Z_OK) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); /* TODO:cleanup */ return TCL_ERROR; } @@ -876,6 +1097,41 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * + * Tcl_ZlibStreamSetCompressionDictionary -- + * + * Sets the compression dictionary for a stream. This will be used as + * appropriate for the next compression or decompression action performed + * on the stream. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zshandle, + Tcl_Obj *compressionDictionaryObj) +{ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; + + if (compressionDictionaryObj != NULL) { + if (Tcl_IsShared(compressionDictionaryObj)) { + compressionDictionaryObj = + Tcl_DuplicateObj(compressionDictionaryObj); + } + Tcl_IncrRefCount(compressionDictionaryObj); + zshPtr->flags |= DICT_TO_SET; + } else { + zshPtr->flags &= ~DICT_TO_SET; + } + if (zshPtr->compDictObj != NULL) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + zshPtr->compDictObj = compressionDictionaryObj; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ZlibStreamPut -- * * Add data to the stream for compression or decompression from a @@ -898,8 +1154,9 @@ Tcl_ZlibStreamPut( if (zshPtr->streamEnd) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "already past compressed stream end", TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "already past compressed stream end", -1)); + Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL); } return TCL_ERROR; } @@ -908,6 +1165,17 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; + if (HaveDictToSet(zshPtr)) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } + DictWasSet(zshPtr); + } + /* * Deflatebound doesn't seem to take various header sizes into * account, so we add 100 extra bytes. @@ -945,6 +1213,12 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } + if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } /* * And append the final data block. @@ -1022,7 +1296,7 @@ Tcl_ZlibStreamGet( * panic for out of memory if we just kept growing the buffer. */ - count = 65536; + count = MAX_BUFFER_SIZE; } /* @@ -1047,10 +1321,15 @@ Tcl_ZlibStreamGet( if (listLen > 0) { /* * There is more input available, get it from the list and - * give it to zlib. + * give it to zlib. At this point, the data must not be shared + * since we require the bytearray representation to not vanish + * under our feet. [Bug 3081008] */ Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj); + if (Tcl_IsShared(itemObj)) { + itemObj = Tcl_DuplicateObj(itemObj); + } itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; @@ -1062,11 +1341,33 @@ Tcl_ZlibStreamGet( */ Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL); - listLen--; } } + /* + * When dealing with a raw stream, we set the dictionary here, once. + * (You can't do it in response to getting Z_NEED_DATA as raw streams + * don't ever issue that.) + */ + + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } + return TCL_ERROR; + } + DictWasSet(zshPtr); + } e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + e = inflate(&zshPtr->stream, zshPtr->flush); + } + }; Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1078,9 +1379,11 @@ Tcl_ZlibStreamGet( if (zshPtr->stream.avail_in > 0) { if (zshPtr->interp) { - Tcl_SetResult(zshPtr->interp, - "Unexpected zlib internal state during decompression", - TCL_STATIC); + Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( + "unexpected zlib internal state during" + " decompression", -1)); + Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE", + NULL); } Tcl_SetByteArrayLength(data, existing); return TCL_ERROR; @@ -1092,10 +1395,15 @@ Tcl_ZlibStreamGet( } /* - * Get the next block of data to go to inflate. + * Get the next block of data to go to inflate. At this point, the + * data must not be shared since we require the bytearray + * representation to not vanish under our feet. [Bug 3081008] */ Tcl_ListObjIndex(zshPtr->interp, zshPtr->inData, 0, &itemObj); + if (Tcl_IsShared(itemObj)) { + itemObj = Tcl_DuplicateObj(itemObj); + } itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; @@ -1113,7 +1421,14 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); + do { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) { + break; + } + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + DictWasSet(zshPtr); + } while (e == Z_OK); } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -1121,7 +1436,7 @@ Tcl_ZlibStreamGet( } if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) { Tcl_SetByteArrayLength(data, existing); - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } if (e == Z_STREAM_END) { @@ -1217,24 +1532,10 @@ Tcl_ZlibDeflate( gz_header *headerPtr = NULL; Tcl_Obj *obj; - /* - * We pass the data back in the interp result obj... - */ - if (!interp) { return TCL_ERROR; } - obj = Tcl_GetObjResult(interp); - - /* - * Make sure that the result is an unshared object. [Bug 2947783] - */ - - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - Tcl_SetObjResult(interp, obj); - } - + /* * Compressed format is specified by the wbits parameter. See zlib.h for * details. @@ -1274,6 +1575,12 @@ Tcl_ZlibDeflate( } /* + * Allocate some space to store the output. + */ + + TclNewObj(obj); + + /* * Obtain the pointer to the byte array, we'll pass this pointer straight * to the deflate command. */ @@ -1341,10 +1648,12 @@ Tcl_ZlibDeflate( */ Tcl_SetByteArrayLength(obj, stream.total_out); + Tcl_SetObjResult(interp, obj); return TCL_OK; error: - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); + TclDecrRefCount(obj); return TCL_ERROR; } @@ -1373,23 +1682,9 @@ Tcl_ZlibInflate( Tcl_Obj *obj; char *nameBuf = NULL, *commentBuf = NULL; - /* - * We pass the data back in the interp result obj... - */ - if (!interp) { return TCL_ERROR; } - obj = Tcl_GetObjResult(interp); - - /* - * Make sure that the result is an unshared object. [Bug 2947783] - */ - - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - Tcl_SetObjResult(interp, obj); - } /* * Compressed format is specified by the wbits parameter. See zlib.h for @@ -1443,6 +1738,7 @@ Tcl_ZlibInflate( } } + TclNewObj(obj); outData = Tcl_SetByteArrayLength(obj, bufferSize); memset(&stream, 0, sizeof(z_stream)); stream.avail_in = (uInt) inLen+1; /* +1 because zlib can "over-request" @@ -1530,10 +1826,12 @@ Tcl_ZlibInflate( ckfree(nameBuf); ckfree(commentBuf); } + Tcl_SetObjResult(interp, obj); return TCL_OK; error: - ConvertError(interp, e); + TclDecrRefCount(obj); + ConvertError(interp, e, stream.adler); if (nameBuf) { ckfree(nameBuf); } @@ -1589,12 +1887,10 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int command, dlen, mode, format, i, option, level = -1; + int command, dlen, i, option, level = -1; unsigned start, buffersize = 0; - Tcl_ZlibStream zh; Byte *data; - Tcl_Obj *obj = Tcl_GetObjResult(interp); - Tcl_Obj *headerDictObj, *headerVarObj; + Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; static const char *const commands[] = { "adler32", "compress", "crc32", "decompress", "deflate", "gunzip", @@ -1605,14 +1901,6 @@ ZlibCmd( CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM }; - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -1638,8 +1926,8 @@ ZlibCmd( start = Tcl_ZlibAdler32(0, NULL, 0); } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); - Tcl_SetWideIntObj(obj, - (Tcl_WideInt) Tcl_ZlibAdler32(start, data, dlen)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? * -> checksum */ @@ -1655,8 +1943,8 @@ ZlibCmd( start = Tcl_ZlibCRC32(0, NULL, 0); } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); - Tcl_SetWideIntObj(obj, - (Tcl_WideInt) Tcl_ZlibCRC32(start, data, dlen)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? * -> rawCompressedData */ @@ -1692,12 +1980,27 @@ ZlibCmd( NULL); case CMD_GZIP: /* gzip data ?level? * -> gzippedCompressedData */ + headerDictObj = NULL; + + /* + * Legacy argument format support. + */ + + if (objc == 4 + && Tcl_GetIntFromObj(interp, objv[3], &level) == TCL_OK) { + if (level < 0 || level > 9) { + extraInfoStr = "\n (in -level option)"; + goto badLevel; + } + return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], + level, NULL); + } + if (objc < 3 || objc > 7 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-level level? ?-header header?"); return TCL_ERROR; } - headerDictObj = NULL; for (i=3 ; i<objc ; i+=2) { static const char *const gzipopts[] = { "-header", "-level", NULL @@ -1736,7 +2039,8 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } } @@ -1754,14 +2058,17 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); - case CMD_GUNZIP: /* gunzip gzippeddata ?bufferSize? + case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? * -> decompressedData */ + Tcl_Obj *headerVarObj; + if (objc < 3 || objc > 5 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?"); return TCL_ERROR; @@ -1782,7 +2089,8 @@ ZlibCmd( (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (buffersize < 16 || buffersize > 65536) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } break; @@ -1801,207 +2109,360 @@ ZlibCmd( } if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL, headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) { - if (headerDictObj) { - TclDecrRefCount(headerDictObj); - } return TCL_ERROR; } return TCL_OK; + } case CMD_STREAM: /* stream deflate/inflate/...gunzip \ - * ?level? + * ?options...? * -> handleCmd */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - mode = TCL_ZLIB_STREAM_INFLATE; - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_INFLATE: - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_DECOMPRESS: - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_GUNZIP: - format = TCL_ZLIB_FORMAT_GZIP; - break; - } - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } else { - level = Z_DEFAULT_COMPRESSION; - } - if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL, - &zh) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); - return TCL_OK; - case CMD_PUSH: { /* push mode channel options... + return ZlibStreamSubcmd(interp, objc, objv); + case CMD_PUSH: /* push mode channel options... * -> channel */ - Tcl_Channel chan; - int chanMode; - static const char *const pushOptions[] = { - "-header", "-level", "-limit", - NULL - }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; - int limit = 1, dummy; + return ZlibPushSubcmd(interp, objc, objv); + }; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); - return TCL_ERROR; - } + return TCL_ERROR; - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); - return TCL_ERROR; - } + badLevel: + Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + if (extraInfoStr) { + Tcl_AddErrorInfo(interp, extraInfoStr); + } + return TCL_ERROR; + badBuffer: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "buffer size must be %d to %d", + MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ZlibStreamSubcmd -- + * + * Implementation of the [zlib stream] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibStreamSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + int i, format, mode = 0, option, level; + enum objIndices { + OPT_COMPRESSION_DICTIONARY = 0, + OPT_GZIP_HEADER = 1, + OPT_COMPRESSION_LEVEL = 2, + OPT_END = -1 + }; + Tcl_Obj *obj[3] = { NULL, NULL, NULL }; +#define compDictObj obj[OPT_COMPRESSION_DICTIONARY] +#define gzipHeaderObj obj[OPT_GZIP_HEADER] +#define levelObj obj[OPT_COMPRESSION_LEVEL] + typedef struct { + const char *name; + enum objIndices offset; + } OptDescriptor; + static const OptDescriptor compressionOpts[] = { + { "-dictionary", OPT_COMPRESSION_DICTIONARY }, + { "-level", OPT_COMPRESSION_LEVEL }, + { NULL, OPT_END } + }; + static const OptDescriptor gzipOpts[] = { + { "-header", OPT_GZIP_HEADER }, + { "-level", OPT_COMPRESSION_LEVEL }, + { NULL, OPT_END } + }; + static const OptDescriptor expansionOpts[] = { + { "-dictionary", OPT_COMPRESSION_DICTIONARY }, + { NULL, OPT_END } + }; + static const OptDescriptor gunzipOpts[] = { + { NULL, OPT_END } + }; + const OptDescriptor *desc = NULL; + Tcl_ZlibStream zh; + + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + + /* + * The format determines the compression mode and the options that may be + * specified. + */ - if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, - 0) != TCL_OK) { + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + desc = gzipOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + desc = gunzipOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_Panic("should be unreachable"); + } + + /* + * Parse the options. + */ + + for (i=3 ; i<objc ; i+=2) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], desc, + sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) { return TCL_ERROR; } + obj[desc[option].offset] = objv[i+1]; + } - /* - * Sanity checks. - */ + /* + * If a compression level was given, parse it (integral: 0..9). Otherwise + * use the default. + */ + + if (levelObj == NULL) { + level = Z_DEFAULT_COMPRESSION; + } else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) { + return TCL_ERROR; + } else if (level < 0 || level > 9) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + + /* + * Construct the stream now we know its configuration. + */ + + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, + &zh) != TCL_OK) { + return TCL_ERROR; + } + if (compDictObj != NULL) { + Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj); + } + Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); + return TCL_OK; +#undef compDictObj +#undef gzipHeaderObj +#undef levelObj +} + +/* + *---------------------------------------------------------------------- + * + * ZlibPushSubcmd -- + * + * Implementation of the [zlib push] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibPushSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + Tcl_Channel chan; + int chanMode, format, mode = 0, level, i, option; + static const char *const pushCompressOptions[] = { + "-dictionary", "-header", "-level", NULL + }; + static const char *const pushDecompressOptions[] = { + "-dictionary", "-header", "-level", "-limit", NULL + }; + const char *const *pushOptions = pushDecompressOptions; + enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL, *compDictObj = NULL; + int limit = 1, dummy; - if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { - Tcl_AppendResult(interp, - "compression may only be applied to writable channels", - NULL); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + pushOptions = pushCompressOptions; + break; + case FMT_INFLATE: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + pushOptions = pushCompressOptions; + break; + case FMT_DECOMPRESS: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + pushOptions = pushCompressOptions; + break; + case FMT_GUNZIP: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_Panic("should be unreachable"); + } + + if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){ + return TCL_ERROR; + } + + /* + * Sanity checks. + */ + + if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "compression may only be applied to writable channels", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + return TCL_ERROR; + } + if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "decompression may only be applied to readable channels",-1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + return TCL_ERROR; + } + + /* + * Parse options. + */ + + level = Z_DEFAULT_COMPRESSION; + for (i=4 ; i<objc ; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0, + &option) != TCL_OK) { return TCL_ERROR; } - if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { - Tcl_AppendResult(interp, - "decompression may only be applied to readable channels", - NULL); + if (++i > objc-1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "value missing for %s option", pushOptions[option])); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - - /* - * Parse options. - */ - - level = Z_DEFAULT_COMPRESSION; - for (i=4 ; i<objc ; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0, - &option) != TCL_OK) { - return TCL_ERROR; + switch ((enum pushOptions) option) { + case poHeader: + headerObj = objv[i]; + if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { + goto genericOptionError; } - switch ((enum pushOptions) option) { - case poHeader: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -header option", NULL); - return TCL_ERROR; - } - headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -header option)"); - return TCL_ERROR; - } - break; - case poLevel: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -level option", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &level) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -level option)"); - return TCL_ERROR; - } - if (level < 0 || level > 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - break; - case poLimit: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -limit option", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &limit) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -limit option)"); - return TCL_ERROR; - } - if (limit < 1) { - limit = 1; - } - break; + break; + case poLevel: + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) { + goto genericOptionError; } + if (level < 0 || level > 9) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "level must be 0 to 9", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", + NULL); + goto genericOptionError; + } + break; + case poLimit: + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) { + goto genericOptionError; + } + if (limit < 1 || limit > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read ahead limit must be 1 to %d", + MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + goto genericOptionError; + } + break; + case poDictionary: + if (format == TCL_ZLIB_FORMAT_GZIP) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a compression dictionary may not be set in the " + "gzip format", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + goto genericOptionError; + } + compDictObj = objv[i]; + break; } - - if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[3]); - return TCL_OK; } - }; - - return TCL_ERROR; - badLevel: - Tcl_AppendResult(interp, "level must be 0 to 9", NULL); - if (extraInfoStr) { - Tcl_AddErrorInfo(interp, extraInfoStr); + if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan, + headerObj, compDictObj) == NULL) { + return TCL_ERROR; } - return TCL_ERROR; - badBuffer: - Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL); + Tcl_SetObjResult(interp, objv[3]); + return TCL_OK; + + genericOptionError: + Tcl_AddErrorInfo(interp, "\n (in "); + Tcl_AddErrorInfo(interp, pushOptions[option]); + Tcl_AddErrorInfo(interp, " option)"); return TCL_ERROR; } @@ -2023,24 +2484,16 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = cd; - int command, index, count; - Tcl_Obj *obj = Tcl_GetObjResult(interp); - int buffersize; - int flush = -1, i; + int command, count, code; + Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", - "fullflush", "get", "put", "reset", + "fullflush", "get", "header", "put", "reset", NULL }; enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, - zs_fullflush, zs_get, zs_put, zs_reset - }; - static const char *const add_options[] = { - "-buffer", "-finalize", "-flush", "-fullflush", NULL - }; - enum addOptions { - ao_buffer, ao_finalize, ao_flush, ao_fullflush + zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; if (objc < 2) { @@ -2055,107 +2508,11 @@ ZlibStreamCmd( switch ((enum zlibStreamCommands) command) { case zs_add: /* $strm add ?$flushopt? $data */ - for (i=2; i<objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum addOptions) index) { - case ao_flush: /* -flush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: /* -buffer */ - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-buffer\" option must be " - "followed by integer decompression buffersize", - NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i+1], - &buffersize) != TCL_OK) { - return TCL_ERROR; - } - } - - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - if (Tcl_ZlibStreamPut(zstream, objv[objc-1], - flush) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_ZlibStreamGet(zstream, obj, -1); - + return ZlibStreamAddCmd(zstream, interp, objc, objv); + case zs_header: /* $strm header */ + return ZlibStreamHeaderCmd(zstream, interp, objc, objv); case zs_put: /* $strm put ?$flushopt? $data */ - for (i=2; i<objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum addOptions) index) { - case ao_flush: /* -flush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: - Tcl_AppendResult(interp, - "\"-buffer\" option not supported here", NULL); - return TCL_ERROR; - } - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); + return ZlibStreamPutCmd(zstream, interp, objc, objv); case zs_get: /* $strm get ?count? */ if (objc > 3) { @@ -2169,33 +2526,50 @@ ZlibStreamCmd( return TCL_ERROR; } } - return Tcl_ZlibStreamGet(zstream, obj, count); + TclNewObj(obj); + code = Tcl_ZlibStreamGet(zstream, obj, count); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, obj); + } else { + TclDecrRefCount(obj); + } + return code; case zs_flush: /* $strm flush */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjLength(obj, 0); - return Tcl_ZlibStreamPut(zstream, obj, Z_SYNC_FLUSH); + TclNewObj(obj); + Tcl_IncrRefCount(obj); + code = Tcl_ZlibStreamPut(zstream, obj, Z_SYNC_FLUSH); + TclDecrRefCount(obj); + return code; case zs_fullflush: /* $strm fullflush */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjLength(obj, 0); - return Tcl_ZlibStreamPut(zstream, obj, Z_FULL_FLUSH); + TclNewObj(obj); + Tcl_IncrRefCount(obj); + code = Tcl_ZlibStreamPut(zstream, obj, Z_FULL_FLUSH); + TclDecrRefCount(obj); + return code; case zs_finalize: /* $strm finalize */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } + /* * The flush commands slightly abuse the empty result obj as input * data. */ - Tcl_SetObjLength(obj, 0); - return Tcl_ZlibStreamPut(zstream, obj, Z_FINISH); + TclNewObj(obj); + Tcl_IncrRefCount(obj); + code = Tcl_ZlibStreamPut(zstream, obj, Z_FINISH); + TclDecrRefCount(obj); + return code; case zs_close: /* $strm close */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -2207,14 +2581,15 @@ ZlibStreamCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetIntObj(obj, Tcl_ZlibStreamEof(zstream)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream))); return TCL_OK; case zs_checksum: /* $strm checksum */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetWideIntObj(obj, (Tcl_WideInt) Tcl_ZlibStreamChecksum(zstream)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + (uLong) Tcl_ZlibStreamChecksum(zstream))); return TCL_OK; case zs_reset: /* $strm reset */ if (objc != 2) { @@ -2226,11 +2601,257 @@ ZlibStreamCmd( return TCL_OK; } + +static int +ZlibStreamAddCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, code, buffersize = -1, flush = -1, i; + Tcl_Obj *obj, *compDictObj = NULL; + static const char *const add_options[] = { + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum addOptions { + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush + }; + + for (i=2; i<objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum addOptions) index) { + case ao_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case ao_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case ao_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case ao_buffer: /* -buffer */ + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-buffer\" option must be followed by integer " + "decompression buffersize", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { + return TCL_ERROR; + } + if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "buffer size must be 1 to %d", + MAX_BUFFER_SIZE)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; + } + break; + case ao_dictionary: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-dictionary\" option must be followed by" + " compression dictionary bytes", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + + if (flush == -2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get such data out as we can (up to the requested length). + */ + + TclNewObj(obj); + code = Tcl_ZlibStreamGet(zstream, obj, buffersize); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, obj); + } else { + TclDecrRefCount(obj); + } + return code; +} + +static int +ZlibStreamPutCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, flush = -1, i; + Tcl_Obj *compDictObj = NULL; + static const char *const put_options[] = { + "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum putOptions { + po_dictionary, po_finalize, po_flush, po_fullflush + }; + + for (i=2; i<objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum putOptions) index) { + case po_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case po_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case po_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case po_dictionary: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-dictionary\" option must be followed by" + " compression dictionary bytes", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + if (flush == -2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-flush\", \"-fullflush\" and \"-finalize\" options" + " are mutually exclusive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); +} + +static int +ZlibStreamHeaderCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ZlibStreamHandle *zshPtr = cd; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "only gunzip streams can produce header information", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} /* *---------------------------------------------------------------------- * Set of functions to support channel stacking. *---------------------------------------------------------------------- + * + * ZlibTransformClose -- + * + * How to shut down a stacked compressing/decompressing transform. + * + *---------------------------------------------------------------------- */ static int @@ -2241,7 +2862,16 @@ ZlibTransformClose( ZlibChannelData *cd = instanceData; int e, result = TCL_OK; - ZlibTransformTimerKill(cd); + /* + * Delete the support timer. + */ + + ZlibTransformEventTimerKill(cd); + + /* + * Flush any data waiting to be compressed. + */ + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { cd->outStream.avail_in = 0; do { @@ -2251,7 +2881,7 @@ ZlibTransformClose( if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); } result = TCL_ERROR; break; @@ -2262,23 +2892,27 @@ ZlibTransformClose( /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ - if (!TclInThreadExit()) { - if (interp) { - Tcl_AppendResult(interp, - "error while finalizing file: ", - Tcl_PosixError(interp), NULL); - } + if (!TclInThreadExit() && interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error while finalizing file: %s", + Tcl_PosixError(interp))); } result = TCL_ERROR; break; } } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->inStream); + e = deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->outStream); + e = inflateEnd(&cd->inStream); } + /* + * Release all memory. + */ + + Tcl_DStringFree(&cd->decompressed); + if (cd->inBuffer) { ckfree(cd->inBuffer); cd->inBuffer = NULL; @@ -2287,8 +2921,19 @@ ZlibTransformClose( ckfree(cd->outBuffer); cd->outBuffer = NULL; } + ckfree(cd); return result; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformInput -- + * + * Reader filter that does decompression. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformInput( @@ -2300,78 +2945,144 @@ ZlibTransformInput( ZlibChannelData *cd = instanceData; Tcl_DriverInputProc *inProc = Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent)); - int e, readBytes, flush = Z_NO_FLUSH; + int readBytes, gotBytes, copied; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead, errorCodePtr); } - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = toRead; - if (cd->inStream.next_in == NULL) { - goto doReadFirst; - } - while (1) { - e = inflate(&cd->inStream, flush); - if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) { - return toRead - cd->inStream.avail_out; - } - + gotBytes = 0; + while (toRead > 0) { /* - * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html - * - * Just indicates that the zlib couldn't consume input/produce output, - * and is fixed by supplying more input. + * Loop until the request is satisfied (or no data available from + * below, possibly EOF). */ - if ((e != Z_OK) && (e != Z_BUF_ERROR)) { - Tcl_Obj *errObj = Tcl_NewListObj(0, NULL); + copied = ResultCopy(cd, buf, toRead); + toRead -= copied; + buf += copied; + gotBytes += copied; - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->inStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return -1; + if (toRead == 0) { + return gotBytes; } /* - * Check if the inflate stopped early. + * The buffer is exhausted, but the caller wants even more. We now + * have to go to the underlying channel, get more bytes and then + * transform them for delivery. We may not get what we want (full EOF + * or temporarily out of data). + * + * Length (cd->decompressed) == 0, toRead > 0 here. + * + * The zlib transform allows us to read at most one character from the + * underlying channel to properly identify Z_STREAM_END without + * reading over the border. */ - if (cd->inStream.avail_in > 0) { - continue; - } + readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* - * Emptied the buffer of data from the underlying channel. Get some - * more. + * Three cases here: + * 1. Got some data from the underlying channel (readBytes > 0) so + * it should be fed through the decompression engine. + * 2. Got an error (readBytes < 0) which we should report up except + * for the case where we can convert it to a short read. + * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If + * it is EOF, try flushing the data out of the decompressor. */ - doReadFirst: - /* - * Hack for Bug 2762041. Disable pre-reading of lots of input, read - * only one character. This way the Z_END_OF_STREAM can be read - * without triggering an EOF in the base channel. The higher input - * loops in DoReadChars() would react to that by stopping, despite the - * transform still having data which could be read. - * - * This is only a hack because other transforms may not be able to - * work around the general problem in this way. - */ - - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); if (readBytes < 0) { + /* + * Report errors to caller. The state of the seek system is + * unchanged! + */ + + if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { + /* + * EAGAIN is a special situation. If we had some data before + * we report that instead of the request to re-try. + */ + + return gotBytes; + } + *errorCodePtr = Tcl_GetErrno(); return -1; } else if (readBytes == 0) { - flush = Z_SYNC_FLUSH; - } + /* + * Check wether we hit on EOF in 'parent' or not. If not, + * differentiate between blocking and non-blocking modes. In + * non-blocking mode we ran temporarily out of data. Signal this + * to the caller via EWOULDBLOCK and error return (-1). In the + * other cases we simply return what we got and let the caller + * wait for more. On the other hand, if we got an EOF we have to + * convert and flush all waiting partial data. + */ - cd->inStream.next_in = (Bytef *) cd->inBuffer; - cd->inStream.avail_in = readBytes; + if (!Tcl_Eof(cd->parent)) { + /* + * The state of the seek system is unchanged! + */ + + if ((gotBytes == 0) && (cd->flags & ASYNC)) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + return gotBytes; + } + + /* + * (Semi-)Eof in parent. + * + * Now this is a bit different. The partial data waiting is + * converted and returned. + */ + + if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) { + return -1; + } + + if (Tcl_DStringLength(&cd->decompressed) == 0) { + /* + * The drain delivered nothing. Time to deliver what we've + * got. + */ + + return gotBytes; + } + + /* + * Reset eof, force caller to drain result buffer. + */ + + ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; + } else /* readBytes > 0 */ { + /* + * Transform the read chunk, which was not empty. Anything we get + * back is a transformation result to be put into our buffers, and + * the next iteration will put it into the result. + */ + + if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, + errorCodePtr) != TCL_OK) { + return -1; + } + } } + return gotBytes; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformOutput -- + * + * Writer filter that does compression. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformOutput( @@ -2384,6 +3095,7 @@ ZlibTransformOutput( Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); int e, produced; + Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, @@ -2407,15 +3119,30 @@ ZlibTransformOutput( } } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); - if (e != Z_OK) { - Tcl_SetChannelError(cd->parent, - Tcl_NewStringObj(cd->outStream.msg, -1)); - *errorCodePtr = EINVAL; - return -1; + if (e == Z_OK) { + return toWrite - cd->outStream.avail_in; } - return toWrite - cd->outStream.avail_out; + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->outStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->outStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return -1; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformSetOption -- + * + * Writing side of [fconfigure] on our channel. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformSetOption( /* not used */ @@ -2427,57 +3154,133 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "flush"; + static const char *compressChanOptions = "dictionary flush"; + static const char *gzipChanOptions = "flush"; + static const char *decompressChanOptions = "dictionary limit"; + static const char *gunzipChanOptions = "flush limit"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); - if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { - int flushType; + if (optionName && (strcmp(optionName, "-dictionary") == 0) + && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { + Tcl_Obj *compDictObj; + int code; - if (value[0] == 'f' && strcmp(value, "full") == 0) { - flushType = Z_FULL_FLUSH; - goto doFlush; + TclNewStringObj(compDictObj, value, strlen(value)); + Tcl_IncrRefCount(compDictObj); + (void) Tcl_GetByteArrayFromObj(compDictObj, NULL); + if (cd->compDictObj) { + TclDecrRefCount(cd->compDictObj); } - if (value[0] == 's' && strcmp(value, "sync") == 0) { - flushType = Z_SYNC_FLUSH; - goto doFlush; + cd->compDictObj = compDictObj; + code = Z_OK; + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { + code = SetDeflateDictionary(&cd->outStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->outStream.adler); + return TCL_ERROR; + } + } else if (cd->format == TCL_ZLIB_FORMAT_RAW) { + code = SetInflateDictionary(&cd->inStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->inStream.adler); + return TCL_ERROR; + } } - Tcl_AppendResult(interp, "unknown -flush type \"", value, - "\": must be full or sync", NULL); - return TCL_ERROR; - - doFlush: - cd->outStream.avail_in = 0; - do { - int e; + return TCL_OK; + } - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; + if (haveFlushOpt) { + if (optionName && strcmp(optionName, "-flush") == 0) { + int flushType; - e = deflate(&cd->outStream, flushType); - if (e != Z_OK) { - ConvertError(interp, e); + if (value[0] == 'f' && strcmp(value, "full") == 0) { + flushType = Z_FULL_FLUSH; + } else if (value[0] == 's' && strcmp(value, "sync") == 0) { + flushType = Z_SYNC_FLUSH; + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown -flush type \"%s\": must be full or sync", + value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); return TCL_ERROR; } - if (cd->outStream.avail_out > 0) { + /* + * Try to actually do the flush now. + */ + + cd->outStream.avail_in = 0; + while (1) { + int e; + + cd->outStream.next_out = (Bytef *) cd->outBuffer; + cd->outStream.avail_out = cd->outAllocated; + + e = deflate(&cd->outStream, flushType); + if (e == Z_BUF_ERROR) { + break; + } else if (e != Z_OK) { + ConvertError(interp, e, cd->outStream.adler); + return TCL_ERROR; + } else if (cd->outStream.avail_out == 0) { + break; + } + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - PTR2INT(cd->outStream.next_out)) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); + cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "problem flushing channel: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } } - } while (cd->outStream.avail_out > 0); - return TCL_OK; + return TCL_OK; + } + } else { + if (optionName && strcmp(optionName, "-limit") == 0) { + int newLimit; + + if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) { + return TCL_ERROR; + } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-limit must be between 1 and 65536", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); + return TCL_ERROR; + } + } } if (setOptionProc == NULL) { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } + /* + * Pass all unknown options down, to deeper transforms and/or the base + * channel. + */ + return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, optionName, value); } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformGetOption -- + * + * Reading side of [fconfigure] on our channel. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformGetOption( @@ -2489,7 +3292,10 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum header"; + static const char *compressChanOptions = "checksum dictionary"; + static const char *gzipChanOptions = "checksum"; + static const char *decompressChanOptions = "checksum dictionary limit"; + static const char *gunzipChanOptions = "checksum header limit"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -2517,6 +3323,28 @@ ZlibTransformGetOption( } } + if ((cd->format != TCL_ZLIB_FORMAT_GZIP) && + (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) { + /* + * Embedded NUL bytes are ok; they'll be C080-encoded. + */ + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-dictionary"); + if (cd->compDictObj) { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetString(cd->compDictObj)); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + } else { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + + Tcl_DStringAppend(dsPtr, str, len); + } + } + /* * The "header" option, which is only valid on inflating gzip channels, * reports the header that has been read from the start of the stream. @@ -2532,10 +3360,7 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj)); Tcl_DecrRefCount(tmpObj); } else { - int len; - const char *str = Tcl_GetStringFromObj(tmpObj, &len); - - Tcl_DStringAppend(dsPtr, str, len); + TclDStringAppendObj(dsPtr, tmpObj); Tcl_DecrRefCount(tmpObj); return TCL_OK; } @@ -2552,8 +3377,27 @@ ZlibTransformGetOption( if (optionName == NULL) { return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformWatch, ZlibTransformEventHandler -- + * + * If we have data pending, trigger a readable event after a short time + * (in order to allow a real event to catch up). + * + *---------------------------------------------------------------------- + */ static void ZlibTransformWatch( @@ -2569,63 +3413,28 @@ ZlibTransformWatch( watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - if (!(mask & TCL_READABLE) - || (cd->inStream.avail_in == (uInt) cd->inAllocated)) { - ZlibTransformTimerKill(cd); - } else { - ZlibTransformTimerSetup(cd); - } -} - -static int -ZlibTransformGetHandle( - ClientData instanceData, - int direction, - ClientData *handlePtr) -{ - ZlibChannelData *cd = instanceData; - - return Tcl_GetChannelHandle(cd->parent, direction, handlePtr); -} - -static int -ZlibTransformBlockMode( - ClientData instanceData, - int mode) -{ - ZlibChannelData *cd = instanceData; - if (mode == TCL_MODE_NONBLOCKING) { - cd->flags |= ASYNC; - } else { - cd->flags &= ~ASYNC; + if (!(mask & TCL_READABLE) || Tcl_DStringLength(&cd->decompressed) == 0) { + ZlibTransformEventTimerKill(cd); + } else if (cd->timer == NULL) { + cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ZlibTransformTimerRun, cd); } - return TCL_OK; } static int -ZlibTransformHandler( +ZlibTransformEventHandler( ClientData instanceData, int interestMask) { ZlibChannelData *cd = instanceData; - ZlibTransformTimerKill(cd); + ZlibTransformEventTimerKill(cd); return interestMask; } -static void -ZlibTransformTimerSetup( - ZlibChannelData *cd) -{ - if (cd->timer == NULL) { - cd->timer = Tcl_CreateTimerHandler(TRANSFORM_FLUSH_DELAY, - ZlibTransformTimerRun, cd); - } -} - -static void -ZlibTransformTimerKill( +static inline void +ZlibTransformEventTimerKill( ZlibChannelData *cd) { if (cd->timer != NULL) { @@ -2647,6 +3456,53 @@ ZlibTransformTimerRun( /* *---------------------------------------------------------------------- * + * ZlibTransformGetHandle -- + * + * Anything that needs the OS handle is told to get it from what we are + * stacked on top of. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibTransformGetHandle( + ClientData instanceData, + int direction, + ClientData *handlePtr) +{ + ZlibChannelData *cd = instanceData; + + return Tcl_GetChannelHandle(cd->parent, direction, handlePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformBlockMode -- + * + * We need to keep track of the blocking mode; it changes our behavior. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibTransformBlockMode( + ClientData instanceData, + int mode) +{ + ZlibChannelData *cd = instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + cd->flags |= ASYNC; + } else { + cd->flags &= ~ASYNC; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ZlibStackChannelTransform -- * * Stacks either compression or decompression onto a channel. @@ -2674,13 +3530,17 @@ ZlibStackChannelTransform( * decompressing transforms. */ int level, /* What compression level to use. Ignored for * decompressing transforms. */ + int limit, /* The limit on the number of bytes to read + * ahead; always at least 1. */ Tcl_Channel channel, /* The channel to attach to. */ - Tcl_Obj *gzipHeaderDictPtr) /* A description of header to use, or NULL to + Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to * use a default. Ignored if not compressing * to produce gzip-format data. */ + Tcl_Obj *compDictObj) /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ { - ZlibChannelData *cd = (ZlibChannelData *) - ckalloc(sizeof(ZlibChannelData)); + ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; int e; @@ -2691,15 +3551,15 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; + cd->format = format; + cd->readAheadLimit = limit; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { if (gzipHeaderDictPtr) { - int dummy = 0; - cd->flags |= OUT_HEADER; if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader, - &dummy) != TCL_OK) { + NULL) != TCL_OK) { goto error; } } @@ -2714,6 +3574,12 @@ ZlibStackChannelTransform( } } + if (compDictObj != NULL) { + cd->compDictObj = Tcl_DuplicateObj(compDictObj); + Tcl_IncrRefCount(cd->compDictObj); + Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); + } + if (format == TCL_ZLIB_FORMAT_RAW) { wbits = WBITS_RAW; } else if (format == TCL_ZLIB_FORMAT_ZLIB) { @@ -2743,6 +3609,14 @@ ZlibStackChannelTransform( goto error; } } + if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + TclDecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } } else { e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); @@ -2757,8 +3631,16 @@ ZlibStackChannelTransform( goto error; } } + if (cd->compDictObj) { + e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + } } + Tcl_DStringInit(&cd->decompressed); + chan = Tcl_StackChannel(interp, &zlibChannelType, cd, Tcl_GetChannelMode(channel), channel); if (chan == NULL) { @@ -2778,12 +3660,177 @@ ZlibStackChannelTransform( ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } - ckfree((char *) cd); + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + } + ckfree(cd); return NULL; } /* *---------------------------------------------------------------------- + * + * ResultCopy -- + * + * Copies the requested number of bytes from the buffer into the + * specified array and removes them from the buffer afterward. Copies + * less if there is not enough data in the buffer. + * + * Side effects: + * See above. + * + * Result: + * The number of actually copied bytes, possibly less than 'toRead'. + * + *---------------------------------------------------------------------- + */ + +static inline int +ResultCopy( + ZlibChannelData *cd, /* The location of the buffer to read from. */ + char *buf, /* The buffer to copy into */ + int toRead) /* Number of requested bytes */ +{ + int have = Tcl_DStringLength(&cd->decompressed); + + if (have == 0) { + /* + * Nothing to copy in the case of an empty buffer. + */ + + return 0; + } else if (have > toRead) { + /* + * The internal buffer contains more than requested. Copy the + * requested subset to the caller, shift the remaining bytes down, and + * truncate. + */ + + char *src = Tcl_DStringValue(&cd->decompressed); + + memcpy(buf, src, toRead); + memmove(src, src + toRead, have - toRead); + + Tcl_DStringSetLength(&cd->decompressed, have - toRead); + return toRead; + } else /* have <= toRead */ { + /* + * There is just or not enough in the buffer to fully satisfy the + * caller, so take everything as best effort. + */ + + memcpy(buf, Tcl_DStringValue(&cd->decompressed), have); + TclDStringClear(&cd->decompressed); + return have; + } +} + +/* + *---------------------------------------------------------------------- + * + * ResultGenerate -- + * + * Extract uncompressed bytes from the compression engine and store them + * in our working buffer. + * + * Result: + * TCL_OK/TCL_ERROR (with *errorCodePtr updated with reason). + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static int +ResultGenerate( + ZlibChannelData *cd, + int n, + int flush, + int *errorCodePtr) +{ +#define MAXBUF 1024 + unsigned char buf[MAXBUF]; + int e, written; + Tcl_Obj *errObj; + + cd->inStream.next_in = (Bytef *) cd->inBuffer; + cd->inStream.avail_in = n; + + while (1) { + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = MAXBUF; + + e = inflate(&cd->inStream, flush); + if (e == Z_NEED_DICT && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e == Z_OK) { + /* + * A repetition of Z_NEED_DICT is just an error. + */ + + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = MAXBUF; + e = inflate(&cd->inStream, flush); + } + } + + /* + * avail_out is now the left over space in the output. Therefore + * "MAXBUF - avail_out" is the amount of bytes generated. + */ + + written = MAXBUF - cd->inStream.avail_out; + if (written) { + Tcl_DStringAppend(&cd->decompressed, (char *) buf, written); + } + + /* + * The cases where we're definitely done. + */ + + if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) + || (e == Z_STREAM_END) + || (e == Z_OK && cd->inStream.avail_out == 0)) { + return TCL_OK; + } + + /* + * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html + * + * Just indicates that the zlib couldn't consume input/produce output, + * and is fixed by supplying more input. + * + * Otherwise, we've got errors and need to report to higher-up. + */ + + if ((e != Z_OK) && (e != Z_BUF_ERROR)) { + goto handleError; + } + + /* + * Check if the inflate stopped early. + */ + + if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) { + return TCL_OK; + } + } + + handleError: + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->inStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->inStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- * Finally, the TclZlibInit function. Used to install the zlib API. *---------------------------------------------------------------------- */ @@ -2792,6 +3839,8 @@ int TclZlibInit( Tcl_Interp *interp) { + Tcl_Config cfg[2]; + /* * This does two things. It creates a counter used in the creation of * stream commands, and it creates the namespace that will contain those @@ -2805,7 +3854,24 @@ TclZlibInit( */ Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); - return TCL_OK; + + /* + * Store the underlying configuration information. + * + * TODO: Describe whether we're using the system version of the library or + * a compatibility version built into Tcl? + */ + + cfg[0].key = "zlibVersion"; + cfg[0].value = zlibVersion(); + cfg[1].key = NULL; + Tcl_RegisterConfig(interp, "zlib", cfg, "ascii"); + + /* + * Formally provide the package as a Tcl built-in. + */ + + return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); } /* @@ -2825,7 +3891,8 @@ Tcl_ZlibStreamInit( Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -2890,7 +3957,8 @@ Tcl_ZlibDeflate( int level, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -2902,7 +3970,8 @@ Tcl_ZlibInflate( int bufferSize, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); return TCL_ERROR; } @@ -2923,6 +3992,14 @@ Tcl_ZlibAdler32( { return 0; } + +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zshandle, + Tcl_Obj *compressionDictionaryObj) +{ + /* Do nothing. */ +} #endif /* HAVE_ZLIB */ /* |