Compare commits

...
Author SHA1 Message Date
dkf 2ce24093a1 Potential fix for issues relating to lack of errorCode setting with unknown command handling. 2013-09-20 13:05:04 +00:00
jan.nijtmans 9e6b54e433 Make sure that panic's during finalization are handled by the custom panicproc not by the default panicproc, because stderr might not be available.
When the default panicproc is in use, this doesn't make any difference.
2013-09-20 09:11:51 +00:00
dgp 39fcdc3c6e merge release 2013-09-20 05:28:59 +00:00
dkf 1479c62f1c [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. 2013-09-19 22:37:06 +00:00
dgp 54a81d4f0e merge trunk 2013-09-19 20:07:41 +00:00
dkf f95a5e7c82 [3970f54c4e]: Corrected regression in argument order processing in [unset]. 2013-09-19 19:37:05 +00:00
dgp 5285fe3ede merge trunk; update changes 2013-09-19 19:10:47 +00:00
dgp 8e1f9e82da comment 2013-09-19 19:02:42 +00:00
dgp fbac621bfc Line numbers wrong in compiled [unset]. 2013-09-19 18:53:01 +00:00
dgp 3cc058aa46 Line numbers wrong in compiled [dict with]. 2013-09-19 17:21:41 +00:00
dgp 3e3649a18e Line numbers wrong in compiled [dict exists]. 2013-09-19 17:01:58 +00:00
dgp d35d4b2c53 Line numbers wrong in compiled [global] and [variable]. 2013-09-19 16:41:04 +00:00
dgp c91c7b7cf1 Line numbers wrong in compiled [global] and [variable]. 2013-09-19 16:33:36 +00:00
dgp b4a00d3ac5 Line numbers wrong in compiled [namespace upvar]. 2013-09-19 16:11:20 +00:00
dgp bfcb6b40d2 renumber tests for branch merge 2013-09-19 16:06:53 +00:00
dgp 2440231062 Line numbers wrong in compiled [namespace upvar]. 2013-09-19 16:04:48 +00:00
dgp 0f1e352369 Line numbers wrong in compiled [upvar]. 2013-09-19 15:57:38 +00:00
dgp aed9fbb19c Line numbers wrong in compiled [upvar]. 2013-09-19 15:44:21 +00:00
dgp 4551ca9b2c Line numbers wrong in compiled [dict update]. 2013-09-19 15:05:55 +00:00
dgp e4dfb0d689 Line numbers wrong in compiled [dict update]. 2013-09-19 15:04:47 +00:00
dgp 63e65ca6f1 Line numbers wrong in compiled [dict for]. 2013-09-19 14:56:29 +00:00
dgp 7887926261 Line numbers wrong in compiled [dict for]. 2013-09-19 14:55:05 +00:00
dgp 91eca443b7 Line numbers wrong in compiled [dict get]. 2013-09-19 14:49:28 +00:00
dgp cb5d76ed2b Line numbers wrong in compiled [dict get]. 2013-09-19 14:48:02 +00:00
dgp 10372d985a Stop segfault due to OBOE in CompileWord() calls in [dict incr] compiler. 2013-09-19 14:22:37 +00:00
dkf 5aee161167 [3606943]: Corrected description of method search order. 2013-09-19 14:21:21 +00:00
dgp 657b49a9d1 Stop segfault due to OBOE in CompileWord() calls in [dict incr] compiler. 2013-09-19 14:06:46 +00:00
dgp bbf4d17089 [31661d2135] Plug memory leak. 2013-09-19 13:44:18 +00:00
dgp 4a2c3b6440 [31661d2135] Plug memory leak. 2013-09-19 13:39:40 +00:00
dgp 3f481feba6 Line numbers wrong in compiled [dict set]. 2013-09-19 13:13:00 +00:00
dgp 1b0845930c Line numbers wrong in compiled [dict set]. 2013-09-19 13:06:06 +00:00
jan.nijtmans 50a0b81579 consistant use of capitals 2013-09-19 13:00:02 +00:00
jan.nijtmans ad07565ec0 consistant use of capitals. 2013-09-19 12:37:13 +00:00
dgp 3b93da87b3 Merge test; bug already fixed in trunk. 2013-09-19 12:22:25 +00:00
dgp a414da9341 Line numbers wrong in compiled foreach body. 2013-09-19 12:20:13 +00:00
dgp 345bd636d4 Stop segfault due to OBOE in CompileWord() calls in [dict lappend] compiler. 2013-09-19 04:27:11 +00:00
dgp 134ada8ff9 Stop segfault due to OBOE in CompileWord() calls in [dict lappend] compiler. 2013-09-19 04:20:53 +00:00
dgp 3204893f09 [3487626] knownBug tests dict-23.2 and dist-24.21 already fixed on trunk. 2013-09-19 04:11:01 +00:00
dgp 7bc81bcbb0 [3487626] Backport fix for knownBug test dict-23.2. 2013-09-19 04:03:57 +00:00
dgp 6d44125712 merge release 2013-09-18 19:13:31 +00:00
dkf a2df72aecb Bump TclOO version to 1.0.1 2013-09-18 12:32:26 +00:00
dgp 85c48e5e91 merge trunk; update changes 2013-09-17 12:17:40 +00:00
dkf d4d8f3201a [2152292]: Corrected implementation of uuencode handling to support line length
indicator bytes.

***POTENTIAL INCOMPATIBILITY***
Existing code that was using the old versions and working around the
limitations will now need to do far less. The -maxlen option now has strict
limits on the range of supported lengths; this is a limitation of the format
itself.
2013-09-17 09:24:41 +00:00
dkf debbae5fd9 ChangeLog entry 2013-09-17 09:20:58 +00:00
dkf 649d0983f9 small improvements to the documentation 2013-09-17 09:13:40 +00:00
dgp 3146ffb96b [7b32d8d13b] Insert missing field initialization. 2013-09-16 23:18:54 +00:00
dgp f1a2117967 merge trunk; update changes 2013-09-16 18:59:14 +00:00
dkf 2044cba5ac Refactor to remove unused flexibility. 2013-09-16 09:03:50 +00:00
dkf eee6883d2a Be careful: separator needs to be bytes, not internal-encoded. 2013-09-16 08:52:12 +00:00
jan.nijtmans 472fd0a636 Add back -wrapchar option to "binary encode uuencode" 2013-09-15 16:30:01 +00:00
dkf bfe331b12a And the decoder too. 2013-09-14 18:25:45 +00:00
jan.nijtmans 1092cae12e Hm, this check doesn't really add anything. 2013-09-14 08:59:41 +00:00
jan.nijtmans 54850c7528 Add back -wrapchar option to "binary encode uuencode". 2013-09-14 08:51:23 +00:00
dkf 365b878745 [2152292] Corrected implementation of uuencoding. 2013-09-14 07:07:03 +00:00
dgp 08390e5c47 Added note to ChangeLog pointing to the fossil timeline for better logging. 2013-09-13 16:02:11 +00:00
dgp a52254cce9 merge 8.5; update changes 2013-09-13 14:14:24 +00:00
dgp 5cc8523f8e merge mark 2013-09-13 14:12:40 +00:00
dgp bcb4faa32f [bdd91c7e43] Stop crash due to error in execution stack memory management.
Thanks to azazel for the fix.
2013-09-13 14:09:09 +00:00
jan.nijtmans fa65ef51ba Suggested fix for [bdd91c7e43]: tclsh crashes in [interp delete] 2013-09-13 10:53:32 +00:00
dgp e94119e59b More macro use. 2013-09-13 03:33:43 +00:00
dgp 0440ab215b Push fixup on the stack only when needed. 2013-09-12 19:27:48 +00:00
dgp 27c4d781f4 Swap the two fixups used when compiling the ternary operator.
Push them on the stack only when needed, and pop as soon as possible.
2013-09-12 19:21:20 +00:00
dgp 8fd5bbdc7c Stop allocating JumpFixups for jumps that can never need any fixing up. 2013-09-12 17:42:36 +00:00
dgp 612c7a7d4a Eliminate another surplus storage field. Make a(n ab)use of the existing
JumpFixup fields instead.
2013-09-11 05:07:52 +00:00
dgp c4a5440ed1 Make use of the existing JumpFixup fields. Eliminate extra storage
field 'offset' in JumpList that we don't require.
2013-09-11 04:49:08 +00:00
dgp 822fd2d405 Stop the save and restore of currStackDepth. Just manage it correctly so
it doesn't need correcting.
2013-09-11 02:32:04 +00:00
dkf e723893895 [3609693] Must strip the internal representation of procedure-like methods in
order to ensure that any bound references to instance variables are removed.
2013-09-09 14:12:05 +00:00
dkf e0623615e3 [3609693] Must strip the internal representation of procedure-like methods in
order to ensure that any bound references to instance variables are removed.
2013-09-09 13:34:06 +00:00
dkf b348c536f6 merge trunk 2013-09-09 12:34:33 +00:00
dkf 2b788a21e4 [3611643] Stop polluting the global namespace.
Refactor the index entry generation so it is done right, once.
Handle more of [namespace ensemble create]'s behavior.
2013-09-08 10:21:37 +00:00
dgp a8bbc9486a merge 8.5. update changes. 2013-09-08 03:26:12 +00:00
dgp f089b1e4a1 [86ceb4e2b6] Improve reaction when multiple *tm files purport to offer the
same version of the same package. Prefer the file that comes first on the
tm path. Makes TCL*_TM_PATH variables more useful. Thanks to Gustaf Neumann
for the suggestion. 
[a16752c252] Revise (partially revert) bug fix to stop crashes in buggy 
tclcompiler.
2013-09-07 22:19:49 +00:00
dgp bb55ca2e95 [86ceb4e2b6] Improve reaction when multiple *tm files purport to offer the
same version of the same package.  Prefer the file that comes first on
the tm path.  Makes TCL*_TM_PATH variables more useful.  Thanks to
Gustaf Neumann for the suggestion.
2013-09-07 21:36:37 +00:00
dgp 0288a572d8 merge trunk 2013-09-07 21:19:47 +00:00
dgp 1ecf461e41 Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. 2013-09-07 18:49:55 +00:00
dgp 97f9595151 Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. 2013-09-05 17:21:41 +00:00
dgp 30710a181c Use ne instead of [string length] for less shimmer risk. 2013-09-05 15:47:29 +00:00
dgp 493b04cbc0 Error in order of #include lines broke some windows builds. 2013-09-05 12:45:11 +00:00
dgp 8938dbcc25 Merge commits to the correct branch -- trunk 2013-09-05 12:35:24 +00:00
dgp db738e7756 [010f4162ef] Repair effect of trace errors on -errorinfo and -errorstack. 2013-09-05 12:31:46 +00:00
dgp c6bb98e763 Cleaned up test command trying to make valgrind happy. 2013-09-04 12:45:51 +00:00
dkf c938932757 [98c8b3ec12] Make test fail in less catastrophic manner. 2013-09-04 09:36:22 +00:00
jan.nijtmans 9878106deb Fix 3 trivial (possible) errors, discovered by covertity.com 2013-09-04 07:22:45 +00:00
dgp 4d70c5f1e1 doc fix exposed by make html 2013-09-03 18:50:08 +00:00
dgp c5cad32cd6 make dist 2013-09-03 17:39:34 +00:00
dgp 6a3868f2cc typo 2013-09-03 17:07:41 +00:00
dgp 3116380710 Favor timeline over ChangeLog 2013-09-03 16:47:50 +00:00
dgp 53dc4dcdee Favor timeline over ChangeLog 2013-09-03 16:45:56 +00:00
dgp 4733e874fc update changes 2013-09-03 16:04:30 +00:00
dgp a313e78ffa some missed changes 2013-09-03 16:04:06 +00:00
dgp 2c3dbea378 Add test and improve errorInfo. 2013-09-02 18:47:07 +00:00
dgp 8520e69f32 [010f4162ef] First step of fix on stammering errorstack. errorstack fixed.
errorinfo revision still under consideration.
2013-09-02 17:59:42 +00:00
jan.nijtmans 54223a5f7e typo 2013-09-02 14:01:00 +00:00
dkf 22515fc47f [b98fa55285]: Fix handling of whitespace at end of hex strings to decode. 2013-09-01 20:08:50 +00:00
dgp 8932701ae7 Bump version number to 8.6.1. 2013-08-30 22:04:12 +00:00
dgp 6b45d21b4b Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. 2013-08-30 21:57:26 +00:00
dgp 3adc645802 fix date 2013-08-30 14:31:06 +00:00
dgp 743ced9da3 changes 2013-08-30 14:16:05 +00:00
dgp b9ef276505 Bump to 8.5.15 for release. 2013-08-29 20:08:04 +00:00
dgp ebd7e8a86b [2486550] NR-enable same-interp invokehidden. Also, reroute all objProc
invocation through the common routines of EvalObjvCore and Dispatch.
2013-08-29 19:19:32 +00:00
dgp 4096bf5d01 New internal eval flag value so that all TclNREvalObjv() callers that
pre-resolve command names can choose whether or not TclNREvalObjv() should
attempt to re-do the resolution from objv[0] when something goes wrong.
2013-08-29 17:59:36 +00:00
dgp 6dcfcb8be9 Rework the re-resolution after enter traces machinery with cleaner
separations and neater interfaces.
2013-08-28 18:05:07 +00:00
dgp 24cec35f7b Clarfy and prettify influence of flag settings and command lookups. 2013-08-28 02:44:50 +00:00
dgp 367ade79ed Tidy up indenting for clarity in refactoring. 2013-08-27 20:25:15 +00:00
dgp e6af5d333b Exceptions raised from enter traces take priority over re-resolution games. 2013-08-27 20:06:08 +00:00
dgp 24be1383da Inline TEOV_RunEnterTraces() so its interface can be redesigned. 2013-08-27 20:03:57 +00:00
dgp 28384139ba Add test for Bug 2486550. 2013-08-27 18:11:53 +00:00
dgp e5b2f21fe9 merge trunk 2013-08-26 18:32:55 +00:00
dkf ccbbb5d288 Unbreak doc; the apropos index entry *must* be one line.
(This is an external constraint forced by the requirement to fit into the standard Unix manual system.)
2013-08-24 09:42:43 +00:00
dgp 2d27ea7088 merge trunk 2013-08-23 16:33:34 +00:00
dgp a33a94ec85 Make sure all Tcl_NR*Eval*() routines do a schedule only. No errors raised. 2013-08-23 16:23:47 +00:00
mig f36f801d24 fix NRE docs 2013-08-23 13:08:15 +00:00
dgp 841e525556 merge trunk 2013-08-23 12:04:12 +00:00
dgp 55b0c17067 Remove complications that no longer server any required purpose. 2013-08-23 05:59:48 +00:00
dgp 993b39c491 merge trunk 2013-08-22 20:41:02 +00:00
dgp 272b2008ad compiler warning 2013-08-22 20:34:30 +00:00
dgp f7cf1b2bae Make Dispatch() the single point for calling a Tcl_ObjCmdProc, and attach
the DTRACE machinery there (one place, not two).
2013-08-22 20:21:15 +00:00
dgp 8173bccfd9 Remove assertion that is not true in some circumstances (--enable-dtrace). 2013-08-22 16:13:29 +00:00
dgp a5b75dfa9a More coroutine tests. 2013-08-22 13:01:31 +00:00
dkf 52b97dd00b Correction to documentation 2013-08-22 08:07:33 +00:00
dgp 987eb68977 merge trunk 2013-08-22 01:13:13 +00:00
dgp f632850eb8 [8ff0cb9fe1] Make Tcl_NREvalObj() (and friends) behave as documented, by
only scheduling evaluation and not doing any of it until the caller routine
returns.  This fixes some serious errors in [coroutine] too.
2013-08-21 19:30:01 +00:00
dgp ed72e77b7d Tidy the code and add a test. 2013-08-21 19:18:28 +00:00
dgp 83d427e824 Don't allocate memory until you know you're going to use it and arrange for
it to be freed.  Leak!
2013-08-21 19:00:17 +00:00
dgp f18c1126d5 Don't use automatic storage to hold the invocation words of oo::define.
That practice doesn't agree with NRE execution.
2013-08-21 18:27:23 +00:00
dgp 62e1b3723e merge trunk 2013-08-21 13:34:19 +00:00
dkf 4d6aaa2e8b [3612422]: Refer to correct part of tclvars(n) rather than page itself. 2013-08-21 10:25:18 +00:00
dkf 6b6685b8fd define tests for this bug; no fix yet 2013-08-21 09:35:50 +00:00
dgp 4bf79aef9b Push out a trial patch for more eyes to see. 2013-08-20 14:00:05 +00:00
dgp 066a4b7b35 Revise execution trace handling to take account of the new reality in
Tcl 8.6 that callers can pre-resolve a cmdPtr for us.  In that case
a re-resolution in the form of another command name lookup isn't the right
thing.
2013-08-19 16:34:10 +00:00
dgp a6f2dee7fb Testing doing away with the NRRunObjProc routine, which looks like a
useless extra bounce on the NRE trampoline.

Normal testing has no problem with it, but debug-enabled testing
triggers an assert failure.

Either it would be good to have a normal test that fails in the conditions
of the assert failure, or it would be good to discover the assert is
asserting something not actually required, and then make the purge.
2013-08-19 15:22:15 +00:00
dgp a7e397556b merge trunk 2013-08-15 20:00:34 +00:00
dgp c084f0ea75 Make sure the errors raised by execution traces become errors raised by the
traced command, as documented. Deletion of the traced command was supressing
that.
2013-08-15 19:59:32 +00:00
dgp 5cdaf0e05b Make sure the errors raised by execution traces become errors raised by
the traced command, as documented.  Deletion of the traced command was
supressing that.
2013-08-15 19:55:26 +00:00
dgp 200e0742b8 merge trunk 2013-08-15 17:43:39 +00:00
dgp fe60431f53 The fix for [3610404] leads to a simplification in the implementation of
forward methods.
2013-08-15 14:05:02 +00:00
dgp 160ba1cb95 merge trunk 2013-08-14 20:31:16 +00:00
dgp 058f0df44d Add several tests to check consistency of stack traces. 2013-08-14 20:20:11 +00:00
dgp ff926f2b01 merge trunk 2013-08-14 19:07:01 +00:00
dgp bee5c35f44 [3610404] Re-resolution of command after enter traces invalidate epoch.
Make sure context is such that correct resolution happens.
2013-08-14 19:01:38 +00:00
dgp 8971b5cdea merge trunk 2013-08-14 18:44:51 +00:00
dgp b2e3f2fa04 merge trunk 2013-08-14 18:00:45 +00:00
dgp 0c1e275cdf [a16752c252] Correct failure to call cmd deletion callbacks. 2013-08-14 17:07:00 +00:00
dgp a2400fbe30 [a16752c252] Correct failure to call cmd deletion callbacks. 2013-08-14 17:02:41 +00:00
dgp 211f7d6466 Arrange for both execution traces and [info frame] to get their pre-subst
source strings from a common routine.
2013-08-14 12:43:22 +00:00
dgp 6dee5b3e07 Consolidate some helper routines. 2013-08-14 12:15:59 +00:00
dgp 9d1f38c3e3 Only schedule leave traces if enter traces complete successfully.
This avoids a memleak, and opens a data slot, so we can pass objc, objv
without the need to copy them into a list value.
2013-08-14 04:13:21 +00:00
dgp 33647e79c8 Use a new flag value TCL_EVAL_SOURCE_IN_FRAME passed in by callers to
determine whether the pre-subst source information in a CmdFrame is to
be used.  This takes the place of numLevels cross checking, so that field
is removed.  Routines are consolidated as well.
2013-08-12 20:00:14 +00:00
dgp f440a6ef41 merge trunk 2013-08-12 15:52:28 +00:00
jan.nijtmans c086de021c Never guess non-existing timezone name "America/Brasilia" on Windows. Reported by Arnulf Wiedemann 2013-08-11 14:42:24 +00:00
jan.nijtmans 97eb71a629 Never guess non-existing timezone name "America/Brasilia" on Windows. Reported by Arnulf Wiedemann 2013-08-11 14:41:10 +00:00
dgp e62b40c808 Arrange for both execution traces and [info frame] to get their pre-subst
source strings from a common routine, with care taken to reduce copying
by that routine.
2013-08-10 05:16:38 +00:00
dgp 234fb04984 Revised GetCommandSource() can (and thus should) return a normal zero
refcount value.
2013-08-09 16:48:30 +00:00
dgp 1b7d424507 Revise GetCommandSource() to return a normal Tcl_Obj value. 2013-08-07 20:27:30 +00:00
dgp 5797625e42 Give (objc, objv) their own ride from enter to leave traces. 2013-08-07 19:45:13 +00:00
dgp 987422a01f Many simplifications to the TIP 280 machinery.
* Removed support for non-NULL invoker when TCL_EVAL_DIRECT requested.
   * Eliminated TCL_EVAL_CTX eval flag.
   * Removed Tcl_Preserve-ability of ContLineLoc pointers.
   * Removed clLoc field of CompileEnv struct.
2013-08-07 17:11:21 +00:00
dgp 5f6b71f3f2 Remove Tcl_Preserve support for ContLineLoc values. It's not needed.
This allows the clLoc field of CompileEnv struct to go away too.
2013-08-07 16:44:03 +00:00
dgp f6f0891fff Test for TclContinuationsGet() usage, and simplifications. 2013-08-07 16:01:53 +00:00
dgp 27c5ada57e Replace potentially memleak creating safety check of a "cannot happen"
condition with an assertion.
2013-08-07 14:41:46 +00:00
dgp 5f2f5b63c3 Add comment stating new limitation on Tcl(NR)EvalObjEx() interface. 2013-08-07 12:44:42 +00:00
dgp 59f7320bdd All use of the evalFlag value TCL_EVAL_CTX is unused by the code and
unreachable by extensions.  This checkin removes all the code supporting
that flag value.

The consequence is that all the calls to TclNREvalObjEx() and its callers
that are currently choosing not to pass the TCL_EVAL_DIRECT flag in when
they pass in a non-NULL invoker will no longer be free to change their
mind.  That might be reason not to adopt this change.
2013-08-06 17:24:40 +00:00
dgp 00546e5e21 The value TCL_LOCATION_EVAL_LIST in the type field of a CmdFrame appears to
exist only for the sake of taking great pains to make sure that pure list
values remain pure list values.

The value of pure list values is no longer what it once was. For a long long
time now, any canonical list values have been equally good.
2013-08-06 16:41:41 +00:00
dgp a63563bd9a Add assertions that will guide and protect more discovery of dead code for elimination. 2013-08-06 16:20:59 +00:00
dgp 1d99884b08 Drop TCL_LOCATION_EVAL_LIST now that it is unused. 2013-08-06 13:30:36 +00:00
dgp 8bd533d76e Eliminate the union that is no longer needed. 2013-08-06 13:20:36 +00:00
dgp 23d61a10c2 Revert the changes that went too far and broke things. 2013-08-06 13:08:54 +00:00
dgp 0ee8df700b The value TCL_LOCATION_EVAL_LIST in the type field of a CmdFrame appears to
exist only for the sake of taking great pains to make sure that pure list
values remain pure list values.

The value of pure list values is no longer what it once was.  For a long long
time now, any canonical list values have been equally good.  This branch
is Work In Progress eliminating the complication of the additional type value.

Currently some minor botches are breaking execution tracing tests.
2013-08-06 04:15:16 +00:00
jan.nijtmans 50a950f2b1 Mark unixforkevent-1.1 nonPortable, until proven on more platforms.
Make sure that when testing for pthread_atfork the thread library is taken into account.
2013-08-05 22:00:58 +00:00
jan.nijtmans c74640849e Mark unixforkevent-1.1 nonPortable, until proven on more platforms. 2013-08-05 21:58:21 +00:00
dkf 861b34625c [3611643fff]: Support TclOO in autoload mechanism. 2013-08-03 15:27:40 +00:00
dkf 0958b92b37 Deal with the elaborate rip-apart-a-metaclass case as well. 2013-08-02 20:19:44 +00:00
dkf 6d9ae4aa16 [9d61624b3d]: Stop crashes when emptying the superclass slot. 2013-08-02 14:58:58 +00:00
dgp 965128fe34 [1905562] [8d2c0da36d] Raise the recursion limits on regexps to allow
existing regexps "in the wild" to continue working with Tcl 8.6.
Latest example comes from DejaGnu.
2013-08-01 19:18:02 +00:00
jan.nijtmans ebc5b27c8c Tcl_InitNotifier: Bug [a0bc856dcd]. Start notifier thread again if we were forked, to solve Rivet bug 55153 2013-08-01 12:54:16 +00:00
jan.nijtmans 3916ce9d4c Tcl_InitNotifier: Bug [a0bc856dcd].
Start notifier thread again if we were forked, to solve Rivet bug 55153
2013-08-01 12:38:04 +00:00
jan.nijtmans 4bd227bc12 Make sure that "string is space \u202f" will continue to return "1", even if in future Unicode this character (NARROW_NO_BREAK_SPACE) will cease to be a space. See: [http://www.unicode.org/review/pri249/].
Don't hardcode "tclWinError.o" for Cygwin
2013-07-29 10:12:12 +00:00
jan.nijtmans 84e92af6dc Make sure that "string is space \u202f" will continue to return "1", even if in future Unicode this character (NARROW_NO_BREAK_SPACE) will cease to be a space. See: [http://www.unicode.org/review/pri249/] 2013-07-29 09:29:16 +00:00
dgp 15ca940ca7 Simplify AuxData access with a macro. 2013-07-27 20:29:42 +00:00
dgp 525bc7c9b5 [6585b21ca8] [regexp {(\w).*?\1} abb] failed to match. Thanks to Tom Lane for passing on the discovery in Postgres. 2013-07-26 13:24:19 +00:00
dgp 6adf3b8c6c [6585b21ca8] [regexp {(\w).*?\1} abb] failed to match.
Thanks to Tom Lane for passing on the discovery in Postgres.
2013-07-26 13:21:30 +00:00
jan.nijtmans 3d14dd6bc9 Move test for pthread_atfork inside SC_ENABLE_THREADS 2013-07-26 09:20:28 +00:00
oehhar 41afeeec2b Fixed test case variable clash with 'folder' 2013-07-25 17:20:02 +00:00
jan.nijtmans 623c1cbe5b rebase 2013-07-25 14:25:47 +00:00
jan.nijtmans 60ef39d24a Move test for pthread_atfork inside SC_ENABLE_THREADS 2013-07-25 14:24:39 +00:00
jan.nijtmans 889454ec06 Make sure that the notifierMutex and notifierCV in a forked child cannot block anything, even though the initialization of the Notifier Thread in the parent is not finished yet. 2013-07-25 08:29:56 +00:00
jan.nijtmans 752ab085d6 rebase 2013-07-25 07:02:59 +00:00
jan.nijtmans c019848148 Put Cygwin's tclWinError.o in PLAT_OBJS, not in DL_OBJS 2013-07-25 06:59:08 +00:00
dgp fd1c7c2fb3 Demonstrate and fix memory leak in Tcl_ParseVar(). 2013-07-24 16:56:59 +00:00
dgp 8f2d19b951 Demonstrate and fix memory leak in Tcl_ParseVar(). 2013-07-24 16:51:04 +00:00
dgp f2bea640bb Mark commands with potential to compile expansion arguments (as [list] does). 2013-07-24 13:58:35 +00:00
dgp d818803502 more disabled code removal 2013-07-24 12:13:01 +00:00
dgp e0437fdf58 Remove outdated, disabled code. 2013-07-23 20:11:00 +00:00
dgp 8163234efd Remove outdated comment. Stack depths are well checked now. 2013-07-23 18:03:39 +00:00
dgp f796ad762c Stop checking stack depth in [catch] compiler.
Stack depth is checked in compiles of *all* Tcl commands/scripts/bodies
in debug builds already.
2013-07-23 18:01:36 +00:00
jan.nijtmans 0185dd6477 rebase 2013-07-23 09:54:05 +00:00
jan.nijtmans 07d10b8a58 Add "testfork" test command. Not used in any test-case yet 2013-07-23 09:27:59 +00:00
jan.nijtmans bc28cd1ac8 Add "testfork" test command. Not used in any test-case yet 2013-07-23 09:07:21 +00:00
jan.nijtmans 9350513d16 Tcl_InitNotifier() call in TestforkObjCmd() is only necessary when pthread_atfork() is not available. 2013-07-22 11:11:10 +00:00
jan.nijtmans 4fb5d04b2f Use pthread_atfork() when available. 2013-07-22 10:57:44 +00:00
jan.nijtmans f287d8cb0f Test-case should pass on Darwin or with non-threaded build as well. 2013-07-22 10:11:05 +00:00
jan.nijtmans 0c2e553e8f Fix bug which hangs iocmd.tf-32.1 2013-07-22 10:10:00 +00:00
oehhar 915c6abe66 Test file tests/unixForkEvent.test added 2013-07-22 08:45:37 +00:00
jan.nijtmans 0070244914 Rebase to core-8-5-branch
Add "testfork" test command to be usable in testcase.
2013-07-21 14:52:57 +00:00
dgp 17ebc3cd20 Rewrite of the TclCompileScript() routine.
Primarily this breaks that large, rather convoluted routine into many
smaller more single-purpose routines for greater clarity.  This also
permits more sharing of function components.  Ensemble compiles now share
the same low level routines as top-level command compiles.  This refactoring
should also have the benefit of easing merging between branches by better
locating patches according to what function or data structure they tweak.

Also in this checkin:
    Minimized calls to Tcl_ResetResult() during compile.
    Several commands compile their detected syntax errors into
	bytecode that reports the syntax error.
    Significant reform to the TIP 280 machinery, including elimination
	of the litInfo hash table.  Its function of finding the index
	of a compiled command in a script from a pc value has been redone
	using the codeDelta information already stored in ByteCode.
2013-07-18 20:27:01 +00:00
dgp 5e9e003379 [assemble] compile syntax error into bytecode reporting syntax error message. 2013-07-18 18:25:24 +00:00
dgp 2aed1acbd1 merge trunk 2013-07-18 15:42:54 +00:00
dgp 81a1a91361 [Bug 1c17fbba5d] Fix -errorinfo from syntax errors so that the error is
not obscured.  Instead highlight it by making it the last character quoted.
2013-07-18 15:05:18 +00:00
oehhar 9a19e4cba0 Start notifier thread again if we were forked, to solve Rivet bug 55153 - RFE [a0bc856dcd] 2013-07-17 16:02:36 +00:00
dgp c2d6c48dd9 Factor out the call to a compileProc into one place used by both ensemble
subcommand compiles and toplevel command compiles in TclCompileScript.
2013-07-17 13:57:23 +00:00
dgp d383707870 Streamline the housekeeping on the operands of INST_START_CMD.
For example, do only incr on success, not incr on attempt + decr on error.
2013-07-16 20:48:37 +00:00
dgp c33f97005c Simplify the ensemble subcommand compile. There's no need to be
crafting synthetic Tcl_Parse and copying tokens.  Some pointer shifts will do.
2013-07-16 17:21:12 +00:00
dgp 3f126895fb Simplify arguments to TclContinuationsEnterDerived(). 2013-07-16 14:52:33 +00:00
dgp d848f30c45 Eliminate the litInfo table and all the code tending to its care and feeding.
The pc -> command index mapping function it provided can be achieved using
other data already in the ByteCode struct.
2013-07-16 14:07:41 +00:00
dgp d860a2c3a4 Build CompileBasicNArgCommand on top of TclCompileInvocation. 2013-07-15 20:16:11 +00:00
dgp 009f2adf3d merge trunk 2013-07-15 19:40:33 +00:00
dgp 5684ad8d94 Possible improvement in light of [86ceb4e2b6]. 2013-07-15 19:09:59 +00:00
dgp 774c402365 Prefer CompileWord() over CompileTokens() when possible. 2013-07-15 17:07:51 +00:00
dgp 740d1811bc Global replace: CompileBody() -> BODY(). 2013-07-12 18:44:15 +00:00
dgp 451ab6927c Tests demonstrating the need for the last two SetLineInformation() calls. 2013-07-12 16:25:51 +00:00
dgp f302557ad5 Revise the CompileWord() and PushVarNameWord() macros to make explicit the
SetLineInformation() that's in each of them.
2013-07-11 23:19:14 +00:00
dgp d061b31460 Have TclMakeEnsemble() set ENSEMBLE_COMPILE at creation, not as a separate
epoch-bumping step.
2013-07-11 17:06:35 +00:00
dgp 783aea7d3a merge trunk 2013-07-11 04:12:01 +00:00
dgp 34c17bad36 Add a test for each call to SetLineInformation() demonstrating the need
for it to be there.  Fixed bugs revealed by the new tests.

What's still missing are more tests demonstrating the need for other
SetLineInformation() calls that are not there yet. ;)
2013-07-11 04:07:39 +00:00
dgp 1e62f5ac76 Remove the (now unused) wlineat arguments. 2013-07-10 03:28:37 +00:00
dgp afad6ffbb4 Revise the litInfo table so that it gets built later (in TclInitByteCodeObj)
from a simpler store of data that can unwind.
2013-07-10 03:17:57 +00:00
dgp d72d5f8b7a Tentative Work In Progress unwinding TIP 280 line information. 2013-07-09 20:37:37 +00:00
dgp c46c774126 Use the TokenAfter() macro. 2013-07-08 23:02:44 +00:00
dgp ba3bf9b61f Use TIP 280 macros. 2013-07-08 22:36:55 +00:00
dgp 82bddf4dca merge trunk 2013-07-08 19:54:50 +00:00
dgp e10479f3d7 Factor out compiling the Command literal. 2013-07-08 19:29:01 +00:00
dgp c10c796a46 Plug memory leak; Break three compilation mechanisms into routines. 2013-07-08 18:08:01 +00:00
dgp 582824087d Move TIP 280 and command extent housekeeping to the periphery. 2013-07-08 15:39:55 +00:00
dgp da4296c06f Defer expansion request detection as much as possible. 2013-07-08 15:24:56 +00:00
dgp 0dec640514 Consolidate the StartExpanding() calls. 2013-07-08 15:00:02 +00:00
dgp d2b490f552 The routines StartExpanding() and EnterCmdWordData() are orthogonal, so it's
ok to reverse the order in which they are called.
2013-07-08 14:31:14 +00:00
dgp 4cfafc3002 merge trunk 2013-07-08 12:55:06 +00:00
dgp 191c6d2137 merge trunk 2013-07-05 19:56:12 +00:00
dgp 7eab500306 merge trunk 2013-07-05 19:54:56 +00:00
dgp 88731d9d93 comment improvements 2013-07-02 10:36:32 +00:00
dgp aec5846c12 More Work In Progress. 2013-07-01 20:58:15 +00:00
dgp 05fb0c0810 More elimination of error message litter to fix [Bug 20a81392ec]. 2013-06-28 02:58:15 +00:00
dgp a47b03577b Stop the compileProc routines leaving behind error messages in interp.
(Nicer way to solve [Bug 20a81392ec].)  Make simplifications in 
TclCompileScript() make possible by the new structure.  Still a work
in progress.
2013-06-27 20:10:41 +00:00
dgp fda71d6d4c merge trunk 2013-06-27 13:12:09 +00:00
dgp 7070acfea1 plug memory leaks 2013-06-27 13:11:53 +00:00
dgp ddd130e532 merge trunk 2013-06-27 12:05:00 +00:00
dgp 324ca57f3d merge trunk 2013-06-26 20:20:23 +00:00
dgp ae7b32a706 Fix bytecode ranges in the cmdMapPtr. still leaky. 2013-06-26 16:06:44 +00:00
dgp 5eecd400b7 A few bug fixes from failing tests; still leaky. 2013-06-26 03:46:54 +00:00
dgp 3f19b90244 merge trunk 2013-06-25 20:22:59 +00:00
dgp 11f1a88c12 Nearly functional now, but leaky and not yet as tidy as I'm hoping for. 2013-06-25 20:22:31 +00:00
dgp 9fd3e86565 merge trunk 2013-06-25 15:01:31 +00:00
dgp dc4782f595 Branch for rewriting TclCompileScript() and related routines, with the
intent to generally simplify and make more readable, as well as find and
eliminate duplication with ensemble machinery and improve mergeability
to other branches.  Work in Progress.  Doesn't work at all right now.
2013-06-25 14:19:39 +00:00
dgp cc984c4e6e merge trunk 2013-04-16 17:34:32 +00:00
dgp 64bf3c8f4a More progress. NR-enable [interp] and [$slave], completely with
invokehidden subcommand.  Test suite passes with no errors.
2013-04-11 21:30:40 +00:00
dgp 064f7e5513 More revisions let multi-interp test case work, but at cost of panics
and segfaults.  Pushing the NRE-envelope.
2013-04-11 19:36:37 +00:00
dgp 6597872335 New internal routine TclNRInvoke() - NR-enabled path through the machinery
behind invokehidden commands.
2013-04-11 14:39:56 +00:00
dgp 5044035ec0 merge trunk 2013-04-11 13:35:41 +00:00
dkf b6b0d1b8dd added some test cases, based on bug report 2013-04-09 20:01:08 +00:00
dgp 1ddb66bfda Use the double-secret iPtr->lookupNsPtr field to get post-enter-trace
re-resolutions of commands done in the right context for oo forwards.
2013-04-09 19:04:04 +00:00
dgp 6b17a1e25a Revise TclNREvalObjv so that pre-resolution of the Command by a caller
does not force suppression of exception handling.  Let those be separable
demands.  Aim is to bring TclObjInvoke*() into the fold.
2013-04-08 18:11:33 +00:00
95 changed files with 2831 additions and 1912 deletions
+81 -9
View File
@@ -1,3 +1,74 @@
A NOTE ON THE CHANGELOG:
Starting in early 2011, Tcl source code has been under the management of
fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline"
view of changes made that is superior in every way to a hand edited log file.
Because of this, many Tcl developers are now out of the habit of maintaining
this log file. You may still find useful things in it, but the Timeline is
a better first place to look now.
============================================================================
2013-09-19 Don Porter <dgp@users.sourceforge.net>
*** 8.6.1 TAGGED FOR RELEASE ***
* generic/tcl.h: Bump version number to 8.6.1.
* library/init.tcl:
* unix/configure.in:
* win/configure.in:
* unix/tcl.spec:
* README:
* unix/configure: autoconf-2.59
* win/configure:
2013-09-19 Donal Fellows <dkf@users.sf.net>
* doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected
description of method search order.
2013-09-18 Donal Fellows <dkf@users.sf.net>
Bump TclOO version to 1.0.1 for release.
2013-09-17 Donal Fellows <dkf@users.sf.net>
* generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]:
Corrected implementation of the core of uuencode handling so that the
line length processing is correctly applied.
***POTENTIAL INCOMPATIBILITY***
Existing code that was using the old versions and working around the
limitations will now need to do far less. The -maxlen option now has
strict limits on the range of supported lengths; this is a limitation
of the format itself.
2013-09-09 Donal Fellows <dkf@users.sf.net>
* generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip
the internal representation of method bodies during cloning in order
to ensure that any bound references to instance variables are removed.
2013-09-01 Donal Fellows <dkf@users.sf.net>
* generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that
whitespace at the end of a string don't cause the decoder to drop the
last decoded byte.
2013-08-03 Donal Fellows <dkf@users.sf.net>
* library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found
by the autoloading mechanism.
2013-08-02 Donal Fellows <dkf@users.sf.net>
* generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop
crashes when emptying the superclass slot, even when doing elaborate
things with metaclasses.
2013-08-01 Harald Oehlmann <oehhar@users.sf.net>
* tclUnixNotify.c (Tcl_InitNotifier): Bug [a0bc856dcd]: Start notifier
thread again if we were forked, to solve Rivet bug 55153.
2013-07-05 Kevin B. Kenny <kennykb@acm.org>
* library/tzdata/Africa/Casablanca:
@@ -20,12 +91,13 @@
2013-06-27 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized
* generic/tclMain.c: encodings.
* generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs
* generic/tclMain.c: initialized encodings.
2013-06-18 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue.
* generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread
issue.
2013-06-17 Jan Nijtmans <nijtmans@users.sf.net>
@@ -137,10 +209,10 @@
* generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit
* generic/tclDecls.h: "long" type. Binary compatibility with win64
requires that all stub entries use 32-bit long's, therefore the
need for various wrapper functions/macros. For Tcl 9 a better
solution is needed, but that cannot be done without introducing
binary incompatibility.
requires that all stub entries use 32-bit long's, therefore the need
for various wrapper functions/macros. For Tcl 9 a better solution is
needed, but that cannot be done without introducing binary
incompatibility.
2013-04-30 Andreas Kupries <andreask@activestate.com>
@@ -158,8 +230,8 @@
* generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj
and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj
and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same,
it only eliminates code duplication.
and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it
only eliminates code duplication.
* generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's
exactly the same as TCL_WIDE_INT_IS_LONG
+1 -1
View File
@@ -1,5 +1,5 @@
README: Tcl
This is the Tcl 8.6.0 source distribution.
This is the Tcl 8.6.1 source distribution.
http://sourceforge.net/projects/tcl/files/Tcl/
You can get any source release of Tcl from the URL above.
+138 -1
View File
@@ -8164,6 +8164,143 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
--- Released 8.6.0, December 20, 2012 --- See ChangeLog for details ---
2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann)
2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd)
2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans)
2013-01-04 (bug fix) memleak in [format] compiler (fellows)
2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points
2013-01-09 (bug fix)[3599395] status line processing (nijtmans)
2013-01-23 (bug fix)[2911139] repair async connection management (fellows)
=> http 2.8.6
2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans)
2013-01-28 (enhancement) improve ensemble bytecode (fellows)
2013-01-30 (enhancement) selected script code improvements (fradin)
=> tcltest 2.3.6
2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries)
=> platform 1.0.11
2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff)
2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin)
2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows)
2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows)
2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans)
=> msgcat 1.5.1
2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick)
2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter)
2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max)
2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane)
2013-03-03 (bug fix)[3606258] major serial port update (english)
2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs
(grathwohl,lane,porter)
2013-03-12 (enhancement) better build support for Debian arch (shadura)
2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans)
2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin)
2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter
2013-04-04 (bug fix) Support URLs with query but no path (max)
=> http 2.8.7
2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas)
2013-04-29 (enhancement) [array set] compile improvement (fellows)
2013-04-30 (enhancement) broaden glibc version detection (kupries)
=> platform 1.0.12
2013-05-06 (platform support) Cygwin64 (nijtmans)
2013-05-15 (enhancement) Improved [list {*}...] compile (fellows)
2013-05-16 (platform support) mingw-4.0 (nijtmans)
2013-05-19 (platform support) FreeBSD updates (cerutti)
2013-05-20 (bug fix)[3613567] access error temp file creation (keene)
2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene)
2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows)
2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann)
=> msgcat 1.5.2
2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter)
2013-06-03 Restored lost performance appending to long strings (elby,porter)
2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows)
2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans)
2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans)
2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang)
2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin)
2013-07-06 tzdata updated to Olson's tzdata2013d (kenny)
2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter)
2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter)
2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane)
2013-07-29 [string is space \u202f] => 1 (nijtmans)
2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans)
2013-08-01 (bug fix)[1905562] RE recursion limit increased to support
reported usage of large expressions (porter)
2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)
2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows)
2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter)
2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter)
2013-08-15 Errors from execution traces become errors of the command (porter)
2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter)
2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter)
2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows)
2013-09-07 (bug fix)[86ceb4] have tm path favor first provider (neumann,porter)
2013-09-09 (bug fix)[3609693] copied object member variable confusion (fellows)
=> TclOO 1.0.1
2013-09-17 (bug fix)[2152292] [binary encode uuencode] corrected (fellows)
2013-09-19 (bug fix)[3487626] segfaults in [dict] compilers (porter)
2013-09-19 (bug fix)[31661d2] mem leak in [lreplace] (ade,porter)
Many optmizations, improvements, and tightened stack management in bytecode.
--- Released 8.6.1, Septemer 20, 2013 --- http://core.tcl.tk/tcl/ for details
+6 -6
View File
@@ -176,16 +176,16 @@ these return options.
The \fB\-errorinfo\fR option holds a stack trace of the
operations that were in progress when an error occurred,
and is intended to be human-readable.
The \fB\-errorcode\fR option holds a list of items that
The \fB\-errorcode\fR option holds a Tcl list of items that
are intended to be machine-readable.
The first item in the \fB\-errorcode\fR value identifies the class of
error that occurred
(e.g. POSIX means an error occurred in a POSIX system call)
(e.g., POSIX means an error occurred in a POSIX system call)
and additional elements hold additional pieces
of information that depend on the class.
See the \fBtclvars\fR manual entry for details on the various
formats for the \fB\-errorcode\fR option used by
Tcl's built-in commands.
See the manual entry on the \fBerrorCode\fR variable for details on the
various formats for the \fB\-errorcode\fR option used by Tcl's built-in
commands.
.PP
The \fB\-errorinfo\fR option value is gradually built up as an
error unwinds through the nested operations.
@@ -307,6 +307,6 @@ so they continue to hold a record of information about the
most recent error seen in an interpreter.
.SH "SEE ALSO"
Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3),
Tcl_SetErrno(3), tclvars(n)
Tcl_SetErrno(3), errorCode(n), errorInfo(n)
.SH KEYWORDS
error, value, value result, stack, trace, variable
+4 -3
View File
@@ -41,8 +41,9 @@ may only be passed to Tcl routines called from the same thread as
the original \fBTcl_CreateInterp\fR call. It is not safe for multiple
threads to pass the same token to Tcl's routines.
The new interpreter is initialized with the built-in Tcl commands
and with the variables documented in the \fBtclvars\fR manual page. To bind in
additional commands, call \fBTcl_CreateCommand\fR.
and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To
bind in additional commands, call \fBTcl_CreateCommand\fR, and to
create additional variables, call \fBTcl_SetVar\fR.
.PP
\fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter
will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have
@@ -144,6 +145,6 @@ should be used to determine when an interpreter is a candidate for deletion
due to inactivity.
.VE 8.6
.SH "SEE ALSO"
Tcl_Preserve(3), Tcl_Release(3), tclvars(n)
Tcl_Preserve(3), Tcl_Release(3)
.SH KEYWORDS
command, create, delete, interpreter
+1 -1
View File
@@ -33,6 +33,6 @@ Tcl-based applications using \fBputenv\fR should redefine it to
\fBTcl_PutEnv\fR so that they will interface properly to the Tcl
runtime.
.SH "SEE ALSO"
tclvars(n)
env(n)
.SH KEYWORDS
environment, variable
+3 -2
View File
@@ -172,8 +172,9 @@ typedef struct {
.PP
The \fIversion\fR field allows for future expansion of the structure, and
should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The
\fIname\fR field provides a human-readable name for the type, and is reserved
for debugging.
\fIname\fR field provides a human-readable name for the type, and is the value
that is exposed via the \fBinfo class methodtype\fR and
\fBinfo object methodtype\fR Tcl commands.
.PP
The \fIcallProc\fR field gives a function that is called when the method is
invoked; it must never be NULL.
+6 -6
View File
@@ -8,7 +8,7 @@
.TH NRE 3 8.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts.
Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -207,7 +207,7 @@ is something like:
.PP
.CS
int
\fITheCmdObjProc\fR(
\fITheCmdOldObjProc\fR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -225,7 +225,7 @@ int
return result;
}
\fBTcl_CreateObjCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, clientData, TheCmdDeleteProc);
\fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc);
.CE
.PP
To enable a command like this one for trampoline-based evaluation,
@@ -255,8 +255,8 @@ int
int objc,
Tcl_Obj *const objv[])
{
return \fBTcl_NRCallObjProc\fR(interp, name,
\fITheCmdNRObjProc\fR, clientData, objc, objv);
return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR,
clientData, objc, objv);
}
.CE
.PP
@@ -317,7 +317,7 @@ and the second is for use when there is already a trampoline in place.
.PP
.CS
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
\fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
+4 -1
View File
@@ -85,6 +85,9 @@ proc bgerror {message} {
}
.CE
.SH "SEE ALSO"
after(n), interp(n), tclvars(n)
after(n), errorCode(n), errorInfo(n), interp(n)
.SH KEYWORDS
background error, reporting
'\" Local Variables:
'\" mode: nroff
'\" End:
+21 -5
View File
@@ -36,6 +36,13 @@ The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert
binary data to or from string encodings such as base64 (used in MIME
messages for example).
.VE 8.6
.PP
Note that other operations on binary data, such as taking a subsequence of it,
getting its length, or reinterpreting it as a string in some encoding, are
done by other Tcl commands (respectively \fBstring range\fR,
\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A
binary string in Tcl is merely one where all the characters it contains are in
the range \eu0000\-\eu00FF.
.SH "BINARY ENCODE AND DECODE"
.VS 8.6
.PP
@@ -95,13 +102,14 @@ between Unix systems and on USENET, but is less common these days, having been
largely superseded by the \fBbase64\fR binary encoding.
.RS
.PP
During encoding, the following options are supported:
'\" This is wrong! The uuencode format had more complexity than this!
During encoding, the following options are supported (though changing them may
produce files that other implementations of decoders cannot process):
.TP
\fB\-maxlen \fIlength\fR
.
Indicates that the output should be split into lines of no more than
\fIlength\fR characters. By default, lines are not split.
\fIlength\fR characters. By default, lines are split every 61 characters, and
this must be in the range 3 to 85 due to limitations in the encoding.
.TP
\fB\-wrapchar \fIcharacter\fR
.
@@ -114,7 +122,11 @@ During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them.
Instructs the decoder to throw an error if it encounters unexpected whitespace
characters. Otherwise it ignores them.
.PP
Note that neither the encoder nor the decoder handle the header and footer of
the uuencode format.
.RE
.VE 8.6
.SH "BINARY FORMAT"
@@ -855,6 +867,7 @@ architectures, use their textual representation (as produced by
.PP
This is a procedure to write a Tcl string to a binary-encoded channel as
UTF-8 data preceded by a length word:
.PP
.CS
proc \fIwriteString\fR {channel string} {
set data [encoding convertto utf-8 $string]
@@ -865,6 +878,7 @@ proc \fIwriteString\fR {channel string} {
.PP
This procedure reads a string from a channel that was written by the
previously presented \fIwriteString\fR procedure:
.PP
.CS
proc \fIreadString\fR {channel} {
if {![\fBbinary scan\fR [read $channel 4] I length]} {
@@ -877,6 +891,7 @@ proc \fIreadString\fR {channel} {
.PP
This converts the contents of a file (named in the variable \fIfilename\fR) to
base64 and prints them:
.PP
.CS
set f [open $filename rb]
set data [read $f]
@@ -884,9 +899,10 @@ close $f
puts [\fBbinary encode\fR base64 \-maxlen 64 $data]
.CE
.SH "SEE ALSO"
format(n), scan(n), tclvars(n)
encoding(n), format(n), scan(n), string(n), tcl_platform(n)
.SH KEYWORDS
binary, format, scan
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
+2 -1
View File
@@ -115,7 +115,8 @@ if { [\fBcatch\fR {open $someFile w} fid] } {
There are more complex examples of \fBcatch\fR usage in the
documentation for the \fBreturn\fR command.
.SH "SEE ALSO"
break(n), continue(n), dict(n), error(n), info(n), return(n), tclvars(n)
break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n),
return(n)
.SH KEYWORDS
catch, error, exception
'\" Local Variables:
+2 -1
View File
@@ -75,7 +75,8 @@ However, the last line would now normally be written without
set var [linsert $var 0 {*}$args]
.CE
.SH "SEE ALSO"
catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n)
catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n),
namespace(n), subst(n), uplevel(n)
.SH KEYWORDS
concatenate, evaluate, script
'\" Local Variables:
+1 -1
View File
@@ -484,7 +484,7 @@ not the effective ones.
.TP
\fBWindows\fR\0\0\0\0
.
The \fbfile owned\fR subcommand currently always reports that the current user
The \fBfile owned\fR subcommand currently always reports that the current user
is the owner of the file, without regard for what the operating system
believes to be true, making an ownership test useless. This issue (#3613671)
may be fixed in a future release of Tcl.
+6 -6
View File
@@ -296,7 +296,6 @@ Returns the name of the library directory in which standard Tcl
scripts are stored.
This is actually the value of the \fBtcl_library\fR
variable and may be changed by setting \fBtcl_library\fR.
See the \fBtclvars\fR manual entry for more information.
.TP
\fBinfo loaded \fR?\fIinterp\fR?
.
@@ -336,8 +335,8 @@ described in \fBOBJECT INTROSPECTION\fR below.
.TP
\fBinfo patchlevel\fR
.
Returns the value of the global variable \fBtcl_patchLevel\fR; see
the \fBtclvars\fR manual entry for more information.
Returns the value of the global variable \fBtcl_patchLevel\fR, which holds
the exact version of the Tcl library by default.
.TP
\fBinfo procs \fR?\fIpattern\fR?
.
@@ -374,8 +373,8 @@ string is returned.
.TP
\fBinfo tclversion\fR
.
Returns the value of the global variable \fBtcl_version\fR; see
the \fBtclvars\fR manual entry for more information.
Returns the value of the global variable \fBtcl_version\fR, which holds the
major and minor version of the Tcl library by default.
.TP
\fBinfo vars\fR ?\fIpattern\fR?
.
@@ -763,8 +762,9 @@ proc getDef {obj method} {
.VE 8.6
.SH "SEE ALSO"
.VS 8.6
global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n)
global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n),
.VE 8.6
tcl_library(n), tcl_patchLevel(n), tcl_version(n)
.SH KEYWORDS
command, information, interpreter, introspection, level, namespace,
.VS 8.6
+7 -3
View File
@@ -262,13 +262,17 @@ If set to any value, then \fBunknown\fR will not attempt to auto-load
any commands.
.TP
\fBauto_path\fR
.
If set, then it must contain a valid Tcl list giving directories to
search during auto-load operations.
search during auto-load operations (including for package index
files when using the default \fBpackage unknown\fR handler).
This variable is initialized during startup to contain, in order:
the directories listed in the \fBTCLLIBPATH\fR environment variable,
the directory named by the \fBtcl_library\fR variable,
the directory named by the \fBtcl_library\fR global variable,
the parent directory of \fBtcl_library\fR,
the directories listed in the \fBtcl_pkgPath\fR variable.
Additional locations to look for files and package indices should
normally be added to this variable using \fBlappend\fR.
.TP
\fBenv(TCL_LIBRARY)\fR
If set, then it specifies the location of the directory containing
@@ -306,7 +310,7 @@ considered to be a word character. On Windows platforms, words are
comprised of any character that is not a space, tab, or newline. Under
Unix, words are comprised of numbers, letters or underscores.
.SH "SEE ALSO"
info(n), re_syntax(n), tclvars(n)
env(n), info(n), re_syntax(n)
.SH KEYWORDS
auto-exec, auto-load, library, unknown, word, whitespace
'\"Local Variables:
+7 -4
View File
@@ -62,14 +62,14 @@ The method chain is cached for future use.
When constructing the method chain, method implementations are searched for in
the following order:
.IP [1]
In the object.
.IP [2]
In the classes mixed into the object, in class traversal order. The list of
mixins is checked in natural order.
.IP [3]
.IP [2]
In the classes mixed into the classes of the object, with sources of mixing in
being searched in class traversal order. Within each class, the list of mixins
is processed in natural order.
.IP [3]
In the object itself.
.IP [4]
In the object's class.
.IP [5]
@@ -77,7 +77,10 @@ In the superclasses of the class, following each superclass in a depth-first
fashion in the natural order of the superclass list.
.PP
Any particular method implementation always comes as \fIlate\fR in the
resulting list of implementations as possible.
resulting list of implementations as possible; this means that if some class,
A, is both mixed into a class, B, and is also a superclass of B, the instances
of B will always treat A as a superclass from the perspective of inheritance.
This is true even when the multiple inheritance is processed indirectly.
.SS FILTERS
.PP
When an object has a list of filter names set upon it, or is an instance of a
+2 -2
View File
@@ -317,8 +317,8 @@ proc myReturn {args} {
}
.CE
.SH "SEE ALSO"
break(n), catch(n), continue(n), dict(n), error(n), proc(n),
source(n), tclvars(n), throw(n), try(n)
break(n), catch(n), continue(n), dict(n), error(n), errorCode(n),
errorInfo(n), proc(n), source(n), throw(n), try(n)
.SH KEYWORDS
break, catch, continue, error, exception, procedure, result, return
.\" Local Variables:
+5 -3
View File
@@ -102,7 +102,9 @@ but also the disadvantage of making it harder to write scripts that
start up uniformly across different versions of Tcl.
.SH "VARIABLES"
.PP
\fBTclsh\fR sets the following Tcl variables:
\fBTclsh\fR sets the following global Tcl variables in addition to those
created by the Tcl library itself (such as \fBenv\fR, which maps
environment variables such as \fBPATH\fR into Tcl):
.TP 15
\fBargc\fR
.
@@ -129,7 +131,7 @@ device), 0 otherwise.
When \fBtclsh\fR is invoked interactively it normally prompts for each
command with
.QW "\fB% \fR" .
You can change the prompt by setting the
You can change the prompt by setting the global
variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable
\fBtcl_prompt1\fR exists then it must consist of a Tcl script
to output a prompt; instead of outputting a prompt \fBtclsh\fR
@@ -142,6 +144,6 @@ incomplete commands.
.PP
See \fBTcl_StandardChannels\fR for more explanations.
.SH "SEE ALSO"
encoding(n), fconfigure(n), tclvars(n)
auto_path(n), encoding(n), env(n), fconfigure(n)
.SH KEYWORDS
application, argument, interpreter, prompt, script file, shell
+1 -1
View File
@@ -40,7 +40,7 @@ The following produces an error that is identical to that produced by
\fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero}
.CE
.SH "SEE ALSO"
catch(n), error(n), return(n), tclvars(n), try(n)
catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n)
.SH "KEYWORDS"
error, exception
'\" Local Variables:
+1 -1
View File
@@ -824,7 +824,7 @@ duptraverse(
* make all normal tests (not reg-33.14) pass.
*/
#ifndef DUPTRAVERSE_MAX_DEPTH
#define DUPTRAVERSE_MAX_DEPTH 700
#define DUPTRAVERSE_MAX_DEPTH 15000
#endif
if (depth++ > DUPTRAVERSE_MAX_DEPTH) {
+1 -6
View File
@@ -504,12 +504,7 @@ complicatedFindLoop(
return er;
}
if ((shorter) ? end == estop : end == begin) {
/*
* No point in trying again.
*/
*coldp = cold;
return REG_NOMATCH;
break;
}
/*
+2 -2
View File
@@ -56,10 +56,10 @@ extern "C" {
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 6
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
#define TCL_RELEASE_SERIAL 0
#define TCL_RELEASE_SERIAL 1
#define TCL_VERSION "8.6"
#define TCL_PATCH_LEVEL "8.6.0"
#define TCL_PATCH_LEVEL "8.6.1"
/*
*----------------------------------------------------------------------------
+30 -11
View File
@@ -930,6 +930,10 @@ TclCompileAssembleCmd(
{
Tcl_Token *tokenPtr; /* Token in the input script */
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
/*
* Make sure that the command has a single arg that is a simple word.
*/
@@ -943,10 +947,23 @@ TclCompileAssembleCmd(
}
/*
* Compile the code and return any error from the compilation.
* Compile the code and convert any error from the compilation into
* bytecode reporting the error;
*/
return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0);
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
Tcl_GetErrorLine(interp)));
envPtr->numCommands = numCommands;
envPtr->codeNext = envPtr->codeStart + offset;
envPtr->currStackDepth = depth;
TclCompileSyntaxError(interp, envPtr);
}
return TCL_OK;
}
/*
@@ -985,8 +1002,6 @@ TclAssembleCode(
const char* instPtr = codePtr;
/* Where to start looking for a line of code */
int instLen; /* Length in bytes of the current line of
* code */
const char* nextPtr; /* Pointer to the end of the line of code */
int bytesLeft = codeLen; /* Number of bytes of source code remaining to
* be parsed */
@@ -1000,10 +1015,6 @@ TclAssembleCode(
*/
status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
instLen = parsePtr->commandSize;
if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
--instLen;
}
/*
* Report errors in the parse.
@@ -1012,7 +1023,7 @@ TclAssembleCode(
if (status != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
instLen);
parsePtr->term + 1 - parsePtr->commandStart);
}
FreeAssemblyEnv(assemEnvPtr);
return TCL_ERROR;
@@ -1032,6 +1043,13 @@ TclAssembleCode(
*/
if (parsePtr->numWords > 0) {
int instLen = parsePtr->commandSize;
/* Length in bytes of the current command */
if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
--instLen;
}
/*
* If tracing, show each line assembled as it happens.
*/
@@ -1107,7 +1125,7 @@ NewAssemblyEnv(
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
assemEnvPtr->cmdLine = envPtr->line;
assemEnvPtr->cmdLine = 1;
assemEnvPtr->clNext = envPtr->clNext;
/*
@@ -2599,6 +2617,7 @@ AllocBB(
bb->minStackDepth = 0;
bb->maxStackDepth = 0;
bb->finalStackDepth = 0;
bb->catchDepth = 0;
bb->enclosingCatch = NULL;
bb->foreignExceptionBase = -1;
bb->foreignExceptionCount = 0;
@@ -3029,7 +3048,7 @@ ResolveJumpTableTargets(
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData;
realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex);
realJumpHashPtr = &realJumpTablePtr->hashTable;
/*
+346 -467
View File
File diff suppressed because it is too large Load Diff
+251 -55
View File
@@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData,
static int BinaryEncode64(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int BinaryDecodeUu(ClientData clientData,
static int BinaryDecode64(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int BinaryDecode64(ClientData clientData,
static int BinaryEncodeUu(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int BinaryDecodeUu(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -139,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = {
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
static const EnsembleImplMap encodeMap[] = {
{ "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 },
{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 },
{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 },
{ "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{ "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 },
{ "base64", BinaryEncode64, NULL, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
static const EnsembleImplMap decodeMap[] = {
@@ -2312,7 +2315,6 @@ BinaryEncodeHex(
Tcl_Obj *resultObj = NULL;
unsigned char *data = NULL;
unsigned char *cursor = NULL;
const char *digits = clientData;
int offset = 0, count = 0;
if (objc != 2) {
@@ -2324,8 +2326,8 @@ BinaryEncodeHex(
data = Tcl_GetByteArrayFromObj(objv[1], &count);
cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
for (offset = 0; offset < count; ++offset) {
*cursor++ = digits[((data[offset] >> 4) & 0x0f)];
*cursor++ = digits[(data[offset] & 0x0f)];
*cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)];
*cursor++ = HexDigits[(data[offset] & 0x0f)];
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2386,29 +2388,32 @@ BinaryDecodeHex(
while (data < dataend) {
value = 0;
for (i=0 ; i<2 ; i++) {
if (data < dataend) {
c = *data++;
if (!isxdigit((int) c)) {
if (strict || !isspace(c)) {
goto badChar;
}
i--;
continue;
}
if (data >= dataend) {
value <<= 4;
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xf);
} else {
value <<= 4;
cut++;
break;
}
c = *data++;
if (!isxdigit((int) c)) {
if (strict || !isspace(c)) {
goto badChar;
}
i--;
continue;
}
value <<= 4;
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xf);
}
if (i < 2) {
cut++;
}
*cursor++ = UCHAR(value);
value = 0;
@@ -2436,7 +2441,7 @@ BinaryDecodeHex(
* This implements a generic 6 bit binary encoding. Input is broken into
* 6 bit chunks and a lookup table passed in via clientData is used to
* turn these values into output characters. This is used to implement
* base64 and uuencode binary encodings.
* base64 binary encodings.
*
* Results:
* Interp result set to an encoded byte array object
@@ -2472,7 +2477,6 @@ BinaryEncode64(
{
Tcl_Obj *resultObj;
unsigned char *data, *cursor, *limit;
const char *digits = clientData;
int maxlen = 0;
const char *wrapchar = "\n";
int wrapcharlen = 1;
@@ -2495,6 +2499,12 @@ BinaryEncode64(
if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) {
return TCL_ERROR;
}
if (maxlen < 0) {
Tcl_SetResult(interp, "line length out of range", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen);
@@ -2525,17 +2535,17 @@ BinaryEncode64(
for (i = 0; i < 3 && offset+i < count; ++i) {
d[i] = data[offset + i];
}
OUTPUT(digits[d[0] >> 2]);
OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
OUTPUT(B64Digits[d[0] >> 2]);
OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
if (offset+1 < count) {
OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
} else {
OUTPUT(digits[64]);
OUTPUT(B64Digits[64]);
}
if (offset+2 < count) {
OUTPUT(digits[d[2] & 0x3f]);
OUTPUT(B64Digits[d[2] & 0x3f]);
} else {
OUTPUT(digits[64]);
OUTPUT(B64Digits[64]);
}
}
}
@@ -2544,6 +2554,124 @@ BinaryEncode64(
}
#undef OUTPUT
/*
*----------------------------------------------------------------------
*
* BinaryEncodeUu --
*
* This implements the uuencode binary encoding. Input is broken into 6
* bit chunks and a lookup table is used to turn these values into output
* characters. This differs from the generic code above in that line
* lengths are also encoded.
*
* Results:
* Interp result set to an encoded byte array object
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryEncodeUu(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
int offset, count, rawLength, n, i, j, bits, index;
int lineLength = 61;
const unsigned char SingleNewline[] = { (unsigned char) '\n' };
const unsigned char *wrapchar = SingleNewline;
int wrapcharlen = sizeof(SingleNewline);
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc%2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-maxlen len? ?-wrapchar char? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) {
return TCL_ERROR;
}
if (lineLength < 3 || lineLength > 85) {
Tcl_SetResult(interp, "line length out of range", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen);
break;
}
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
*/
resultObj = Tcl_NewObj();
offset = 0;
data = Tcl_GetByteArrayFromObj(objv[objc-1], &count);
rawLength = (lineLength - 1) * 3 / 4;
start = cursor = Tcl_SetByteArrayLength(resultObj,
(lineLength + wrapcharlen) *
((count + (rawLength - 1)) / rawLength));
n = bits = 0;
/*
* Encode the data. Each output line first has the length of raw data
* encoded by the output line described in it by one encoded byte, then
* the encoded data follows (encoding each 6 bits as one character).
* Encoded lines are always terminated by a newline.
*/
while (offset < count) {
int lineLen = count - offset;
if (lineLen > rawLength) {
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i=0 ; i<lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
*cursor++ = UueDigits[(n >> (bits-6)) & 0x3f];
}
}
if (bits > 0) {
n <<= 8;
*cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f];
bits = 0;
}
for (j=0 ; j<wrapcharlen ; ++j) {
*cursor++ = wrapchar[j];
}
}
/*
* Fix the length of the output bytearray.
*/
Tcl_SetByteArrayLength(resultObj, cursor-start);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -2570,8 +2698,8 @@ BinaryDecodeUu(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
int i, index, size, count = 0, cut = 0, strict = 0;
char c;
int i, index, size, count = 0, strict = 0, lineLen;
unsigned char c;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2597,44 +2725,112 @@ BinaryDecodeUu(
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
lineLen = -1;
/*
* The decoding loop. First, we get the length of line (strictly, the
* number of data bytes we expect to generate from the line) we're
* processing this time round if it is not already known (i.e., when the
* lineLen variable is set to the magic value, -1).
*/
while (data < dataend) {
char d[4] = {0, 0, 0, 0};
if (lineLen < 0) {
c = *data++;
if (c < 32 || c > 96) {
if (strict || !isspace(c)) {
goto badUu;
}
i--;
continue;
}
lineLen = (c - 32) & 0x3f;
}
/*
* Now we read a four-character grouping.
*/
for (i=0 ; i<4 ; i++) {
if (data < dataend) {
d[i] = c = *data++;
if (c < 33 || c > 96) {
if (strict || !isspace(UCHAR(c))) {
goto badUu;
if (c < 32 || c > 96) {
if (strict) {
if (!isspace(c)) {
goto badUu;
} else if (c == '\n') {
goto shortUu;
}
}
i--;
continue;
}
} else {
cut++;
}
}
if (cut > 3) {
cut = 3;
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
*cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
| (((d[1] - 0x20) & 0x3f) >> 4);
if (--lineLen > 0) {
*cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
| (((d[2] - 0x20) & 0x3f) >> 2);
if (--lineLen > 0) {
*cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
| (((d[3] - 0x20) & 0x3f));
lineLen--;
}
}
}
/*
* If we've reached the end of the line, skip until we process a
* newline.
*/
if (lineLen == 0 && data < dataend) {
lineLen = -1;
do {
c = *data++;
if (c == '\n') {
break;
} else if (c >= 32 && c <= 96) {
data--;
break;
} else if (strict || !isspace(c)) {
goto badUu;
}
} while (data < dataend);
}
*cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
| (((d[1] - 0x20) & 0x3f) >> 4);
*cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
| (((d[2] - 0x20) & 0x3f) >> 2);
*cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
| (((d[3] - 0x20) & 0x3f));
}
if (cut > size) {
cut = size;
/*
* Sanity check, clean up and finish.
*/
if (lineLen > 0 && strict) {
goto shortUu;
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetByteArrayLength(resultObj, cursor - begin);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" at position %d",
c, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
+8 -26
View File
@@ -1302,28 +1302,12 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
framePtr->cmd.str.len));
break;
case TCL_LOCATION_EVAL_LIST:
/*
* List optimized evaluation. Type, line, cmd, the latter through
* listPtr, possibly a frame.
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
ADD_PAIR("line", Tcl_NewIntObj(1));
/*
* We put a duplicate of the command list obj into the result to
* ensure that the 'pure List'-property of the command itself is not
* destroyed. Otherwise the query here would disable the list
* optimization path in Tcl_EvalObjEx.
*/
ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr));
if (framePtr->line) {
ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
} else {
ADD_PAIR("line", Tcl_NewIntObj(1));
}
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PREBC:
@@ -1371,8 +1355,7 @@ TclInfoFrame(
Tcl_DecrRefCount(fPtr->data.eval.path);
}
ADD_PAIR("cmd",
Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL));
TclStackFree(interp, fPtr);
break;
}
@@ -1391,8 +1374,7 @@ TclInfoFrame(
* the result list object.
*/
ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
framePtr->cmd.str.len));
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PROC:
+44 -66
View File
@@ -87,6 +87,7 @@ TclCompileAppendCmd(
int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
@@ -544,7 +545,6 @@ TclCompileCatchCmd(
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
int resultIndex, optsIndex, range;
int initStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
/*
@@ -610,12 +610,12 @@ TclCompileCatchCmd(
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
SetLineInformation(1);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, cmdTokenPtr, interp);
BODY(cmdTokenPtr, 1);
} else {
SetLineInformation(1);
CompileTokens(envPtr, cmdTokenPtr, interp);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
@@ -742,15 +742,6 @@ TclCompileCatchCmd(
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;
}
@@ -848,7 +839,7 @@ TclCompileDictSetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int numWords, i, dictVarIndex;
int i, dictVarIndex;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
@@ -877,8 +868,7 @@ TclCompileDictSetCmd(
*/
tokenPtr = TokenAfter(varTokenPtr);
numWords = parsePtr->numWords-1;
for (i=1 ; i<numWords ; i++) {
for (i=2 ; i< parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
@@ -887,7 +877,7 @@ TclCompileDictSetCmd(
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
@@ -959,7 +949,7 @@ TclCompileDictIncrCmd(
* Emit the key and the code to actually do the increment.
*/
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, keyTokenPtr, interp, 2);
TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
@@ -975,7 +965,7 @@ TclCompileDictGetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int numWords, i;
int i;
DefineLineInformation; /* TIP #280 */
/*
@@ -983,21 +973,21 @@ TclCompileDictGetCmd(
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
numWords = parsePtr->numWords-1;
/*
* Only compile this because we need INST_DICT_GET anyway.
*/
for (i=0 ; i<numWords ; i++) {
for (i=1 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -1012,7 +1002,7 @@ TclCompileDictExistsCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int numWords, i;
int i;
DefineLineInformation; /* TIP #280 */
/*
@@ -1020,21 +1010,21 @@ TclCompileDictExistsCmd(
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
numWords = parsePtr->numWords-1;
/*
* Now we do the code generation.
*/
for (i=0 ; i<numWords ; i++) {
for (i=1 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -1057,6 +1047,7 @@ TclCompileDictUnsetCmd(
* compile to bytecode.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -1202,6 +1193,7 @@ TclCompileDictMergeCmd(
* argument, the only thing to do is to verify the dict-ness.
*/
/* TODO: Consider support for compiling expanded args. (less likely) */
if (parsePtr->numWords < 2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
@@ -1431,7 +1423,7 @@ CompileDictEachCmd(
* this point.
*/
CompileWord(envPtr, dictTokenPtr, interp, 3);
CompileWord(envPtr, dictTokenPtr, interp, 2);
/*
* Now we catch errors from here on so that we can finalize the search
@@ -1467,8 +1459,7 @@ CompileDictEachCmd(
* Compile the loop body itself. It should be stack-neutral.
*/
SetLineInformation(3);
CompileBody(envPtr, bodyTokenPtr, interp);
BODY(bodyTokenPtr, 3);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
TclEmitInstInt4(INST_OVER, 1, envPtr);
@@ -1641,7 +1632,7 @@ TclCompileDictUpdateCmd(
infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
for (i=0 ; i<numVars ; i++) {
CompileWord(envPtr, keyTokenPtrs[i], interp, i);
CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
}
TclEmitInstInt4( INST_LIST, numVars, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
@@ -1651,8 +1642,7 @@ TclCompileDictUpdateCmd(
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
SetLineInformation(parsePtr->numWords - 1);
CompileBody(envPtr, bodyTokenPtr, interp);
BODY(bodyTokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -1724,6 +1714,7 @@ TclCompileDictAppendCmd(
* speed quite so much. ;-)
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords<4 || parsePtr->numWords>100) {
return TCL_ERROR;
}
@@ -1776,6 +1767,8 @@ TclCompileDictLappendCmd(
* There must be three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
/* Probably not. Why is INST_DICT_LAPPEND limited to one value? */
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
@@ -1796,8 +1789,8 @@ TclCompileDictLappendCmd(
* Issue the implementation.
*/
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
CompileWord(envPtr, keyTokenPtr, interp, 2);
CompileWord(envPtr, valueTokenPtr, interp, 3);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
return TCL_OK;
}
@@ -1822,6 +1815,7 @@ TclCompileDictWithCmd(
* There must be at least one argument after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -1881,7 +1875,7 @@ TclCompileDictWithCmd(
tokenPtr = TokenAfter(varTokenPtr);
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i-1);
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
@@ -1908,7 +1902,7 @@ TclCompileDictWithCmd(
tokenPtr = varTokenPtr;
for (i=1 ; i<parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i-1);
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
@@ -1922,7 +1916,7 @@ TclCompileDictWithCmd(
* Case: Direct dict in non-simple var with empty body.
*/
CompileWord(envPtr, varTokenPtr, interp, 0);
CompileWord(envPtr, varTokenPtr, interp, 1);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LOAD_STK, envPtr);
PushStringLiteral(envPtr, "");
@@ -1957,13 +1951,13 @@ TclCompileDictWithCmd(
*/
if (dictVar == -1) {
CompileWord(envPtr, varTokenPtr, interp, 0);
CompileWord(envPtr, varTokenPtr, interp, 1);
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
}
tokenPtr = TokenAfter(varTokenPtr);
if (gotPath) {
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i-1);
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr);
@@ -1992,8 +1986,7 @@ TclCompileDictWithCmd(
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
SetLineInformation(parsePtr->numWords-1);
CompileBody(envPtr, tokenPtr, interp);
BODY(tokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -2232,7 +2225,7 @@ TclCompileForCmd(
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
DefineLineInformation; /* TIP #280 */
@@ -2268,8 +2261,7 @@ TclCompileForCmd(
* Inline compile the initial command.
*/
SetLineInformation(1);
CompileBody(envPtr, startTokenPtr, interp);
BODY(startTokenPtr, 1);
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -2292,8 +2284,7 @@ TclCompileForCmd(
bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
SetLineInformation(4);
CompileBody(envPtr, bodyTokenPtr, interp);
BODY(bodyTokenPtr, 4);
ExceptionRangeEnds(envPtr, bodyRange);
TclEmitOpcode(INST_POP, envPtr);
@@ -2306,8 +2297,7 @@ TclCompileForCmd(
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
SetLineInformation(3);
CompileBody(envPtr, nextTokenPtr, interp);
BODY(nextTokenPtr, 3);
ExceptionRangeEnds(envPtr, nextRange);
TclEmitOpcode(INST_POP, envPtr);
@@ -2316,13 +2306,9 @@ TclCompileForCmd(
* terminates the for.
*/
testCodeOffset = CurrentOffset(envPtr);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
testCodeOffset += 3;
}
SetLineInformation(2);
@@ -2542,7 +2528,7 @@ CompileEachloopCmd(
Tcl_DStringInit(&varList);
TclDStringAppendToken(&varList, &tokenPtr[1]);
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
@@ -2644,8 +2630,7 @@ CompileEachloopCmd(
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
SetLineInformation(i);
CompileTokens(envPtr, tokenPtr, interp);
CompileWord(envPtr, tokenPtr, interp, i);
tempVar = (firstValueTemp + loopIndex);
Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
@@ -2682,9 +2667,8 @@ CompileEachloopCmd(
* Inline compile the loop body.
*/
SetLineInformation(numWords - 1);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
BODY(bodyTokenPtr, numWords - 1);
ExceptionRangeEnds(envPtr, range);
if (collect == TCL_EACH_COLLECT) {
@@ -2986,7 +2970,8 @@ TclCompileFormatCmd(
ckfree(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
return TCL_ERROR;
TclCompileSyntaxError(interp, envPtr);
return TCL_OK;
}
/*
@@ -3164,10 +3149,7 @@ TclPushVarName(
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *isScalarPtr, /* Must not be NULL. */
int line, /* Line the token starts on. */
int *clNext) /* Reference to offset of next hidden cont.
* line. */
int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
const char *name, *elName;
@@ -3347,8 +3329,6 @@ TclPushVarName(
if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
envPtr->line = line;
envPtr->clNext = clNext;
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
envPtr);
} else {
@@ -3360,8 +3340,6 @@ TclPushVarName(
* The var name isn't simple: compile and push it.
*/
envPtr->line = line;
envPtr->clNext = clNext;
CompileTokens(envPtr, varTokenPtr, interp);
}
+28 -19
View File
@@ -60,6 +60,7 @@ TclCompileGlobalCmd(
int localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
@@ -84,14 +85,17 @@ TclCompileGlobalCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
if (localIndex < 0) {
return TCL_ERROR;
}
CompileWord(envPtr, varTokenPtr, interp, 1);
/* TODO: Consider what value can pass throug the
* IndexTailVarIfKnown() screen. Full CompileWord()
* likely does not apply here. Push known value instead. */
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
@@ -264,8 +268,7 @@ TclCompileIfCmd(
*/
if (compileScripts) {
SetLineInformation(wordIdx);
CompileBody(envPtr, tokenPtr, interp);
BODY(tokenPtr, wordIdx);
}
if (realCond) {
@@ -345,8 +348,7 @@ TclCompileIfCmd(
* Compile the else command body.
*/
SetLineInformation(wordIdx);
CompileBody(envPtr, tokenPtr, interp);
BODY(tokenPtr, wordIdx);
}
/*
@@ -585,6 +587,7 @@ TclCompileInfoCommandsCmd(
* that the result needs to be list-ified.
*/
/* TODO: Just push the known value */
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
TclEmitOpcode( INST_DUP, envPtr);
@@ -701,8 +704,7 @@ TclCompileInfoLevelCmd(
* list of arguments.
*/
SetLineInformation(1);
CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1);
TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
}
return TCL_OK;
@@ -823,6 +825,7 @@ TclCompileLappendCmd(
return TCL_ERROR;
}
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
@@ -1064,6 +1067,7 @@ TclCompileLindexCmd(
* Quit if too few args.
*/
/* TODO: Consider support for compiling expanded args. */
if (numWords <= 1) {
return TCL_ERROR;
}
@@ -1586,6 +1590,7 @@ TclCompileLsetCmd(
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
/*
* Fail at run time, not in compilation.
@@ -1898,13 +1903,13 @@ TclCompileNamespaceUpvarCmd(
*/
localTokenPtr = tokenPtr;
for (i=3; i<=numWords; i+=2) {
for (i=2; i<numWords; i+=2) {
otherTokenPtr = TokenAfter(localTokenPtr);
localTokenPtr = TokenAfter(otherTokenPtr);
CompileWord(envPtr, otherTokenPtr, interp, 1);
CompileWord(envPtr, otherTokenPtr, interp, i);
PushVarNameWord(interp, localTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
&localIndex, &isScalar, i+1);
if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
@@ -2534,6 +2539,7 @@ TclCompileSyntaxError(
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
}
/*
@@ -2566,16 +2572,14 @@ TclCompileUpvarCmd(
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
Tcl_Obj *objPtr = Tcl_NewObj();
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
numWords = parsePtr->numWords;
if (numWords < 3) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
@@ -2583,6 +2587,7 @@ TclCompileUpvarCmd(
* Push the frame index if it is known at compile time
*/
objPtr = Tcl_NewObj();
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
CallFrame *framePtr;
@@ -2601,16 +2606,17 @@ TclCompileUpvarCmd(
if (numWords%2) {
return TCL_ERROR;
}
/* TODO: Push the known value instead? */
CompileWord(envPtr, tokenPtr, interp, 1);
otherTokenPtr = TokenAfter(tokenPtr);
i = 4;
i = 2;
} else {
if (!(numWords%2)) {
return TCL_ERROR;
}
PushStringLiteral(envPtr, "1");
otherTokenPtr = tokenPtr;
i = 3;
i = 1;
}
} else {
Tcl_DecrRefCount(objPtr);
@@ -2623,12 +2629,12 @@ TclCompileUpvarCmd(
* be called at runtime.
*/
for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
localTokenPtr = TokenAfter(otherTokenPtr);
CompileWord(envPtr, otherTokenPtr, interp, 1);
CompileWord(envPtr, otherTokenPtr, interp, i);
PushVarNameWord(interp, localTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
&localIndex, &isScalar, i+1);
if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
@@ -2704,6 +2710,9 @@ TclCompileVariableCmd(
return TCL_ERROR;
}
/* TODO: Consider what value can pass throug the
* IndexTailVarIfKnown() screen. Full CompileWord()
* likely does not apply here. Push known value instead. */
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
+78 -33
View File
@@ -85,8 +85,6 @@ const AuxDataType tclJumptableInfoType = {
TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define BODY(token,index) \
SetLineInformation((index));CompileBody(envPtr,(token),interp)
#define PUSH(str) \
PushStringLiteral(envPtr, str)
#define JUMP4(name,var) \
@@ -745,6 +743,9 @@ TclSubstCompile(
Tcl_InterpState state = NULL;
TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
if (state != NULL) {
Tcl_ResetResult(interp);
}
/*
* Tricky point! If the first token does not result in a *guaranteed* push
@@ -990,9 +991,6 @@ TclSubstCompile(
* Instructions are added to envPtr to execute the "switch" command at
* runtime.
*
* FIXME:
* Stack depths are probably not calculated correctly.
*
*----------------------------------------------------------------------
*/
@@ -1284,8 +1282,7 @@ TclCompileSwitchCmd(
*/
/* Both methods push the value to match against onto the stack. */
SetLineInformation(valueIndex);
CompileTokens(envPtr, valueTokenPtr, interp);
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
@@ -1499,7 +1496,7 @@ IssueSwitchChainedTests(
}
/*
* Now do the actual compilation. Note that we do not use CompileBody
* Now do the actual compilation. Note that we do not use BODY()
* because we may have synthesized the tokens in a non-standard
* pattern.
*/
@@ -1867,6 +1864,7 @@ TclCompileTailcallCmd(
}
/* make room for the nsObjPtr */
/* TODO: Doesn't this have to be a known value? */
CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
@@ -2817,38 +2815,81 @@ TclCompileUnsetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int isScalar, localIndex, numWords, flags, i;
Tcl_Obj *leadingWord;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords-1;
flags = 1;
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
leadingWord = Tcl_NewObj();
if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
int len;
const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
/* TODO: Consider support for compiling expanded args. */
if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
varTokenPtr = TokenAfter(varTokenPtr);
numWords--;
} else if (len == 2 && !strncmp("--", bytes, 2)) {
varTokenPtr = TokenAfter(varTokenPtr);
numWords--;
/*
* Verify that all words - except the first non-option one - are known at
* compile time so that we can handle them without needing to do a nasty
* push/rotate. [Bug 3970f54c4e]
*/
for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
Tcl_Obj *leadingWord = Tcl_NewObj();
varTokenPtr = TokenAfter(varTokenPtr);
if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
TclDecrRefCount(leadingWord);
/*
* We can tolerate non-trivial substitutions in the first variable
* to be unset. If a '--' or '-nocomplain' was present, anything
* goes in that one place! (All subsequent variable names must be
* constants since we don't want to have to push them all first.)
*/
if (varCount == 0) {
if (haveFlags) {
continue;
}
/*
* In fact, we're OK as long as we're the first argument *and*
* we provably don't start with a '-'. If that is true, then
* even if everything else is varying, we still can't be a
* flag. Otherwise we'll spill to runtime to place a limit on
* the trickiness.
*/
if (varTokenPtr->type == TCL_TOKEN_WORD
&& varTokenPtr[1].type == TCL_TOKEN_TEXT
&& varTokenPtr[1].size > 0
&& varTokenPtr[1].start[0] != '-') {
continue;
}
}
return TCL_ERROR;
}
} else {
/*
* Cannot guarantee that the first word is not '-nocomplain' at
* evaluation with reasonable effort, so spill to interpreted version.
*/
if (i == 1) {
const char *bytes;
int len;
bytes = Tcl_GetStringFromObj(leadingWord, &len);
if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags = 1;
} else if (len == 2 && !strncmp("--", bytes, 2)) {
haveFlags = 1;
} else {
varCount++;
}
} else {
varCount++;
}
TclDecrRefCount(leadingWord);
return TCL_ERROR;
}
TclDecrRefCount(leadingWord);
for (i=0 ; i<numWords ; i++) {
/*
* Issue instructions to unset each of the named variables.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (haveFlags) {
varTokenPtr = TokenAfter(varTokenPtr);
}
for (i=1+haveFlags ; i<parsePtr->numWords ; i++) {
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
@@ -2858,7 +2899,7 @@ TclCompileUnsetCmd(
*/
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
&localIndex, &isScalar, i);
/*
* Emit instructions to unset the variable.
@@ -3176,6 +3217,7 @@ CompileAssociativeBinaryOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
/* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
@@ -3259,6 +3301,7 @@ CompileComparisonOpCmd(
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
PUSH("1");
} else if (parsePtr->numWords == 3) {
@@ -3596,6 +3639,7 @@ TclCompileMinusOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
@@ -3641,6 +3685,7 @@ TclCompileDivOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
+39 -62
View File
@@ -490,13 +490,6 @@ typedef struct JumpList {
JumpFixup jump; /* Pass this argument to matching calls of
* TclEmitForwardJump() and
* TclFixupForwardJump(). */
int depth; /* Remember the currStackDepth of the
* CompileEnv here. */
int offset; /* Data used to compute jump lengths to pass
* to TclFixupForwardJump() */
int convert; /* Temporary storage used to compute whether
* numeric conversion will be needed following
* the operator we're compiling. */
struct JumpList *next; /* Point to next item on the stack */
} JumpList;
@@ -2261,30 +2254,8 @@ CompileExprTree(
if (nodePtr->mark == MARK_LEFT) {
next = nodePtr->left;
switch (nodePtr->lexeme) {
case QUESTION:
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
jumpPtr->depth = envPtr->currStackDepth;
if (nodePtr->lexeme == QUESTION) {
convert = 1;
break;
case AND:
case OR:
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
jumpPtr->depth = envPtr->currStackDepth;
break;
}
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
@@ -2317,25 +2288,35 @@ CompileExprTree(
break;
}
case QUESTION:
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
CLANG_ASSERT(jumpPtr);
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpPtr->next->jump);
envPtr->currStackDepth = jumpPtr->depth;
jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
jumpPtr->convert = convert;
&jumpPtr->jump);
TclAdjustStackDepth(-1, envPtr);
if (convert) {
jumpPtr->jump.jumpType = TCL_TRUE_JUMP;
}
convert = 1;
break;
case AND:
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case OR:
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump);
newJump = TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump);
break;
}
} else {
int pc1, pc2, target;
switch (nodePtr->lexeme) {
case START:
case QUESTION:
@@ -2375,18 +2356,20 @@ CompileExprTree(
break;
case COLON:
CLANG_ASSERT(jumpPtr);
if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump,
(envPtr->codeNext - envPtr->codeStart)
- jumpPtr->next->jump.codeOffset, 127)) {
jumpPtr->offset += 3;
if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) {
jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP;
convert = 1;
}
target = jumpPtr->jump.codeOffset + 2;
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
target += 3;
}
TclFixupForwardJump(envPtr, &jumpPtr->jump,
jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
convert |= jumpPtr->convert;
envPtr->currStackDepth = jumpPtr->depth + 1;
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
TclFixupForwardJump(envPtr, &jumpPtr->jump,
target - jumpPtr->jump.codeOffset, 127);
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
@@ -2394,30 +2377,24 @@ CompileExprTree(
case AND:
case OR:
CLANG_ASSERT(jumpPtr);
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
? TCL_FALSE_JUMP : TCL_TRUE_JUMP,
&jumpPtr->next->jump);
pc1 = CurrentOffset(envPtr);
TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
: INST_JUMP_TRUE1, 0, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpPtr->next->next->jump);
pc2 = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1,
envPtr->codeStart + pc1 + 1);
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
jumpPtr->next->next->jump.codeOffset += 3;
pc2 += 3;
}
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump,
127);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
envPtr->codeStart + pc2 + 1);
convert = 0;
envPtr->currStackDepth = jumpPtr->depth + 1;
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
+416 -547
View File
File diff suppressed because it is too large Load Diff
+28 -28
View File
@@ -193,13 +193,6 @@ typedef struct ExtCmdLoc {
ECL *loc; /* Command word locations (lines). */
int nloc; /* Number of allocated entries in 'loc'. */
int nuloc; /* Number of used entries in 'loc'. */
Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the
* information accessible per command and
* argument, not per whole bytecode. Value is
* index of command in 'loc', giving us the
* literals to associate with line information
* as command argument, see
* TclArgumentBCEnter() */
} ExtCmdLoc;
/*
@@ -372,10 +365,6 @@ typedef struct CompileEnv {
* encountered that have not yet been paired
* with a corresponding
* INST_INVOKE_EXPANDED. */
ContLineLoc *clLoc; /* If not NULL, the table holding the
* locations of the invisible continuation
* lines in the input script, to adjust the
* line counter. */
int *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
@@ -991,6 +980,9 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
CompileEnv *envPtr);
MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
@@ -1002,6 +994,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp,
Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp,
const char *script, int numBytes,
CompileEnv *envPtr);
@@ -1074,7 +1069,7 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile,
MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr, int line, int *clNext);
int *isScalarPtr);
MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr,
char *bytes, int length, int flags);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -1114,6 +1109,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
*----------------------------------------------------------------
*/
/*
* Simplified form to access AuxData.
*
* ClientData TclFetchAuxData(CompileEng *envPtr, int index);
*/
#define TclFetchAuxData(envPtr, index) \
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
@@ -1407,16 +1411,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
/*
* Convenience macro for use when compiling bodies of commands. The ANSI C
* "prototype" for this macro is:
* Convenience macros for use when compiling bodies of commands. The ANSI C
* "prototype" for these macros are:
*
* static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
* Tcl_Interp *interp);
* static void BODY(Tcl_Token *tokenPtr, int word);
*/
#define CompileBody(envPtr, tokenPtr, interp) \
TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr))
#define BODY(tokenPtr, word) \
SetLineInformation((word)); \
TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \
envPtr)
/*
* Convenience macro for use when compiling tokens to be pushed. The ANSI C
@@ -1515,13 +1519,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
#define CompileWord(envPtr, tokenPtr, interp, word) \
if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
(tokenPtr)[1].size), (envPtr)); \
PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \
} else { \
envPtr->line = mapPtr->loc[eclIndex].line[word]; \
envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr)); \
SetLineInformation((word)); \
CompileTokens((envPtr), (tokenPtr), (interp)); \
}
/*
@@ -1542,9 +1543,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
#define PushVarNameWord(i,v,e,f,l,sc,word) \
TclPushVarName(i,v,e,f,l,sc, \
mapPtr->loc[eclIndex].line[(word)], \
mapPtr->loc[eclIndex].next[(word)])
SetLineInformation(word); \
TclPushVarName(i,v,e,f,l,sc)
/*
* Often want to issue one of two versions of an instruction based on whether
+57 -117
View File
@@ -35,9 +35,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static int CompileToCompiledCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
CompileEnv *envPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
Command *cmdPtr, CompileEnv *envPtr);
@@ -1527,6 +1524,14 @@ TclMakeEnsemble(
cmdName = nameParts[nameCount - 1];
}
}
/*
* Switch on compilation always for core ensembles now that we can do
* nice bytecode things with them. Do it now. Waiting until later will
* just cause pointless epoch bumps.
*/
ensembleFlags |= ENSEMBLE_COMPILE;
ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
/*
@@ -1578,14 +1583,6 @@ TclMakeEnsemble(
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
/*
* Switch on compilation always for core ensembles now that we can do
* nice bytecode things with them.
*/
Tcl_SetEnsembleFlags(interp, ensemble,
ensembleFlags | ENSEMBLE_COMPILE);
}
Tcl_DStringFree(&buf);
@@ -2994,8 +2991,8 @@ TclCompileEnsemble(
*/
invokeAnyway = 1;
if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
envPtr) == TCL_OK) {
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
envPtr)) {
ourResult = TCL_OK;
goto cleanup;
}
@@ -3029,24 +3026,16 @@ TclCompileEnsemble(
return ourResult;
}
/*
* How to compile a subcommand using its own command compiler. To do that, we
* have to perform some trickery to rewrite the arguments, as compilers *must*
* have parse tokens that refer to addresses in the original script.
*/
static int
CompileToCompiledCommand(
int
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Parse synthetic;
Tcl_Token *tokenPtr;
int result, i;
int savedNumCmds = envPtr->numCommands;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
DefineLineInformation;
@@ -3055,47 +3044,17 @@ CompileToCompiledCommand(
return TCL_ERROR;
}
TclParseInit(interp, NULL, 0, &synthetic);
synthetic.numWords = parsePtr->numWords - depth + 1;
TclGrowParseTokenArray(&synthetic, 2);
synthetic.numTokens = 2;
/*
* Now we have the space to work in, install something rewritten. The
* first word will "officially" be the bytes of the structured ensemble
* name. That's technically wrong, but nobody will care; we just need
* *something* here...
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
* This will be wrong, but it will not matter, and it will put the
* tokens for the arguments in the right place without the needed to
* allocate a synthetic Tcl_Parse struct, or copy tokens around.
*/
synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
synthetic.tokenPtr[0].numComponents = 1;
synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
synthetic.tokenPtr[1].numComponents = 0;
for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
+ tokenPtr->size;
synthetic.tokenPtr[0].size = sclen;
synthetic.tokenPtr[1].size = sclen;
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Copy over the real argument tokens.
*/
for (i=1; i<synthetic.numWords; i++) {
int toCopy;
toCopy = tokenPtr->numComponents + 1;
TclGrowParseTokenArray(&synthetic, toCopy);
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
sizeof(Tcl_Token) * toCopy);
synthetic.numTokens += toCopy;
tokenPtr = TokenAfter(tokenPtr);
for (i = 0; i < depth - 1; i++) {
parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
}
parsePtr->numWords -= (depth - 1);
/*
* Shift the line information arrays to account for different word
@@ -3109,7 +3068,7 @@ CompileToCompiledCommand(
* Hand off compilation to the subcommand compiler. At last!
*/
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
/*
* Undo the shift.
@@ -3118,22 +3077,37 @@ CompileToCompiledCommand(
mapPtr->loc[eclIndex].line -= (depth - 1);
mapPtr->loc[eclIndex].next -= (depth - 1);
parsePtr->numWords += (depth - 1);
parsePtr->tokenPtr = saveTokenPtr;
/*
* If our target fails to compile, revert the number of commands and the
* pointer to the place to issue the next instruction. [Bug 3600328]
* If our target failed to compile, revert any data from failed partial
* compiles. Note that envPtr->numCommands need not be checked because
* we avoid compiling subcommands that recursively call TclCompileScript().
*/
if (result != TCL_OK) {
envPtr->numCommands = savedNumCmds;
envPtr->currStackDepth = savedStackDepth;
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
#ifdef TCL_COMPILE_DEBUG
} else {
/*
* Confirm that the command compiler generated a single value on
* the stack as its result. This is only done in debugging mode,
* as it *should* be correct and normal users have no reasonable
* way to fix it anyway.
*/
int diff = envPtr->currStackDepth - savedStackDepth;
if (diff != 1) {
Tcl_Panic("bad stack adjustment when compiling"
" %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
parsePtr->tokenPtr->start, diff);
}
#endif
}
/*
* Clean up if necessary.
*/
Tcl_FreeParse(&synthetic);
return result;
}
@@ -3163,12 +3137,16 @@ CompileToInvokedCommand(
*/
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
} else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/* TODO: Check about registering Cmd Literals here */
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterNewLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size);
@@ -3176,14 +3154,12 @@ CompileToInvokedCommand(
TclContinuationsEnterDerived(
TclFetchLiteral(envPtr, literal),
tokPtr[1].start - envPtr->source,
mapPtr->loc[eclIndex].next[i]);
envPtr->clNext);
}
TclEmitPush(literal, envPtr);
} else {
SetLineInformation(i);
CompileTokens(envPtr, tokPtr, interp);
}
tokPtr = TokenAfter(tokPtr);
}
/*
@@ -3229,49 +3205,13 @@ CompileBasicNArgCommand(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
char *bytes;
int length, i, literal;
DefineLineInformation;
Tcl_Obj *objPtr = Tcl_NewObj();
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, literal), cmdPtr);
TclEmitPush(literal, envPtr);
TclDecrRefCount(objPtr);
/*
* Push the words of the command.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<parsePtr->numWords ; i++) {
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
} else {
SetLineInformation(i);
CompileTokens(envPtr, tokenPtr, interp);
}
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Do the standard dispatch.
*/
if (i <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr);
} else {
TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr);
}
TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
parsePtr->numWords, envPtr);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
-2
View File
@@ -1171,8 +1171,6 @@ Tcl_Finalize(void)
TclFinalizeEncodingSubsystem();
Tcl_SetPanicProc(NULL);
/*
* Repeat finalization of the thread local storage once more. Although
* this step is already done by the Tcl_FinalizeThread call above, series
+73 -41
View File
@@ -721,7 +721,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
int catchOnly, ByteCode *codePtr);
static const char * GetSrcInfoForPc(const unsigned char *pc,
ByteCode *codePtr, int *lengthPtr,
const unsigned char **pcBeg);
const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
@@ -1426,17 +1426,12 @@ Tcl_NRExprObj(
Tcl_Obj *resultPtr)
{
ByteCode *codePtr;
Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK);
/* TODO: consider saving whole state? */
Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
Tcl_ResetResult(interp);
codePtr = CompileExprObj(interp, objPtr);
/* TODO: Confirm reset not required? */
/*Tcl_ResetResult(interp);*/
Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr,
Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr,
NULL, NULL);
return TclNRExecuteByteCode(interp, codePtr);
}
@@ -1447,14 +1442,15 @@ ExprObjCallback(
Tcl_Interp *interp,
int result)
{
Tcl_Obj *saveObjPtr = data[0];
Tcl_InterpState state = data[0];
Tcl_Obj *resultPtr = data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
Tcl_SetObjResult(interp, saveObjPtr);
(void) Tcl_RestoreInterpState(interp, state);
} else {
Tcl_DiscardInterpState(state);
}
TclDecrRefCount(saveObjPtr);
return result;
}
@@ -2002,7 +1998,6 @@ TclNRExecuteByteCode(
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
bcFramePtr->numLevels = iPtr->numLevels;
bcFramePtr->framePtr = iPtr->framePtr;
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline = 0;
@@ -2010,8 +2005,9 @@ TclNRExecuteByteCode(
bcFramePtr->litarg = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
bcFramePtr->cmd.str.cmd = NULL;
bcFramePtr->cmd.str.len = 0;
bcFramePtr->cmdObj = NULL;
bcFramePtr->cmd = NULL;
bcFramePtr->len = 0;
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
@@ -2134,6 +2130,11 @@ TEBCresume(
result = TCL_ERROR;
}
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
Tcl_DecrRefCount(bcFramePtr->cmdObj);
bcFramePtr->cmdObj = NULL;
bcFramePtr->cmd = NULL;
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
@@ -2435,8 +2436,11 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
int cmd;
if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
}
}
pc++;
@@ -2889,8 +2893,11 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
int cmd;
if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
}
}
DECACHE_STACK_INFO();
@@ -2898,7 +2905,7 @@ TEBCresume(
pc += pcAdjustment;
TEBC_YIELD();
return TclNREvalObjv(interp, objc, objv,
TCL_EVAL_NOERR, NULL);
TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
#if TCL_SUPPORT_84_BYTECODE
case INST_CALL_BUILTIN_FUNC1:
@@ -3035,8 +3042,11 @@ TEBCresume(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
int cmd;
if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
}
}
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = opnd;
@@ -4728,7 +4738,7 @@ TEBCresume(
if (listPtr->refCount == 1) {
TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr),
TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)));
for (index=toIdx+1 ; index<objc-1 ; index++) {
for (index=toIdx+1; index<objc ; index++) {
TclDecrRefCount(objv[index]);
}
listPtr->elemCount = toIdx+1;
@@ -6971,7 +6981,7 @@ TEBCresume(
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL);
DECACHE_STACK_INFO();
TclLogCommandInfo(interp, codePtr->source, bytes,
bytes ? length : 0, pcBeg, tosPtr);
@@ -7153,7 +7163,7 @@ TEBCresume(
}
codePtr->flags |= TCL_BYTECODE_RECOMPILE;
bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL);
opnd = TclGetUInt4AtPtr(pc+1);
pc += (opnd-1);
PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
@@ -8646,7 +8656,7 @@ ValidatePcAndStackTop(
if (checkStack &&
((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
@@ -8730,7 +8740,7 @@ IllegalExprOperandType(
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
* TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
@@ -8751,16 +8761,26 @@ IllegalExprOperandType(
*----------------------------------------------------------------------
*/
const char *
TclGetSrcInfoForCmd(
Interp *iPtr,
int *lenPtr)
Tcl_Obj *
TclGetSourceFromFrame(
CmdFrame *cfPtr,
int objc,
Tcl_Obj *const objv[])
{
CmdFrame *cfPtr = iPtr->cmdFramePtr;
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
if (cfPtr == NULL) {
return Tcl_NewListObj(objc, objv);
}
if (cfPtr->cmdObj == NULL) {
if (cfPtr->cmd == NULL) {
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
codePtr, lenPtr, NULL);
cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
}
cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
Tcl_IncrRefCount(cfPtr->cmdObj);
}
return cfPtr->cmdObj;
}
void
@@ -8769,13 +8789,16 @@ TclGetSrcInfoForPc(
{
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
if (cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd = GetSrcInfoForPc(
assert(cfPtr->type == TCL_LOCATION_BC);
if (cfPtr->cmd == NULL) {
cfPtr->cmd = GetSrcInfoForPc(
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
&cfPtr->cmd.str.len, NULL);
&cfPtr->len, NULL, NULL);
}
if (cfPtr->cmd.str.cmd != NULL) {
if (cfPtr->cmd != NULL) {
/*
* We now have the command. We can get the srcOffset back and from
* there find the list of word locations for this command.
@@ -8792,7 +8815,7 @@ TclGetSrcInfoForPc(
return;
}
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
@@ -8832,9 +8855,12 @@ GetSrcInfoForPc(
int *lengthPtr, /* If non-NULL, the location where the length
* of the command's source should be stored.
* If NULL, no length is stored. */
const unsigned char **pcBeg)/* If non-NULL, the bytecode location
const unsigned char **pcBeg,/* If non-NULL, the bytecode location
* where the current instruction starts.
* If NULL; no pointer is stored. */
int *cmdIdxPtr) /* If non-NULL, the location where the index
* of the command containing the pc should
* be stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
@@ -8844,6 +8870,7 @@ GetSrcInfoForPc(
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
int bestCmdIdx = -1;
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
if (pcBeg != NULL) *pcBeg = NULL;
@@ -8911,6 +8938,7 @@ GetSrcInfoForPc(
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
bestCmdIdx = i;
}
}
}
@@ -8940,6 +8968,10 @@ GetSrcInfoForPc(
*lengthPtr = bestSrcLength;
}
if (cmdIdxPtr != NULL) {
*cmdIdxPtr = bestCmdIdx;
}
return (codePtr->source + bestSrcOffset);
}
+1 -1
View File
@@ -1944,7 +1944,7 @@ TclNREvalFile(
iPtr->evalFlags |= TCL_EVAL_FILE;
TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
NULL);
return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN);
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, INT_MIN);
}
static int
+30 -39
View File
@@ -1175,29 +1175,27 @@ typedef struct CmdFrame {
*
* EXECUTION CONTEXTS and usage of CmdFrame
*
* Field TEBC EvalEx EvalObjEx
* ======= ==== ====== =========
* level yes yes yes
* type BC/PREBC SRC/EVAL EVAL_LIST
* line0 yes yes yes
* framePtr yes yes yes
* ======= ==== ====== =========
* Field TEBC EvalEx
* ======= ==== ======
* level yes yes
* type BC/PREBC SRC/EVAL
* line0 yes yes
* framePtr yes yes
* ======= ==== ======
*
* ======= ==== ====== ========= union data
* line1 - yes -
* line3 - yes -
* path - yes -
* ------- ---- ------ ---------
* codePtr yes - -
* pc yes - -
* ======= ==== ====== =========
* ======= ==== ========= union data
* line1 - yes
* line3 - yes
* path - yes
* ------- ---- ------
* codePtr yes -
* pc yes -
* ======= ==== ======
*
* ======= ==== ====== ========= | union cmd
* listPtr - - yes |
* ------- ---- ------ --------- |
* cmd yes yes - |
* cmdlen yes yes - |
* ------- ---- ------ --------- |
* ======= ==== ========= union cmd
* str.cmd yes yes
* str.len yes yes
* ------- ---- ------
*/
union {
@@ -1210,15 +1208,9 @@ typedef struct CmdFrame {
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
union {
struct {
const char *cmd; /* The executed command, if possible... */
int len; /* ... and its length. */
} str;
Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */
} cmd;
int numLevels; /* Value of interp's numLevels when the frame
* was pushed. */
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
int len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
@@ -1282,8 +1274,6 @@ typedef struct ContLineLoc {
* location data referenced via the 'baseLocPtr'.
*
* TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
* TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list
* optimization path of EvalObjEx.
* TCL_LOCATION_BC : Frame is for bytecode.
* TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
* TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a
@@ -1295,8 +1285,6 @@ typedef struct ContLineLoc {
*/
#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */
#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script,
* list-path. */
#define TCL_LOCATION_BC (2) /* Location in byte code. */
#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no
* location. */
@@ -2210,9 +2198,10 @@ typedef struct Interp {
* other than these should be turned into errors.
*/
#define TCL_ALLOW_EXCEPTIONS 4
#define TCL_EVAL_FILE 2
#define TCL_EVAL_CTX 8
#define TCL_ALLOW_EXCEPTIONS 0x04
#define TCL_EVAL_FILE 0x02
#define TCL_EVAL_SOURCE_IN_FRAME 0x10
#define TCL_EVAL_NORESOLVE 0x20
/*
* Flag bits for Interp structures:
@@ -2737,6 +2726,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
@@ -2828,7 +2818,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc,
void *codePtr, CmdFrame *cfPtr, int pc);
void *codePtr, CmdFrame *cfPtr, int cmd, int pc);
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
@@ -2919,7 +2909,8 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
const char *modeString, int *seekFlagPtr,
int *binaryPtr);
MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr);
MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
+52 -4
View File
@@ -279,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData);
static void RunLimitHandlers(LimitHandler *handlerPtr,
Tcl_Interp *interp);
static void TimeLimitCallback(ClientData clientData);
/* NRE enabling */
static Tcl_NRPostProc NRPostInvokeHidden;
static Tcl_ObjCmdProc NRInterpCmd;
static Tcl_ObjCmdProc NRSlaveCmd;
/*
*----------------------------------------------------------------------
@@ -481,7 +487,8 @@ TclInterpInit(
slavePtr->interpCmd = NULL;
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
NULL, NULL);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
@@ -589,6 +596,16 @@ Tcl_InterpObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
ClientData clientData, /* Unused. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *slaveInterp;
int index;
@@ -2372,8 +2389,8 @@ SlaveCreate(
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
@@ -2461,6 +2478,16 @@ SlaveObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
}
static int
NRSlaveCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *slaveInterp = clientData;
int index;
@@ -3052,7 +3079,11 @@ SlaveInvokeHidden(
Tcl_AllowExceptions(slaveInterp);
if (namespaceName == NULL) {
result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
NRE_callback *rootPtr = TOP_CB(slaveInterp);
Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
rootPtr, NULL, NULL);
return TclNRInvoke(NULL, slaveInterp, objc, objv);
} else {
Namespace *nsPtr, *dummy1, *dummy2;
const char *tail;
@@ -3071,6 +3102,23 @@ SlaveInvokeHidden(
Tcl_Release(slaveInterp);
return result;
}
static int
NRPostInvokeHidden(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
NRE_callback *rootPtr = (NRE_callback *)data[1];
if (interp != slaveInterp) {
result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
Tcl_TransferResult(slaveInterp, result, interp);
}
Tcl_Release(slaveInterp);
return result;
}
/*
*----------------------------------------------------------------------
+1 -1
View File
@@ -1942,7 +1942,7 @@ InvokeImportedNRCmd(
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
static int
+1 -1
View File
@@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs(
* win/tclooConfig.sh
*/
#define TCLOO_VERSION "1.0"
#define TCLOO_VERSION "1.0.1"
#define TCLOO_PATCHLEVEL TCLOO_VERSION
/*
+10 -6
View File
@@ -4,7 +4,7 @@
* This file contains implementations of the "simple" commands and
* methods from the object-system core.
*
* Copyright (c) 2005-2012 by Donal K. Fellows
* Copyright (c) 2005-2013 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -88,7 +88,7 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj *invoke[3];
Tcl_Obj **invoke;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -102,6 +102,7 @@ TclOO_Class_Constructor(
* Delegate to [oo::define] to do the work.
*/
invoke = ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -115,7 +116,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
invoke[0], invoke[1], invoke[2], NULL);
invoke, NULL, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -131,9 +132,12 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
TclDecrRefCount((Tcl_Obj *) data[0]);
TclDecrRefCount((Tcl_Obj *) data[1]);
TclDecrRefCount((Tcl_Obj *) data[2]);
Tcl_Obj **invoke = data[0];
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
ckfree(invoke);
return result;
}
+32 -19
View File
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
* Copyright (c) 2006-2012 by Donal K. Fellows
* Copyright (c) 2006-2013 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -2206,29 +2206,42 @@ ClassSuperSet(
/*
* Parse the arguments to get the class to use as superclasses.
*
* Note that zero classes is special, as it is equivalent to just the
* class of objects. [Bug 9d61624b3d]
*/
for (i=0 ; i<superc ; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
if (superc == 0) {
superclasses = ckrealloc(superclasses, sizeof(Class *));
superclasses[0] = oPtr->fPtr->objectCls;
superc = 1;
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
}
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
} else {
for (i=0 ; i<superc ; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
return TCL_ERROR;
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
-1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
return TCL_ERROR;
}
}
}
-6
View File
@@ -122,12 +122,6 @@ typedef struct ForwardMethod {
Tcl_Obj *prefixObj; /* The list of values to use to replace the
* object and method name with. Will be a
* non-empty list. */
int fullyQualified; /* If 1, the command name is fully qualified
* and we should let the default Tcl mechanism
* handle the command lookup because it is
* more efficient. If 0, we need to do a
* specialized lookup based on the current
* object's namespace. */
} ForwardMethod;
/*
+55 -18
View File
@@ -513,8 +513,8 @@ TclOOMakeProcInstanceMethod(
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
cfPtr->cmd = NULL;
cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
(char *) procPtr, &isNew);
@@ -626,8 +626,8 @@ TclOOMakeProcMethod(
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
cfPtr->cmd = NULL;
cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
(char *) procPtr, &isNew);
@@ -1290,11 +1290,57 @@ CloneProcedureMethod(
ClientData *newClientData)
{
ProcedureMethod *pmPtr = clientData;
ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod));
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
/*
* Copy the argument list.
*/
argsObj = Tcl_NewObj();
for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_Obj *argObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, argObj,
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, argsObj, argObj);
}
}
/*
* Must strip the internal representation in order to ensure that any
* bound references to instance variables are removed. [Bug 3609693]
*/
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
TclFreeIntRep(bodyObj);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
pm2Ptr = ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
pm2Ptr->procPtr->refCount++;
Tcl_IncrRefCount(argsObj);
Tcl_IncrRefCount(bodyObj);
if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
&pm2Ptr->procPtr) != TCL_OK) {
Tcl_DecrRefCount(argsObj);
Tcl_DecrRefCount(bodyObj);
ckfree(pm2Ptr);
return TCL_ERROR;
}
Tcl_DecrRefCount(argsObj);
Tcl_DecrRefCount(bodyObj);
if (pmPtr->cloneClientdataProc) {
pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
}
@@ -1338,7 +1384,6 @@ TclOONewForwardInstanceMethod(
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
@@ -1380,7 +1425,6 @@ TclOONewForwardMethod(
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
@@ -1409,7 +1453,6 @@ InvokeForwardMethod(
ForwardMethod *fmPtr = clientData;
Tcl_Obj **argObjs, **prefixObjs;
int numPrefixes, len, skip = contextPtr->skip;
Command *cmdPtr;
/*
* Build the real list of arguments to use. Note that we know that the
@@ -1421,15 +1464,10 @@ InvokeForwardMethod(
Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
if (fmPtr->fullyQualified) {
cmdPtr = NULL;
} else {
cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]),
contextPtr->oPtr->namespacePtr, 0 /* normal lookup */);
}
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr);
((Interp *)interp)->lookupNsPtr
= (Namespace *) contextPtr->oPtr->namespacePtr;
return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
static int
@@ -1474,7 +1512,6 @@ CloneForwardMethod(
ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
fm2Ptr->fullyQualified = fmPtr->fullyQualified;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
+3 -35
View File
@@ -97,7 +97,6 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
static void ContLineLocFree(char *clientData);
static void TclThreadFinalizeContLines(ClientData clientData);
static ThreadSpecificData *TclGetContLineTable(void);
@@ -805,14 +804,7 @@ TclThreadFinalizeContLines(
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
/*
* We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
* here we can be sure that the compiler will not hold references to
* the data in the hashtable, and using TEF might bork the
* finalization sequence.
*/
ContLineLocFree(Tcl_GetHashValue(hPtr));
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
@@ -820,30 +812,6 @@ TclThreadFinalizeContLines(
tsdPtr->lineCLPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* ContLineLocFree --
*
* The freProc for continuation line location tables.
*
* Results:
* None.
*
* Side effects:
* Releases memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
ContLineLocFree(
char *clientData)
{
ckfree(clientData);
}
/*
*--------------------------------------------------------------
*
@@ -1405,7 +1373,7 @@ TclFreeObj(
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
@@ -1496,7 +1464,7 @@ TclFreeObj(
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
+7 -8
View File
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
#include <assert.h>
/*
* The following table provides parsing information about each possible 8-bit
@@ -1567,6 +1568,7 @@ Tcl_ParseVar(
code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
NULL, 1, NULL, NULL);
Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
if (code != TCL_OK) {
return NULL;
@@ -1577,16 +1579,13 @@ Tcl_ParseVar(
* At this point we should have an object containing the value of a
* variable. Just return the string from that object.
*
* This should have returned the object for the user to manage, but
* instead we have some weak reference to the string value in the object,
* which is why we make sure the object exists after resetting the result.
* This isn't ideal, but it's the best we can do with the current
* documented interface. -- hobbs
* Since TclSubstTokens above returned TCL_OK, we know that objPtr
* is shared. It is in both the interp result and the value of the
* variable. Returning the string relies on that to be true.
*/
if (!Tcl_IsShared(objPtr)) {
Tcl_IncrRefCount(objPtr);
}
assert( Tcl_IsShared(objPtr) );
Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
+4 -4
View File
@@ -271,8 +271,8 @@ Tcl_ProcObjCmd(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
cfPtr->cmd = NULL;
cfPtr->len = 0;
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
@@ -2595,8 +2595,8 @@ SetLambdaFromAny(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
cfPtr->cmd = NULL;
cfPtr->len = 0;
}
/*
+23 -5
View File
@@ -1555,14 +1555,14 @@ DelCallbackProc(
*
* TestdelCmd --
*
* This procedure implements the "testdcall" command. It is used
* to test Tcl_CallWhenDeleted.
* This procedure implements the "testdel" command. It is used
* to test calling of command deletion callbacks.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
* Creates a command.
*
*----------------------------------------------------------------------
*/
@@ -4408,8 +4408,26 @@ TestseterrorcodeCmd(
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
argv[5], NULL);
switch (argc) {
case 1:
Tcl_SetErrorCode(interp, "NONE", NULL);
break;
case 2:
Tcl_SetErrorCode(interp, argv[1], NULL);
break;
case 3:
Tcl_SetErrorCode(interp, argv[1], argv[2], NULL);
break;
case 4:
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL);
break;
case 5:
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL);
break;
case 6:
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
argv[5], NULL);
}
return TCL_ERROR;
}
+1 -1
View File
@@ -1558,7 +1558,7 @@ Tcl_UniCharIsSpace(
return TclIsSpaceProc((char) ch);
} else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e
|| (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060
|| (Tcl_UniChar) ch == 0xfeff) {
|| (Tcl_UniChar) ch == 0x202f || (Tcl_UniChar) ch == 0xfeff) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
+1 -2
View File
@@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + 5];
register int len;
register int len = 3;
memcpy(buffer, "end", 4);
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
+48 -17
View File
@@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} {
return [string map [list \0 \$] $name]
}
# auto_mkindex_parser::indexEntry --
#
# Used by commands like "proc" within the auto_mkindex parser to add a
# correctly-quoted entry to the index. This is shared code so it is done
# *right*, in one place.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::indexEntry {name} {
variable index
variable scriptFile
# We convert all metacharacters to their backslashed form, and pre-split
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
{set auto_index(%s) [list source [file join $dir %s]]%s} \
$name $filenameParts \n]
return
}
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
@@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} {
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
variable index
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
# command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
@@ -559,14 +577,7 @@ auto_mkindex_parser::hook {
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
variable scriptFile
# Do some nice reformatting of the "source" call, to get around
# path differences on different platforms. We use the format
# command just so that the code is a little easier to read.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
indexEntry $name
}
}
}
@@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} {
variable contextStack
if {[lindex $args 0] eq "create"} {
set name ::[join [lreverse $contextStack] ::]
catch {
set name [dict get [lrange $args 1 end] -command]
if {![string match ::* $name]} {
set name ::[join [lreverse $contextStack] ::]$name
}
regsub -all ::+ $name :: name
}
# create artifical proc to force an entry in the tclIndex
$parser eval [list ::proc $name {} {}]
}
@@ -617,4 +635,17 @@ auto_mkindex_parser::command namespace {op args} {
}
}
# AUTO MKINDEX: oo::class create name ?definition?
# Adds an entry to the auto index list for the given class name.
auto_mkindex_parser::command oo::class {op name {body ""}} {
if {$op eq "create"} {
indexEntry $name
}
}
auto_mkindex_parser::command class {op name {body ""}} {
if {$op eq "create"} {
indexEntry $name
}
}
return
+1 -1
View File
@@ -324,7 +324,7 @@ proc ::tcl::clock::Initialize {} {
{-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
{-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
{-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia
{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
{-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
{-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
+7 -4
View File
@@ -16,7 +16,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.6.0
package require -exact Tcl 8.6.1
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -250,7 +250,8 @@ proc unknown args {
# Make sure we're not trying to load the same proc twice.
#
if {[info exists UnknownPending($name)]} {
return -code error "self-referential recursion\
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
"self-referential recursion\
in \"unknown\" for command \"$name\""
}
set UnknownPending($name) pending
@@ -399,10 +400,12 @@ proc unknown args {
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error "invalid command name \"$name\""
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
"invalid command name \"$name\""
}
# auto_load --
+1 -1
View File
@@ -9,4 +9,4 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]]
package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]]
+1 -1
View File
@@ -22,7 +22,7 @@ namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.3.5
variable Version 2.3.6
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
+9
View File
@@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} {
continue
}
if {[package ifneeded $pkgname $pkgversion] ne {}} {
# There's already a provide script registered for
# this version of this package. Since all units of
# code claiming to be the same version of the same
# package ought to be identical, just stick with
# the one we already have.
continue
}
# We have found a candidate, generate a "provide script"
# for it, and remember it. Note that we are using ::list
# to do this; locally [list] means something else without
+1 -1
View File
@@ -39,7 +39,7 @@ needs to conform to the following conventions.
distclean: Delete all generated files.
dist: Produce a copy of the package's source code distribution.
Must respect the DIST_ROOT variable determing where to
Must respect the DIST_ROOT variable determining where to
write the generated directory.
Packages that are written to make use of the Tcl Extension Architecture (TEA)
+1 -2
View File
@@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} {
-match glob
-result {1 {extra characters after close-brace} {extra characters after close-brace
while executing
"{}extra
"
"{}e"
("assemble" body, line 2)*}}
}
test assemble-4.2 {null command} {
+71 -32
View File
@@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body {
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
test binary-71.11 {binary decode hex: Bug b98fa55285} -body {
apply {{} {
set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n"
set decoded [binary decode hex $str]
list [string length $decoded] [scan [string index $decoded end] %c]
}}
} -result {29 38}
test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body {
apply {{} {
set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n"
set decoded [binary decode hex $str]
list [string length $decoded] [scan [string index $decoded end] %c]
}}
} -result {28 140}
test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body {
apply {{} {
set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n"
set decoded [binary decode hex $str]
list [string length $decoded] [scan [string index $decoded end] %c]
}}
} -result {28 140}
test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body {
apply {{} {
set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n"
set decoded [binary decode hex $str]
list [string length $decoded] [scan [string index $decoded end] %c]
}}
} -result {28 140}
test binary-72.1 {binary encode base64} -body {
binary encode base64
@@ -2677,105 +2705,116 @@ test binary-74.1 {binary encode uuencode} -body {
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
} -result {#86)C
}
test binary-74.3 {binary encode uuencode} -body {
binary encode uuencode {}
} -result {}
test binary-74.4 {binary encode uuencode} -body {
binary encode uuencode [string repeat abc 20]
} -result [string repeat 86)C 20]
} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n"
test binary-74.5 {binary encode uuencode} -body {
binary encode uuencode \0\1\2\3\4\0\1\2\3
} -result "``\$\"`P0``0(#"
} -result ")``\$\"`P0``0(#\n"
test binary-74.6 {binary encode uuencode} -body {
binary encode uuencode \0
} -result {````}
} -result {!``
}
test binary-74.7 {binary encode uuencode} -body {
binary encode uuencode \0\0
} -result {````}
} -result "\"```
"
test binary-74.8 {binary encode uuencode} -body {
binary encode uuencode \0\0\0
} -result {````}
} -result {#````
}
test binary-74.9 {binary encode uuencode} -body {
binary encode uuencode \0\0\0\0
} -result {````````}
test binary-74.10 {binary encode uuencode} -body {
binary encode uuencode -maxlen 0 -wrapchar | abcabcabc
} -result {86)C86)C86)C}
test binary-74.11 {binary encode uuencode} -body {
binary encode uuencode -maxlen 1 -wrapchar | abcabcabc
} -result {8|6|)|C|8|6|)|C|8|6|)|C}
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 1 abcabcabc
} -result {line length out of range}
test binary-74.12 {binary encode uuencode} -body {
binary encode uuencode -maxlen 3 -wrapchar | abcabcabc
} -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|}
test binary-75.1 {binary decode uuencode} -body {
binary decode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-75.2 {binary decode uuencode} -body {
binary decode uuencode 86)C
binary decode uuencode "#86)C\n"
} -result {abc}
test binary-75.3 {binary decode uuencode} -body {
binary decode uuencode {}
} -result {}
test binary-75.3.1 {binary decode uuencode} -body {
binary decode uuencode `\n
} -result {}
test binary-75.4 {binary decode uuencode} -body {
binary decode uuencode [string repeat "86)C" 20]
binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n"
} -result [string repeat abc 20]
test binary-75.5 {binary decode uuencode} -body {
binary decode uuencode "``\$\"`P0``0(#"
binary decode uuencode ")``\$\"`P0``0(#"
} -result "\0\1\2\3\4\0\1\2\3"
test binary-75.6 {binary decode uuencode} -body {
string length [binary decode uuencode {`}]
string length [binary decode uuencode "`\n"]
} -result 0
test binary-75.7 {binary decode uuencode} -body {
string length [binary decode uuencode {``}]
string length [binary decode uuencode "!`\n"]
} -result 1
test binary-75.8 {binary decode uuencode} -body {
string length [binary decode uuencode {```}]
string length [binary decode uuencode "\"``\n"]
} -result 2
test binary-75.9 {binary decode uuencode} -body {
string length [binary decode uuencode {````}]
string length [binary decode uuencode "#```\n"]
} -result 3
test binary-75.10 {binary decode uuencode} -body {
set s "[string repeat 86)C 10]\n[string repeat 86)C 10]"
set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s "[string repeat 86)C 10]\n [string repeat 86)C 10]"
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
} -returnCodes error -match glob -result {invalid uuencode character "|" at position 0}
test binary-75.13 {binary decode uuencode} -body {
set s "[string repeat 86)C 10]|[string repeat 86)C 10]"
set s ">[string repeat 86)C 10]|[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40}
} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41}
test binary-75.14 {binary decode uuencode} -body {
set s "[string repeat 86)C 10]\n [string repeat 86)C 10]"
set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character *}
test binary-75.20 {binary decode uuencode} -body {
set r [binary decode uuencode 8]
set r [binary decode uuencode " 8"]
list [string length $r] $r
} -result {0 {}}
test binary-75.21 {binary decode uuencode} -body {
set r [binary decode uuencode 86]
set r [binary decode uuencode "!86"]
list [string length $r] $r
} -result {1 a}
test binary-75.22 {binary decode uuencode} -body {
set r [binary decode uuencode 86)]
set r [binary decode uuencode "\"86)"]
list [string length $r] $r
} -result {2 ab}
test binary-75.23 {binary decode uuencode} -body {
set r [binary decode uuencode 86)C]
set r [binary decode uuencode "#86)C"]
list [string length $r] $r
} -result {3 abc}
test binary-75.24 {binary decode uuencode} -body {
set s "04)\# "
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "04)\#z"
set s "#04)\#z"
binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4}
} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5}
test binary-75.26 {binary decode uuencode} -body {
string length [binary decode uuencode " "]
} -result 0
+33
View File
@@ -609,6 +609,39 @@ test coroutine-7.3 {yielding between coroutines} -body {
} -cleanup {
catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
proc foo {a b} {catch yield; return 1}
} -cleanup {
rename foo {}
} -body {
coroutine demo lsort -command foo {a b}
} -result {b a}
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
lappend result [catch {coroutine demo return -level 0 -code $code}]
}
set result
} {0 1 2 3 4 5}
test coroutine-7.6 {Early yield crashes} {
proc foo args {}
trace add execution foo enter {catch yield}
coroutine demo foo
rename foo {}
} {}
test coroutine-7.7 {Bug 2486550} -setup {
interp hide {} yield
} -body {
coroutine demo interp invokehidden {} yield ok
} -cleanup {
demo
interp expose {} yield
} -result ok
# cleanup
unset lambda
+73 -2
View File
@@ -1604,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
}
}} [linenumber]}}
} 5
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
test dict-23.2 {dict compilation crash: Bug 3487626} {
# Something isn't quite right in line number and continuation line
# tracking; at time of writing, this test produces 7, not 5, which
# indicates that the extra newlines in the non-script argument are
@@ -1838,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} {
}
}} [linenumber]}}
} 5
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} {
apply {{} {apply {n {
set e {}
set k {}
@@ -1865,6 +1865,77 @@ j
}
}} [linenumber]}}
} 5
test dict-23.3 {CompileWord OBOE} {
# segfault when buggy
apply {{} {tcl::dict::lappend foo bar \
[format baz]}}
} {bar baz}
test dict-23.4 {CompileWord OBOE} {
apply {n {
dict set foo {*}{
} [return [incr n -[linenumber]]] val
}} [linenumber]
} 1
test dict-23.5 {CompileWord OBOE} {
# segfault when buggy
apply {{} {tcl::dict::incr foo \
[format bar]}}
} {bar 1}
test dict-23.6 {CompileWord OBOE} {
apply {n {
dict get {a b} {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} 1
test dict-23.7 {CompileWord OBOE} {
apply {n {
dict for {a b} [return [incr n -[linenumber]]] {*}{
} {}
}} [linenumber]
} 2
test dict-23.8 {CompileWord OBOE} {
apply {n {
dict update foo {*}{
} [return [incr n -[linenumber]]] x {}
}} [linenumber]
} 1
test dict-23.9 {CompileWord OBOE} {
apply {n {
dict exists {} {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} 1
test dict-23.10 {CompileWord OBOE} {
apply {n {
dict with foo {*}{
} [return [incr n -[linenumber]]] {}
}} [linenumber]
} 1
test dict-23.11 {CompileWord OBOE} {
apply {n {
dict with ::foo {*}{
} [return [incr n -[linenumber]]] {}
}} [linenumber]
} 1
test dict-23.12 {CompileWord OBOE} {
apply {n {
dict with {*}{
} [return [incr n -[linenumber]]] {}
}} [linenumber]
} 1
test dict-23.13 {CompileWord OBOE} {
apply {n {
dict with {*}{
} [return [incr n -[linenumber]]] {bar}
}} [linenumber]
} 1
test dict-23.14 {CompileWord OBOE} {
apply {n {
dict with foo {*}{
} [return [incr n -[linenumber]]] {bar}
}} [linenumber]
} 1
rename linenumber {}
test dict-24.22 {dict map results (non-compiled)} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
+10
View File
@@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body {
catch {f 12} m d
dict get $d -errorstack
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
test error-4.8 {errorstack from exec traces} -body {
proc foo args {}
proc goo {} foo
trace add execution foo enter {error bar;#}
catch goo m d
dict get $d -errorstack
} -cleanup {
rename goo {}; rename foo {}
unset -nocomplain m d
} -result {INNER {error bar} CALL goo UP 1}
# Errors in error command itself
+11
View File
@@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} {
list [catch { foo } msg] $msg
} {1 {foreach varlist is empty}}
test foreach-9.2 {line numbers} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
foreach x y {*}{
} {return [incr n -[linenumber]]}
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
proc demo {} {
set vals {1 2 3 4}
+25
View File
@@ -2370,6 +2370,31 @@ test info-33.33 {{*}, literal, simple, bytecompiled} -body {
namespace delete foo
} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
append x {*}{
} [return [info frame 0]]
}
test info-33.34 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
append {*}{
} x([return [info frame 0]]) {*}{
} a
}
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
unset -nocomplain res
+14
View File
@@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup {
} -cleanup {
interp delete slave
} -returnCodes error -match glob -result *
test interp-20.50.1 {Bug 2486550} -setup {
interp create slave
} -body {
slave hide coroutine
catch {slave invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete slave
} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
"slave invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
+1 -6
View File
@@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} {
missing close-brace for variable name
missing close-brace for variable name
while executing
"set tst $a([winfo name $\{zz)
# this is a bogus comment
# this is a bogus comment
# this is a bogus comment
# this is a bogus comment
# this is a ..."
"set tst $a([winfo name $\{"
(procedure "tstProc" line 4)
invoked from within
"tstProc"}]
+131 -2
View File
@@ -2,12 +2,12 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2012 Donal K. Fellows
# Copyright (c) 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require TclOO 1.0.1
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
@@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
} -returnCodes error -cleanup {
fooClass destroy
} -result {wrong # args: should be "::foo len string"}
test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup {
oo::object create foo
unset -nocomplain ::result
set ::result {}
} -body {
proc ::my {method} {lappend ::result global}
oo::objdefine foo {
method target {} {lappend ::result instance}
forward bar my target
method bump {} {
set ns [info object namespace ::foo]
rename ${ns}::my ${ns}::
rename ${ns}:: ${ns}::my
}
}
proc harness {} {
foo target
foo bar
foo target
}
trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
foo target
foo bar
foo bump
foo bar
harness
} -cleanup {
catch {rename harness {}}
catch {rename ::my {}}
foo destroy
} -result {instance instance instance instance instance instance}
test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup {
oo::class create fooClass
fooClass create foo
unset -nocomplain ::result
set ::result {}
} -body {
proc ::my {method} {lappend ::result global}
oo::define fooClass {
method target {} {lappend ::result class}
forward bar my target
method bump {} {
set ns [info object namespace [self]]
rename ${ns}::my ${ns}::
rename ${ns}:: ${ns}::my
}
}
proc harness {} {
foo target
foo bar
foo target
}
trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
foo target
foo bar
foo bump
foo bar
harness
} -cleanup {
catch {rename harness {}}
catch {rename ::my {}}
fooClass destroy
} -result {class class class class class class}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
@@ -1776,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
} -returnCodes error -cleanup {
Foo destroy
} -result {wrong # args: should be "::bar <cloned> a b"}
test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
oo::class create FooClass
set result {}
} -body {
set obj1 [FooClass new]
oo::objdefine $obj1 {
variable var
method m {} {
set var foo
}
method get {} {
return $var
}
export eval
}
$obj1 m
lappend result [$obj1 get]
set obj2 [oo::copy $obj1]
$obj2 eval {
set var bar
}
lappend result [$obj2 get]
$obj1 eval {
set var grill
}
lappend result [$obj1 get] [$obj2 get]
} -cleanup {
FooClass destroy
} -result {foo bar grill bar}
test oo-16.1 {OO: object introspection} -body {
info object
@@ -3374,6 +3467,42 @@ test oo-34.8 {TIP 380: slots - presence} {
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
} {{-append -clear -set} {Get Set}}
test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
oo::class create fruit {
method eat {} {}
}
set result {}
} -body {
lappend result [fruit create ::apple] [info class superclasses fruit]
oo::define fruit superclass
lappend result [info class superclasses fruit] \
[info object class apple oo::object] \
[info class call fruit destroy] \
[catch { apple }]
} -cleanup {
unset -nocomplain result
fruit destroy
} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1}
test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
oo::class create fruitMetaclass {
superclass oo::class
method eat {} {}
}
set result {}
} -body {
lappend result [fruitMetaclass create ::appleClass] \
[appleClass create orange] \
[info class superclasses fruitMetaclass]
oo::define fruitMetaclass superclass
lappend result [info class superclasses fruitMetaclass] \
[info object class appleClass oo::class] \
[catch { orange }] [info object class orange] \
[appleClass create pear]
} -cleanup {
unset -nocomplain result
fruitMetaclass destroy
} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
cleanupTests
return
+1 -1
View File
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require TclOO 1.0.1
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
+27
View File
@@ -27,6 +27,7 @@ testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
testConstraint memory [llength [info commands memory]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -678,6 +679,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
proc getbytes {} {
return [lindex [split [memory info] \n] 3 3]
}
} -body {
set a() foo
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
set vn {}
set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]]
if {$res ne {foo bar}} {error "Unexpected result: $res"}
set tmp $end
set end [getbytes]
}
expr {$end - $tmp}
} -cleanup {
unset -nocomplain a end i vn res tmp
rename getbytes {}
} -result 0
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -1097,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent {
testevent queue a head $::script
vwait done
} {}
test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent {
testevent queue a head {testevent delete a; \
set ::done [dict get [info frame 0] line]}
vwait done
set ::done
} 2
cleanupTests
}
+3
View File
@@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} {
(.*) # ConditionalFields
}] 0
} 68
test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} {
lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0
} 1
# cleanup
::tcltest::cleanupTests
+4
View File
@@ -876,6 +876,10 @@ test regexp-22.5 {Bug 3610026} -setup {
} -cleanup {
unset -nocomplain e cp
} -returnCodes error -match glob -result {*too many colors*}
test regexp-22.6 {Bug 6585b21ca8} {
expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"}
} rogr
test regexp-23.1 {regexp -all and -line} {
set string ""
+7
View File
@@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel {
if {[info exists env(value)]} {
unset env(value)
}
test rename-4.8 {Bug a16752c252} testdel {
set x broken
testdel {} foo {set x ok}
proc foo args {}
rename foo {}
return -level 0 $x[unset x]
} ok
# Save the unknown procedure which is modified by the following test.
+80
View File
@@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i {load {} Safepkg1}} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1"
invoked from within
"interp eval $i {load {} Safepkg1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
@@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1 x"
invoked from within
"interp eval $i {interp create x; load {} Safepkg1 x}"}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
@@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
test safe-11.7.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i encoding convertfrom} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
while executing
"encoding convertfrom"
invoked from within
"::interp invokehidden interp1 encoding convertfrom"
invoked from within
"encoding convertfrom"
invoked from within
"interp eval $i encoding convertfrom"}
test safe-11.8 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
@@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
test safe-11.8.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i encoding convertto} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"
while executing
"encoding convertto"
invoked from within
"::interp invokehidden interp1 encoding convertto"
invoked from within
"encoding convertto"
invoked from within
"interp eval $i encoding convertto"}
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
@@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
lappend result [interp eval $i {tcl::file::split a/b/c}]
lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
lappend result [interp invokehidden $i file split a/b/c]
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp invokehidden $i file isdirectory .}]
interp expose $i file
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo]
} -cleanup {
unset -nocomplain msg o
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file
while executing
"file isdirectory ."
invoked from within
"interp eval $i {file isdirectory .}"}}
### ~ should have no special meaning in paths in safe interpreters
test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
+4
View File
@@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup {
} -cleanup {
removeFile subst13.tcl
}
test subst-13.2 {Test for segfault} -body {
subst {[}
} -returnCodes error -result * -match glob
# cleanup
::tcltest::cleanupTests
+7
View File
@@ -2661,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
rename dotrace {}
rename foo {}
} -result {3 | 0 1 1}
test trace-40.1 {execution trace errors become command errors} {
proc foo args {}
trace add execution foo enter {rename foo {}; error bar;#}
catch foo m
return -level 0 $m[unset m]
} bar
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
+45
View File
@@ -0,0 +1,45 @@
# This file contains a collection of tests for the procedures in the file
# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
testConstraint testfork [llength [info commands testfork]]
# Test if the notifier thread is well initialized in a forked interpreter
# by Tcl_InitNotifier
test unixforkevent-1.1 {fork and test writeable event} \
-constraints {testfork nonPortable} \
-body {
set myFolder [makeDirectory unixtestfork]
set pid [testfork]
if {$pid == 0} {
# we are the forked process
set result initialized
set h [open [file join $myFolder test.txt] w]
fileevent $h writable\
"set result writable;\
after cancel [after 1000 {set result timeout}]"
vwait result
close $h
makeFile $result result.txt $myFolder
exit
}
# we are the original process
while {![file readable [file join $myFolder result.txt]]} {}
viewFile result.txt $myFolder
} \
-result {writable} \
-cleanup {
catch { removeFolder $myFolder }
}
::tcltest::cleanupTests
return
+43
View File
@@ -414,6 +414,17 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar {
} {1234}
catch {unset a}
test upvar-10.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
upvar 1 {*}{
} [return [incr n -[linenumber]]] x
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
#
# Tests for 'namespace upvar'. As the implementation is essentially the same as
# for 'upvar', we only test that the variables are linked correctly, i.e., we
@@ -536,6 +547,38 @@ test upvar-NS-2.2 {TIP 323} -setup {
} -cleanup {
namespace delete test_ns_1
} -result {}
test upvar-NS-3.1 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
namespace upvar {*}{
} [return [incr n -[linenumber]]] x y
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test upvar-NS-3.2 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
namespace upvar :: {*}{
} [return [incr n -[linenumber]]] x
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
test upvar-NS-3.3 {CompileWord OBOE} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
variable x {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
# cleanup
::tcltest::cleanupTests
+16
View File
@@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} {
namespace eval test A useSomeUnlikelyNameHere
namespace eval test unset useSomeUnlikelyNameHere
} {}
test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} {
apply {{} {unset foo [return ok]}}
} ok
test var-16.1 {CallVarTraces: save/restore interp error state} {
trace add variable ::errorCode write " ;#"
@@ -862,6 +865,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
}}
array size x
} -result 0
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
} -body {
apply {n {
set foo bar
unset foo {*}{
} [return [incr n -[linenumber]]]
}} [linenumber]
} -cleanup {
rename linenumber {}
} -result 1
catch {namespace delete ns}
catch {unset arr}
+12 -9
View File
@@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup {
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
test zlib-8.8 {transformtion and fconfigure} -setup {
test zlib-8.8 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
@@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
test zlib-8.9 {transformtion and fconfigure} -setup {
test zlib-8.9 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
@@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
test zlib-8.10 {transformtion and fconfigure} -setup {
test zlib-8.10 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
@@ -276,7 +276,10 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib inflate $compressed} err opt
catch {
zlib inflate $compressed
throw UNREACHABLE "should be unreachable"
} err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
@@ -284,7 +287,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
test zlib-8.11 {transformtion and fconfigure} -setup {
test zlib-8.11 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
@@ -300,7 +303,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.12 {transformtion and fconfigure} -setup {
test zlib-8.12 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -317,7 +320,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.13 {transformtion and fconfigure} -setup {
test zlib-8.13 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -334,7 +337,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.14 {transformtion and fconfigure} -setup {
test zlib-8.14 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
@@ -350,7 +353,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.15 {transformtion and fconfigure} -setup {
test zlib-8.15 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
+11 -3
View File
@@ -335,7 +335,10 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \
bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o
STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS}
STUB_LIB_OBJS = tclStubLib.o \
tclTomMathStubLib.o \
tclOOStubLib.o \
${COMPAT_OBJS}
UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
tclUnixFile.o tclUnixPipe.o tclUnixSock.o \
@@ -346,6 +349,8 @@ NOTIFY_OBJS = tclUnixNotfy.o
MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o
CYGWIN_OBJS = tclWinError.o
DTRACE_OBJ = tclDTrace.o
ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \
@@ -575,6 +580,9 @@ MAC_OSX_SRCS = \
$(MAC_OSX_DIR)/tclMacOSXFCmd.c \
$(MAC_OSX_DIR)/tclMacOSXNotify.c
CYGWIN_SRCS = \
$(TOP_DIR)/win/tclWinError.c
DTRACE_HDR = tclDTrace.h
DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d
@@ -842,8 +850,8 @@ install-libraries: libraries
done;
@echo "Installing package msgcat 1.5.2 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm;
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm;
@echo "Installing package tcltest 2.3.6 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm;
@echo "Installing package platform 1.0.12 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm;
+10 -105
View File
@@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
@@ -4821,7 +4821,11 @@ echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you m
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
for ac_func in pthread_attr_setstacksize
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
for ac_func in pthread_attr_setstacksize pthread_atfork
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
@@ -4922,6 +4926,7 @@ _ACEOF
fi
done
LIBS=$ac_saved_libs
else
TCL_THREADS=0
fi
@@ -7068,7 +7073,9 @@ fi
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o tclWinError.o"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
@@ -17945,108 +17952,6 @@ if test `eval echo '${'$as_ac_var'}'` = yes; then
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
fi
done
for ac_func in pthread_atfork
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
if eval "test \"\${$as_ac_var+set}\" = set"; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h. */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h. */
/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
For example, HP-UX 11i <limits.h> declares gettimeofday. */
#define $ac_func innocuous_$ac_func
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func (); below.
Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
<limits.h> exists even on freestanding compilers. */
#ifdef __STDC__
# include <limits.h>
#else
# include <assert.h>
#endif
#undef $ac_func
/* Override any gcc2 internal prototype to avoid an error. */
#ifdef __cplusplus
extern "C"
{
#endif
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char $ac_func ();
/* The GNU C library defines this for functions which it implements
to always fail with ENOSYS. Some functions are actually named
something starting with __ and the normal name is an alias. */
#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
choke me
#else
char (*f) () = $ac_func;
#endif
#ifdef __cplusplus
}
#endif
int
main ()
{
return f != $ac_func;
;
return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
(eval $ac_link) 2>conftest.er1
ac_status=$?
grep -v '^ *+' conftest.er1 >conftest.err
rm -f conftest.er1
cat conftest.err >&5
echo "$as_me:$LINENO: \$? = $ac_status" >&5
(exit $ac_status); } &&
{ ac_try='test -z "$ac_c_werror_flag"
|| test ! -s conftest.err'
{ (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
(eval $ac_try) 2>&5
ac_status=$?
echo "$as_me:$LINENO: \$? = $ac_status" >&5
(exit $ac_status); }; } &&
{ ac_try='test -s conftest$ac_exeext'
{ (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
(eval $ac_try) 2>&5
ac_status=$?
echo "$as_me:$LINENO: \$? = $ac_status" >&5
(exit $ac_status); }; }; then
eval "$as_ac_var=yes"
else
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
eval "$as_ac_var=no"
fi
rm -f conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
fi
echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
if test `eval echo '${'$as_ac_var'}'` = yes; then
cat >>confdefs.h <<_ACEOF
#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
fi
done
+1 -2
View File
@@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
@@ -576,7 +576,6 @@ if test "`uname -s`" = "Darwin" ; then
if test $tcl_corefoundation = yes; then
AC_CHECK_HEADERS(libkern/OSAtomic.h)
AC_CHECK_FUNCS(OSSpinLockLock)
AC_CHECK_FUNCS(pthread_atfork)
fi
AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?])
AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8",
+8 -2
View File
@@ -676,7 +676,11 @@ AC_DEFUN([SC_ENABLE_THREADS], [
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
AC_CHECK_FUNCS(pthread_attr_setstacksize)
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork)
LIBS=$ac_saved_libs
else
TCL_THREADS=0
fi
@@ -1224,7 +1228,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o tclWinError.o"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
+1 -1
View File
@@ -4,7 +4,7 @@
Name: tcl
Summary: Tcl scripting language development environment
Version: 8.6.0
Version: 8.6.1
Release: 2
License: BSD
Group: Development/Languages
+3 -3
View File
@@ -115,6 +115,9 @@
/* Define to 1 if you have the `gmtime_r' function. */
#undef HAVE_GMTIME_R
/* Compiler support for module scope symbols */
#undef HAVE_HIDDEN
/* Do we have the intptr_t type? */
#undef HAVE_INTPTR_T
@@ -343,9 +346,6 @@
/* Do we have <values.h>? */
#undef NO_VALUES_H
/* Compiler support for module scope symbols */
#undef HAVE_HIDDEN
/* Do we have wait3() */
#undef NO_WAIT3
+2 -2
View File
@@ -462,10 +462,10 @@ DoCopyFile(
switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
case S_IFLNK: {
char linkBuf[MAXPATHLEN];
char linkBuf[MAXPATHLEN+1];
int length;
length = readlink(src, linkBuf, sizeof(linkBuf));
length = readlink(src, linkBuf, MAXPATHLEN);
/* INTL: Native. */
if (length == -1) {
return TCL_ERROR;
+112 -1
View File
@@ -119,6 +119,15 @@ static Tcl_ThreadDataKey dataKey;
static int notifierCount = 0;
/*
* The following static stores the process ID of the initialized notifier
* thread. If it changes, we have passed a fork and we should start a new
* notifier thread.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
static pid_t processIDInitialized = 0;
/*
* The following variable points to the head of a doubly-linked list of
* ThreadSpecificData structures for all threads that are currently waiting on
@@ -185,7 +194,13 @@ static Tcl_ThreadId notifierThread;
#ifdef TCL_THREADS
static void NotifierThreadProc(ClientData clientData);
#endif
#ifdef HAVE_PTHREAD_ATFORK
static int atForkInit = 0;
static void AtForkPrepare(void);
static void AtForkParent(void);
static void AtForkChild(void);
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
@@ -275,11 +290,38 @@ Tcl_InitNotifier(void)
*/
Tcl_MutexLock(&notifierMutex);
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
*/
if (!atForkInit) {
int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);
if (result) {
Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
}
atForkInit = 1;
}
#endif
/*
* Check if my process id changed, e.g. I was forked
* In this case, restart the notifier thread and close the
* pipe to the original notifier thread
*/
if (notifierCount > 0 && processIDInitialized != getpid()) {
notifierCount = 0;
processIDInitialized = 0;
close(triggerPipe);
triggerPipe = -1;
}
if (notifierCount == 0) {
if (TclpThreadCreate(&notifierThread, NotifierThreadProc, NULL,
TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread");
}
processIDInitialized = getpid();
}
notifierCount++;
@@ -1270,6 +1312,75 @@ NotifierThreadProc(
TclpThreadExit(0);
}
#ifdef HAVE_PTHREAD_ATFORK
/*
*----------------------------------------------------------------------
*
* AtForkPrepare --
*
* Lock the notifier in preparation for a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkPrepare(void)
{
}
/*
*----------------------------------------------------------------------
*
* AtForkParent --
*
* Unlock the notifier in the parent after a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkParent(void)
{
}
/*
*----------------------------------------------------------------------
*
* AtForkChild --
*
* Unlock and reinstall the notifier in the child after a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkChild(void)
{
notifierMutex = NULL;
notifierCV = NULL;
Tcl_InitNotifier();
}
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
#endif /* !HAVE_COREFOUNDATION */
+2
View File
@@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer(
my_errno = errno;
}
close(sock);
sock = -1;
continue;
}
if (port == 0 && chosenport == 0) {
@@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer(
my_errno = errno;
}
close(sock);
sock = -1;
continue;
}
if (statePtr == NULL) {
+49
View File
@@ -67,6 +67,7 @@ static Tcl_CmdProc TestchmodCmd;
static Tcl_CmdProc TestfilehandlerCmd;
static Tcl_CmdProc TestfilewaitCmd;
static Tcl_CmdProc TestfindexecutableCmd;
static Tcl_ObjCmdProc TestforkObjCmd;
static Tcl_CmdProc TestgetdefencdirCmd;
static Tcl_CmdProc TestgetopenfileCmd;
static Tcl_CmdProc TestgotsigCmd;
@@ -103,6 +104,8 @@ TclplatformtestInit(
NULL, NULL);
Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
@@ -526,6 +529,52 @@ TestsetdefencdirCmd(
Tcl_SetDefaultEncodingDir(argv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestforkObjCmd --
*
* This function implements the "testfork" command. It is used to
* fork the Tcl process for specific test cases.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestforkObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
pid = fork();
if (pid == -1) {
Tcl_AppendResult(interp,
"Cannot fork", NULL);
return TCL_ERROR;
}
#if !defined(HAVE_PTHREAD_ATFORK) || defined(MAC_OSX_TCL)
/* Only needed when pthread_atfork is not present or on OSX. */
if (pid==0) {
Tcl_InitNotifier();
}
#endif
Tcl_SetObjResult(interp, Tcl_NewIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
+1 -1
View File
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
TCLOO_VERSION=1.0
TCLOO_VERSION=1.0.1
+6 -6
View File
@@ -584,23 +584,23 @@ install-binaries: binaries
fi; \
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo installing $(DDE_DLL_FILE); \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
$(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo installing $(DDE_LIB_FILE); \
echo Installing $(DDE_LIB_FILE); \
$(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo installing $(REG_DLL_FILE); \
echo Installing $(REG_DLL_FILE); \
$(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
$(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
$(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo installing $(REG_LIB_FILE); \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs
done;
@echo "Installing package msgcat 1.5.2 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm;
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm;
@echo "Installing package tcltest 2.3.6 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm;
@echo "Installing package platform 1.0.12 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
+1 -1
View File
@@ -1311,7 +1311,7 @@ SHELL=/bin/sh
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
TCL_PATCH_LEVEL=".1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
+1 -1
View File
@@ -14,7 +14,7 @@ SHELL=/bin/sh
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
TCL_PATCH_LEVEL=".1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
+14 -14
View File
@@ -409,57 +409,57 @@ $(CAT32): $(WINDIR)\cat.c
install-binaries: $(TCLSH)
$(MKDIR) "$(BIN_INSTALL_DIR)"
$(MKDIR) "$(LIB_INSTALL_DIR)"
@echo installing $(TCLDLLNAME)
@echo Installing $(TCLDLLNAME)
@copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
@copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
@echo installing "$(TCLSH)"
@echo Installing "$(TCLSH)"
@copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
@echo installing $(TCLSTUBLIBNAME)
@echo Installing $(TCLSTUBLIBNAME)
@copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
@echo installing $(WINDIR)\tclooConfig.sh
@echo Installing $(WINDIR)\tclooConfig.sh
@copy "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)"
install-libraries:
-@$(MKDIR) "$(LIB_INSTALL_DIR)"
-@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
@echo installing http1.0
@echo Installing http1.0
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
-@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
-@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
@echo installing http2.8
@echo Installing http2.8
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8"
-@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
-@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
@echo installing opt0.4
@echo Installing opt0.4
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
-@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
-@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
@echo installing msgcat1.5
@echo Installing msgcat1.5
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
-@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
-@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
@echo installing tcltest2.3
@echo Installing tcltest2.3
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
-@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
-@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
@echo installing platform1.0
@echo Installing platform1.0
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0"
-@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
-@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
-@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
@echo installing $(TCLDDEDLLNAME)
@echo Installing $(TCLDDEDLLNAME)
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3"
-@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3"
-@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3"
@echo installing $(TCLREGDLLNAME)
@echo Installing $(TCLREGDLLNAME)
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2"
-@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.3"
-@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2"
@echo installing encoding files
@echo Installing encoding files
-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
-@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
@echo installing library files
@echo Installing library files
-@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
-@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)"
-@copy "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)"
+1 -1
View File
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
TCLOO_VERSION=1.0
TCLOO_VERSION=1.0.1