Compare commits

...
Author SHA1 Message Date
andy 681f02daf1 Check in stash. This code probably does not compile as-is. Changes intended to address possible segfault on termination of search. 2017-04-15 15:15:59 +00:00
andy 154ca655c9 Add note to array documentation about the general uselessness of -exact matching. It exists because [array names] had it since check-in [634da00427] (8.4a1), which also added -regexp. 2016-12-25 00:39:48 +00:00
andy 7f81f792a1 Do not deallocate Tcl_ArraySearchStart()-initiated array searches when Tcl_ArraySearchPeek() or Tcl_ArraySearchNext() is called, only when Tcl_ArraySearchDone() is called. This avoids a crash should user code unconditionally call Tcl_ArraySearchDone() at the end of an array enumeration loop. This change does not affect array searches initiated by the Tcl script command [array startsearch]. 2016-12-25 00:23:21 +00:00
andy 21c60565b1 Update tests array-7.16 and array-7.17 and delete test array-7.18 now that bug [46a2410650] is fixed 2016-12-25 00:11:11 +00:00
andy 517a53c57c Merge array-search-unset 2016-12-25 00:04:33 +00:00
andy 5d444e0610 Reference ticket number in tests var-13.2 and var-13.3 2016-12-25 00:00:30 +00:00
andy cd9fecea9c Bug [46a2410650]: Create macro TclIsVarArraySearched to check if an array variable has an active search, and modify INST_UNSET_ARRAY to fall back on the slow unset method for array elements within an array being searched. The slow unset method involves a call to DeleteSearches() which stops all active searches. 2016-12-24 23:58:29 +00:00
andy 17d343aa62 Add test var-13.3 which is a more serious version of test var-13.2. var-13.3 is a SIGSEGV until we fix it. 2016-12-24 23:25:40 +00:00
andy f857e512dd Merge trunk. Test var-13.2 now fails due to [af5c35971a]. 2016-12-24 23:02:02 +00:00
andy 628009fb64 Add test var-13.2 to check that unsetting an array element terminates an array search. This behavior was broken by check-in [af5c35971a]. 2016-12-24 23:00:56 +00:00
jan.nijtmans b76f99d88c Update -DMSTATS functionality, for possible total memory sizes > 2Gb. One more place where use of size_t can increase range. 2016-12-23 15:43:42 +00:00
jan.nijtmans f256ed021d Eliminate the internal macro/function TclNewIntObj: In all cases TclNewLongObj is just as good. 2016-12-23 08:27:02 +00:00
andy f8e15b9d2c Correct typo, credit Brad Lanam for report 2016-12-21 23:23:01 +00:00
jan.nijtmans cbfc7befb0 Make sure that Tcl_GetIntFromObj/Tcl_GetWideIntFromObj/Tcl_GetDoubleFromObj don't set an error in the interp during LinkTraceProc(): The error is supposed to be reported as return value of this function, not the interp. 2016-12-21 14:03:15 +00:00
jan.nijtmans e1e78edbbc Make sure that Tcl_GetIntFromObj/Tcl_GetWideIntFromObj/Tcl_GetDoubleFromObj don't set an error in the interp during LinkTraceProc(): The error is supposed to be reported as return value of this function, not the interp. 2016-12-21 14:01:26 +00:00
jan.nijtmans 97834be313 Make sure that Tcl_GetIntFromObj/Tcl_GetWideIntFromObj/Tcl_GetDoubleFromObj don't set an error in the interp during LinkTraceProc(): The error is supposed to be reported as return value of this function, not the interp. 2016-12-21 13:59:26 +00:00
jan.nijtmans dd3012b0b5 Document that from the "exact" parameter of Tcl_InitStubs(), only bit 0 has meaning. 2016-12-20 10:32:37 +00:00
jan.nijtmans 0dd0678546 more internal use of size_t in stead of int. 2016-12-20 09:46:14 +00:00
jan.nijtmans 3d1095d348 Record the fact that all stub-enabled extensions work in Tcl 8.5+, no 8.6 (or 9.0) features are needed. (Differences between 8.x and 9.0 are handled by a different stub magic value) 2016-12-20 09:36:50 +00:00
andy 834146d5a7 Implement deferring search structure deallocation until the next search function is called. Determination of immediate versus deferred deallocation is done using a new search flags field. 2016-12-20 05:45:34 +00:00
andy 1a31487c96 Merge trunk 2016-12-20 05:12:13 +00:00
andy 83316ca933 Rework array search C API to invoke array traces and report errors. Still need to update documentation accordingly and to add tests demonstrating correct execution of array traces. Also need to handle early search termination due to array elements being added or removed. 2016-12-20 05:08:07 +00:00
jan.nijtmans 972b65b569 Some more internal use of size_t in stead of int. No functional change. 2016-12-16 16:14:57 +00:00
jan.nijtmans b549e19961 Add back testcase winFile-4.10. This test passes anyway, even though it appeared to be Windows 2000 only. 2016-12-15 15:18:21 +00:00
jan.nijtmans 05a9b0d75c Add "file join $grandParentDir tcl8.? library" as possible path for a valid init.tcl.
Some simplifications in use of test restrictions.
2016-12-15 15:07:56 +00:00
andy b69d556f2e Add more array search tests per Brad Lanam. These tests should fail because adding or removing elements should terminate the search, but the tests are not failing in the right way. 2016-12-15 01:01:48 +00:00
jan.nijtmans 6edec95607 Implement all possible TCL_LL_MODIFIER formats in Tcl_ObjPrintf(), can be "ll", "I64" and "L", whatever the platform defines for long long integer. With test-cases. 2016-12-14 15:03:13 +00:00
jan.nijtmans b2c94acd0b Implement all possible TCL_LL_MODIFIER formats in Tcl_ObjPrintf(), can be "ll", "I64" and "L", whatever the platform defines for long long integer. With test-cases. 2016-12-14 14:14:17 +00:00
andy 6cda9a3dd0 Rework array size increase/decrease tests to avoid dummy list element 2016-12-13 19:21:16 +00:00
andy bc6a6d8093 Update ArrayArgs() comments again 2016-12-12 04:53:39 +00:00
andy 11e45a8e8a Update ArrayArgs() comments 2016-12-12 04:52:49 +00:00
andy d207738ea6 Finish implementing array search tests 2016-12-11 05:00:40 +00:00
andy 8be00e1a2d Remove invalid panic. There is an odd case in which exact matching does take a trip through the ArrayNext() search loop despite the fact that ArrayFirst() finds the exact element and sets the search to the end of the hash table. If exact matching is used in combination with a command that stuffs the found element back into the queue (e.g. [array anymore]), ArrayNext() will have to "find" the element again. It's the very next entry, but nevertheless it needs to confirm. 2016-12-11 04:57:38 +00:00
andy dda69c2bd3 Continue array search tests, array-7.12 panics 2016-12-11 04:29:18 +00:00
andy 8f3cc52061 Use setup feature in test array-5.4 2016-12-11 04:08:02 +00:00
andy 7429c43446 Add first array search test 2016-12-11 04:03:35 +00:00
andy 04a12eac75 Adjust test array-5.4 to not use [array set] 2016-12-11 03:05:29 +00:00
andy c1c0c583a8 Reorganize array tests 2016-12-11 03:04:25 +00:00
andy 2e808506d0 Add [array statistics] tests 2016-12-11 02:38:50 +00:00
andy ce63d3dd71 Add [array names] tests 2016-12-10 22:45:51 +00:00
andy c51e8269ab Add [array get] tests 2016-12-10 22:43:58 +00:00
andy dd989ca6aa Add [array exists] tests 2016-12-10 22:42:18 +00:00
andy beb833ddfb Plan remainder of test suite 2016-12-10 22:37:05 +00:00
andy 7dc11bcdf6 Adjust comments 2016-12-10 22:32:12 +00:00
andy 6b7d38ac8a Rename $result to $resultPattern to reduce confusion 2016-12-10 22:16:29 +00:00
andy 1d958d0818 Fix spelling 2016-12-10 22:02:08 +00:00
andy a57f1df696 Add [array unset] tests 2016-12-10 22:01:21 +00:00
andy ac5ad5b7c1 Add first [array unset] test 2016-12-10 21:13:14 +00:00
andy ed9b488466 Add [array size] tests 2016-12-10 21:11:52 +00:00
andy 01fd1c7404 Exchange setup and extra 2016-12-10 20:45:10 +00:00
andy 8c1885a481 Condense non-array error handling tests and incorporate non-array successful result tests 2016-12-10 20:42:31 +00:00
andy 9b015ba94c Add [array set] tests 2016-12-10 19:35:41 +00:00
andy c7b4e5a092 Add more failure cases to test suite, gonna have to do non-error cases one of these days 2016-12-03 00:42:19 +00:00
andy cb62b287a5 Rename [oxor] to [or] and [oxand] to [and], also [oxjoin] to [oxfordJoin] 2016-12-02 22:10:39 +00:00
andy c8f1b6377e Merge trunk 2016-12-02 21:18:39 +00:00
andy 0cd0bb6862 Avoid "warning: format '%llu' expects argument of type 'long long unsigned int', but argument 2 has type 'long unsigned int'" on platforms where TCL_WIDE_INT_IS_LONG. Warning introduced by check-in [e3ba334a42] which was merged to trunk by [eac13870dc]. This fix also was made by [418b169207] which has not yet been merged to trunk. 2016-12-02 21:08:15 +00:00
andy 8a552b0e0a Merge trunk 2016-12-02 21:00:11 +00:00
andy 550d30ff4a Experiment with wrapping [::tcltest::test] 2016-12-02 20:50:54 +00:00
dgp 0714cd9321 Added long comment explaining history and work in progress making bytearray
interfaces usable.
2016-12-02 18:18:59 +00:00
jan.nijtmans 6a1787475c implement "I64" format in Tcl_ObjPrintf as well. Still to be tested. 2016-12-02 15:52:09 +00:00
dgp e9d4e1005e Relocate the cmdEpoch bumps during command deletion so that command resolution
caching works properly in deletion callbacks (destructors!) and delete traces.
2016-12-02 15:39:31 +00:00
jan.nijtmans 74c17b45b2 Implement %ll (WideInt) handling for Tcl_ObjPrintf(). Use it in some places. (now without edit-error in tcl.h, thanks Don!) 2016-12-02 14:52:11 +00:00
dgp c4e63fa109 Repair what appears to be a stray edit error. This restores ability to
build on a TCL_WIDE_INT_IS_LONG platform, but leaves code in tclStringObj.c
raising compiler warnings.  Suspect things still need some reconciliation
in the TCL_WIDE_INT_IS_LONG scenario.
2016-12-02 14:17:40 +00:00
jan.nijtmans ef88cbd89e Implement %ll (WideInt) handling for Tcl_ObjPrintf(). Use it in some places.
Moved to feature branch temporarily.  Breaks build.
2016-12-02 13:50:29 +00:00
dgp 674aeae3b0 Remove dup line. 2016-12-02 13:26:08 +00:00
andy 7c56b863cb Minor test tweaks, add test for nonexistent arrays 2016-12-01 22:32:22 +00:00
dgp 72c1f925db Reports from NSF that command epoch bumping isn't properly timed.
http://paste.tclers.tk/4030
Since the epoch should bump to indicate when Tcl_FindCommand() would
produce a different result from the cached value, the bump ought to be
connected to the state change that would have that effect.  This checkin
appears to be the more correct answer, and it makes the Delete path get
into agreement with the Rename path.  Review would be good.
2016-12-01 20:13:10 +00:00
andy 6a3ecb5e40 Annoyed with tabs, switching to spaces 2016-12-01 18:43:52 +00:00
andy b0b36759a5 Continue implementation of test suite 2016-12-01 18:43:05 +00:00
andy d0c0f228e0 Clarify detection of regular expression errors. While this may seem bogus and inconsistent, it is actually the undocumented baseline behavior of [array names -regexp **]. 2016-12-01 17:28:25 +00:00
dgp e42f5d61b2 So long as we register only one, we can have multiple Tcl_ObjTypes with
the same name.  This smooths migration. See obj-2.2 and tclsqlite usage.
2016-12-01 17:25:40 +00:00
andy 77b96afba5 Implement [array names] in terms of Tcl_ArrayNames(), also make Tcl_ArrayNames() treat non-array like empty array for consistency with documentation, other functions, and baseline [array names] 2016-12-01 17:08:24 +00:00
dgp a8e3472731 Created a new "proper bytearray" Tcl_ObjType so we can use bytearrays
as bytearrays without all this fussing about over purity.
2016-12-01 13:20:47 +00:00
jan.nijtmans 95d020a657 compatability -> compatibility 2016-12-01 11:44:23 +00:00
jan.nijtmans 6d7abfd8a9 compatability -> compatibility 2016-12-01 11:42:07 +00:00
jan.nijtmans bbaecb023a compatability -> compatibility 2016-12-01 11:39:40 +00:00
andy 3f2cb54333 Correct tab stops 2016-12-01 01:49:03 +00:00
andy a396f84b31 Begin implementation of array test suite 2016-11-30 19:47:13 +00:00
andy d334401183 Document filter options to [array exists] 2016-11-30 19:35:25 +00:00
andy 6a0f0076bc Be more consistent in usage of italic text 2016-11-30 17:57:26 +00:00
andy 3a9990cb01 Minor documentation correction pointing out that Tcl_ArraySet allows the variable to not exist in which case it will create it 2016-11-30 17:53:15 +00:00
dgp c25e21b7bb Route all [string repeat] operations through a common implementation.
Code that to preserve bytearrays, eliminate unnecessary string rep
generation, increase efficiency, and encapsulate access to internal rep
details.
2016-11-30 03:08:24 +00:00
andy 42b47a6d64 Restore tests set-old-8.46 and set-old-10.2. Note: this is commit number 20000 2016-11-29 19:45:52 +00:00
andy 2c1225e7dd Merge trunk 2016-11-29 19:39:08 +00:00
andy 6cbc96a10d Add filtering capability to [array exists] and Tcl_ArrayExists() so that individual elements can be tested for. For example, [array exists arrayName *] is a higher-performance alternative to [array size arrayName] for testing if an array is non-empty since it doesn't fully enumerate the array and only checks if there is at least one matching element. 2016-11-29 19:29:16 +00:00
andy 5eb1f0c955 Add comments to tcl.h more clearly indicating which flag values are reserved to better avoid future collisions 2016-11-29 18:50:07 +00:00
dgp 3489a76210 Where feasible, convert concatenation panics into errors. 2016-11-29 18:46:41 +00:00
andy 28048d3791 Update [array] man page for new/expanded filter options 2016-11-29 18:46:34 +00:00
jan.nijtmans 357515037a Minor simplifications. Eliminate FUNCPRT from regexp engine. Fix compile-error (non-debug) in tclDictObj.c, from previous commit 2016-11-29 13:03:15 +00:00
jan.nijtmans a435d9e14b more internal use of size_t (in stead of int) 2016-11-29 11:10:10 +00:00
andy 128e222ada Man page tweak 2016-11-28 17:53:45 +00:00
andy 83ad62ad4d Double backslashes in man page 2016-11-28 16:47:43 +00:00
andy 990bb19ffd Add manual page for new array functions 2016-11-28 06:06:15 +00:00
andy 1d514c5f57 Fix set-old-8.35 2016-11-28 04:47:38 +00:00
andy 94cc1a4ddb Fix set-old-8.56 2016-11-28 04:31:32 +00:00
andy 1bf28f3806 Add Tcl_ArrayStatistics() 2016-11-28 04:21:58 +00:00
andy 80888b3fc9 Change Tcl_ArraySet() to always report errors without having to specify TCL_LEAVE_ERR_MSG 2016-11-28 02:35:33 +00:00
andy fbdfb60849 Remove most instances of TCL_LEAVE_ERR_MSG in favor of making Tcl_Array*() functions treat nonexistent and scalar variables as empty arrays and always reporting other kinds of errors, was very confusing having the absence of TCL_LEAVE_ERR_MSG only inhibiting variable lookup errors. Clean up documentation throughout. Merge ArraySize() into Tcl_ArraySize() and make ArraySizeCmd() use Tcl_ArraySize() directly now that the error handling policy is consistent. Rename *existsPtr to *intPtr for consistency with other public functions. Change Tcl_ArraySize() to use *intPtr to report the size rather than returning it. 2016-11-28 01:20:41 +00:00
andy 3fe79a32c6 Change TCL_MATCH_GLOB to avoid collision with the deprecated TCL_PARSE_PART1 flag 2016-11-27 20:37:19 +00:00
andy 2bf69fa2b7 Renumber and rearrange new Tcl_Array*() functions to have a somewhat more logical ordering 2016-11-26 20:03:13 +00:00
andy b353bc10cb Revert unintended change to Tcl_ZlibStreamInit() argument name 2016-11-26 07:39:31 +00:00
andy 45c7b5098e Implement Tcl_ArrayGet(), add -exact|-glob|-regexp options to [array get] 2016-11-26 07:30:58 +00:00
andy f67b7c4e94 Remove new test trace-41.1 since it is a duplicate of test var-18.1 2016-11-26 07:21:18 +00:00
andy 5c93cd4200 Remove optimization that runs afoul of test var-18.1 2016-11-26 07:19:59 +00:00
andy f3aab2af7c Update test for [array unset] mode option 2016-11-26 07:11:00 +00:00
andy fb45801148 Implement Tcl_ArrayExists() 2016-11-26 02:14:08 +00:00
andy cde090bbd2 Fold create argument to ArrayVar() into TCL_VAR_CREATE flags bit which only ArrayVar() understands. Implement Tcl_ArrayUnset(). Add a test case showing bug [2939073] which was fixed long ago but could have been disturbed by any refactoring done to [array unset]. [array unset] now has -exact|-glob|-regexp options to customize the match style. 2016-11-26 01:57:34 +00:00
andy a463dba6d5 Simplify function description comment 2016-11-25 18:24:02 +00:00
andy b03c2cad93 Merge CleanupVar() into TclCleanupVar(), no need for them to be separate 2016-11-25 18:11:59 +00:00
andy 8bbff6bc30 Rename dictObj to dictPtr for consistency with other public variable function arguments, even though I like dictObj better 2016-11-25 18:08:20 +00:00
andy 88b52cca59 Rename TclArraySet() to Tcl_ArraySet() and put in tcl.decls. Enhance ArrayVar() to support array creation, and update Tcl_ArraySet() to use it. 2016-11-25 18:05:49 +00:00
jan.nijtmans df537d0dfb Eliminate some macros that are no longer used/needed. 2016-11-25 11:47:54 +00:00
andy d738104aff Add Tcl_ArraySearchPeek() 2016-11-25 08:17:16 +00:00
andy dbb0afd2b0 Add filter options to more [array] subcommands, implement with a common function 2016-11-25 07:55:57 +00:00
andy 032df7c99f Merge trunk 2016-11-25 07:33:14 +00:00
andy 1000af34fa Allow [array names -regexp] to use backreferences. This capability was broken by [71270e9141]. See also bug [1366683]. 2016-11-25 07:31:46 +00:00
andy f1a0cd2e9d Add filtering options to [array size] command 2016-11-25 07:02:21 +00:00
andy b45f0bb10f Correct bug by splitting Tcl_ArrayNames() to high-level Tcl_ArrayNames() operating on a variable name and low-level ArrayNames() operating on a variable pointer so that the [array names] command can customize its handling of non-array variables 2016-11-25 06:27:43 +00:00
andy f81e77119d Implement Tcl_ArrayNames(), still have a bug to fix though 2016-11-25 05:53:55 +00:00
andy 91725a719a Implement various array functions in terms of ArrayVar() to avoid repetition of trace code, and restore TCL_LEAVE_ERR_MSG to accommodate the functions that need it 2016-11-25 05:11:23 +00:00
andy 8055d2fd9a Implement Tcl_ArraySearchDone() 2016-11-25 04:42:04 +00:00
andy 04a0e60983 Implement Tcl_ArraySearchNext() 2016-11-25 04:31:09 +00:00
andy da411794db Remove need for passing TCL_LEAVE_ERR_MSG to various array functions 2016-11-25 04:11:54 +00:00
andy c4ee3e6388 Correct test failures in set-old.test 2016-11-25 03:56:33 +00:00
andy 7fa35ac034 Split ArrayNext() into ArrayFirst() and ArrayNext(), and reimplement other array functions in terms of these two functions 2016-11-25 03:33:01 +00:00
andy d37425bc05 Remove spurious article in comments 2016-11-25 01:39:13 +00:00
andy 02e8249054 Rename LookupArrayVar() to ArrayVar(), add ArrayNext(), reimplement ArraySize() in terms of ArrayNext(), fix typo (recount -> refcount) 2016-11-25 01:36:27 +00:00
andy 6edd446f14 Improve comments, add interp to Tcl_ArraySearch so Tcl_ArraySearchNext() can report regular expression errors. Alternate approach would be giving Tcl_ArraySearchNext() an interp argument, but there is no need to send errors to a different interpreter than the one in which the search was created. 2016-11-24 22:51:15 +00:00
andy e7967fc2c8 Implement Tcl_ArraySearchStart() 2016-11-24 22:38:00 +00:00
andy 998d27f2c2 Simplify LookupArrayVar() interface 2016-11-24 22:24:51 +00:00
andy a60c64b7fc Fold VerifyArray() into LookupArrayVar(), begin adding filtering capabilities to array search 2016-11-24 22:06:43 +00:00
andy ee28e88470 Add exact/glob/regexp filter capability to new array size and enumeration functions. Change Tcl_ArrayNames() to append to a list-type Tcl_Obj to simplify memory management. Fix typo in name of Tcl_ArraySearchDone(). 2016-11-24 21:33:07 +00:00
andy f24a078b50 Improve comments a little 2016-11-24 20:12:09 +00:00
andy 74590c5ddc Merge trunk 2016-11-24 19:22:48 +00:00
andy 5e9f624428 Partially backout [ef4da65408] because AppendPrintfToObjVA() (used indirectly by [tcl::unsupported::disassemble]) does not yet support wide and bignum arguments. This fixes a SIGSEGV in compile.test and makes [disassemble] work again. 2016-11-24 19:21:12 +00:00
andy 3f12ad7691 Correct reporting of trace errors in [array size] 2016-11-24 18:49:32 +00:00
andy 1aea568d6e Correct sense of scalar variable detection 2016-11-24 18:46:15 +00:00
andy e2e7983c0e Get rid of now-unnecessary varPtr2 variable, add stubbed-out (pun unintentional) implementations of new Tcl_Array*() functions 2016-11-24 18:42:04 +00:00
andy 4725a30a34 Reorganize code into separate LookupArrayVar() and ArraySize() functions so that [array size] can separately detect and report array trace errors 2016-11-24 18:36:22 +00:00
andy b663b683d5 Update stubs init 2016-11-24 18:35:09 +00:00
andy 2085fc1daf Rename part1Ptr arguments to varNamePtr 2016-11-24 18:34:50 +00:00
jan.nijtmans c2f9601344 Make compileEpoch "unsigned int", and start counting at 1. 2016-11-24 13:33:32 +00:00
jan.nijtmans c8d9ab8790 typos 2016-11-24 10:26:28 +00:00
dkf f096df2170 Corrections to misleading comments. 2016-11-22 15:04:28 +00:00
andy 896caee843 [array size] should 0 if argument does not name an array. TODO: Distinguish between existence errors and trace errors. Hide the former and report the latter for compatibility with [array size]. 2016-11-21 18:25:04 +00:00
andy 8292447454 Initial commit of new C API for array enumeration. TIP forthcoming. Work far from complete, only Tcl_ArraySize() implemented as of yet. See [http://wiki.tcl.tk/48264] for more information. 2016-11-21 13:12:11 +00:00
jan.nijtmans 990d6fd6f1 More internal use of size_t in stead of int. 2016-11-21 10:15:24 +00:00
dkf da608f8c61 Minor: fix the indentation of comments. 2016-11-18 15:51:27 +00:00
jan.nijtmans c58016090f Fix mp_cnt_lsb() signature, so it matches the signature used in Tcl 2016-11-18 10:53:45 +00:00
jan.nijtmans e7f46501e2 Fix mp_cnt_lsb() signature, so it matches the signature used in Tcl. Add two missing "static" keywords in tclUnixNotfy.c. Remove some more files in libtommath directory which are not useful for Tcl. 2016-11-18 10:23:24 +00:00
jan.nijtmans 13a2801fd7 Fix [e6f27aa56fa51bfc1752ce768bf0d301c60bfd2c|e6f27aa56f]: Update libtommath to 1.0 2016-11-18 09:50:37 +00:00
andy 995aaf8bfd Remove extra space in documentation for [file stat] 2016-11-18 03:34:32 +00:00
jan.nijtmans d7da846591 Fix libtommath's mp_radix_size() function such that it returns 2 for single-digit numbers. Add testcases for mp_radix_size() and mp_iseven(). Undo useless change in bn_mp_add_d.c (bring back libtommath's version). 2016-11-17 16:26:50 +00:00
jan.nijtmans 2287394ba1 Fix libtommath's mp_radix_size() function such that it returns 2 for single-digit numbers. Add testcases for mp_radix_size() and mp_iseven(). Undo useless change in bn_mp_add_d.c (bring back libtommath's version). 2016-11-17 16:24:37 +00:00
jan.nijtmans 8d1caeae4d Fix libtommath's mp_radix_size() function such that it returns 2 for single-digit numbers. Add testcases for mp_radix_size() and mp_iseven(). Undo useless change in bn_mp_add_d.c (bring back libtommath's version). 2016-11-17 16:12:14 +00:00
jan.nijtmans 1be35f340f Restore bn_mp_radix_size.c to exact copy of libtommath-1.0 version: Since the radix_size of "9" should return 2, not 3. Add test-case to prove that. 2016-11-17 15:30:32 +00:00
jan.nijtmans ca471eb748 Restore bn_mp_add_d.c to exact copy of libtommath-1.0 version: Since the mp_clamp() function already restores the sign of it's argument to positive if c->used ==0, it is not necessary to do that twice. Therefore, the original version of the code is correct. 2016-11-17 13:18:17 +00:00
jan.nijtmans 538960215f Add test-case for mp_iseven(). If mp_iseven(0) ever returns 0, we will be warned that we are using the wrong mp_iseven() function. 2016-11-17 11:38:13 +00:00
jan.nijtmans 1375c96d2f Bring in fix for mp_iseven().... almost missed that .... This should be given a dedicated test-case. Now everything taken from "gahr-ticket-e6f27aa56f" branch is handled. 2016-11-17 11:03:39 +00:00
jan.nijtmans 8f07b4a94c Merge trunk. Re-generate tclTomMath.h. Use faster exponentiation-function from libtommath 1.0 (in tclExecute.c). 2016-11-17 10:46:09 +00:00
jan.nijtmans 2edb1dcd83 Remove subdirectories of "libtommath", and various individual related files, not taking any part in the Tcl build. Makes the Tcl distribution smaller without sacrificing anything.
And remove the TCL_TOMMATH define, which was never used for anything.
2016-11-17 09:33:08 +00:00
jan.nijtmans 37f6932c0a Remove subdirectories of "libtommath", and various individual related files, not taking any part in the Tcl build. Makes the Tcl distribution smaller without sacrificing anything. 2016-11-17 09:24:05 +00:00
jan.nijtmans 9e7c15f53e merge trunk 2016-11-16 15:59:40 +00:00
jan.nijtmans f850132635 (experimental) Upgrade to libtommath 1.0 (actually by merging all changes between libtommath 0.42.0 and 1.0). Still to be tested thourougly, before doing anything with it. 2016-11-16 15:22:26 +00:00
jan.nijtmans f10147dbfe import libtommath 1.0 2016-11-16 13:04:26 +00:00
jan.nijtmans 0dd529776d Use more "size_t" in stead of "int" internall. Also eliminate a lot of type-casts which are not necessary any more. 2016-11-16 10:55:40 +00:00
dkf ea1423a2ab See Itcl Bug [1b28657c0e]. Make methodNameType honor the Tcl_ObjType contract. 2016-11-15 13:33:35 +00:00
dkf 5b71bf5ea8 See Itcl Bug [1b28657c0e]. Make methodNameType honor the Tcl_ObjType contract. 2016-11-15 13:32:51 +00:00
dkf a5538d84c4 Slightly more efficient version as this is Hot Path code. 2016-11-15 13:31:02 +00:00
dgp addd1694e0 See Itcl Bug [1b28657c0e]. The methodNameType fails to honor the Tcl_ObjType
contract. Need dkf review on suitability of this fix.
2016-11-14 17:01:37 +00:00
jan.nijtmans 7cdd87e4f1 Merge core-8-6-branch 2016-11-14 14:26:38 +00:00
jan.nijtmans 0b9cb76206 Better fix for the usability of TCL_NO_DEPRECATED on MacOSX 2016-11-14 14:25:13 +00:00
jan.nijtmans 99fd1215e2 Better fix for the usability of TCL_NO_DEPRECATED on MacOSX. 2016-11-14 14:20:13 +00:00
venkat 6e380ef6e9 Merge tzdata2016i from IETF 2016-11-12 11:19:52 +00:00
venkat ae6e14e33c Merge tzdata2016i from IETF 2016-11-12 11:19:26 +00:00
venkat bc5ffbb3b2 Update to tzdata2016i from IETF 2016-11-12 11:18:31 +00:00
jan.nijtmans 92b58040dd Fix harmless gcc warning message: using "unsigned" doesn't serve any purpose, actually. 2016-11-11 14:53:58 +00:00
jan.nijtmans fcc907b2a6 Fix [79614fb8b61983ac8ef30ea8752c310465798fc7|79614fb8b6]: "glob", "encoding system" and encoding-free filesystems 2016-11-11 10:58:54 +00:00
jan.nijtmans 25ba428ff9 Fix [79614fb8b61983ac8ef30ea8752c310465798fc7|79614fb8b6]: "glob", "encoding system" and encoding-free filesystems 2016-11-11 10:55:45 +00:00
jan.nijtmans 2020e9be61 Fix [79614fb8b61983ac8ef30ea8752c310465798fc7|79614fb8b6]: "glob", "encoding system" and encoding-free filesystems 2016-11-11 10:53:10 +00:00
jan.nijtmans 6497c6c6ee On OSX, there is a conflict with the "define panic" and definitions in "mach.h". 2016-11-10 14:21:41 +00:00
jan.nijtmans 31647bcceb On OSX, there is a conflict with the "define panic" and definitions in "mach.h". 2016-11-10 14:19:28 +00:00
dgp 3555752d45 Route all [string last] operations through a common implementation. 2016-11-08 02:56:11 +00:00
dgp 37fb43ad48 Purge disabled code. 2016-11-07 20:18:30 +00:00
dgp cd2858d1d0 Refactor to channel all [string first] functions through a single implementation. 2016-11-07 20:11:11 +00:00
dgp 790b302275 Optimize case of all single-byte chars. 2016-11-07 20:04:22 +00:00
dgp dc11ffbbdb Consolidate the "find empty string" cases. 2016-11-07 19:41:15 +00:00
dgp 1571dc01bb Implement direct eval [string first] with the refactored engine. 2016-11-07 19:28:25 +00:00
dgp 4dc2505e43 First draft refactoring the [string first] functionality. 2016-11-04 21:29:30 +00:00
dgp 18a2ebc51d [824752f10e] Use LIST_MAX instead of INT_MAX for unknown number of elements to the end of the list. 2016-11-04 14:56:19 +00:00
dgp da3723c942 [8245752f10e] Use LIST_MAX instead of INT_MAX for unknown number of elements
to the end of the list.
2016-11-04 14:54:38 +00:00
dgp 27ef344b9c merge mark 2016-11-04 14:49:22 +00:00
dgp 885ced5608 [824752f10e] More robust, portable check for integer overflow. 2016-11-04 14:48:36 +00:00
dgp b1fe66323b close fork 2016-11-04 14:42:14 +00:00
dgp a188ceee21 [824752f10e] More robust, portable check for integer overflow. 2016-11-04 14:40:54 +00:00
dgp eb87ed60f6 close fork 2016-11-04 14:39:00 +00:00
dgp bc94a394c9 [824752f10e] More robust, portable check for integer overflow. 2016-11-04 14:37:50 +00:00
gahr 46d871617f merge core-8-5-branch ([824752f10e] Avoid calling Tcl_SetObjResult if interp is NULL) 2016-11-04 14:24:42 +00:00
gahr d654ce6429 merge core-8-5-branch ([824752f10e] Avoid calling Tcl_SetObjResult if interp is NULL) 2016-11-04 14:23:43 +00:00
gahr 452f14ebb5 [824752f10e] Avoid calling Tcl_SetObjResult if interp is NULL 2016-11-04 14:21:04 +00:00
jan.nijtmans 0a7d5ef6ed Fix the generated copyright sections in the HTML help file 2016-11-04 11:51:22 +00:00
jan.nijtmans f785a01764 Fix the generated copyright sections in the HTML help file. 2016-11-04 11:50:22 +00:00
jan.nijtmans 274f081025 Make packages msgcat and tcltest work unmodified in "novem". Make more test-cases work unmodified in "novem". 2016-11-04 11:38:09 +00:00
jan.nijtmans 76ed3d5b55 Make packages msgcat and tcltest work unmodified in "novem". 2016-11-04 11:32:44 +00:00
jan.nijtmans fba10e8615 merge core-8-6-branch (http package version update) 2016-11-02 12:45:47 +00:00
jan.nijtmans 1f0c1b800d Update http version number to 2.8.10, due to [838e99a76d] 2016-11-02 12:44:32 +00:00
jan.nijtmans a7e97de50a Update http version number to 2.7.14, due to [838e99a76d] 2016-11-02 12:41:04 +00:00
Joe Mistachkin ea11870f5b Fix the generated copyright sections in the HTML help file. 2016-11-02 01:42:49 +00:00
dgp 95b511bac2 Refactor to channel all [string cat] functions through a single implementation. 2016-11-01 16:18:08 +00:00
dgp 17e1ea228c Replace indexing with pointer increments. 2016-11-01 15:42:50 +00:00
dgp 53abdcc518 Trim away obsolete code. 2016-11-01 15:12:07 +00:00
dgp d963b1acb7 Expand all the cases of the [string cat] engine. 2016-11-01 15:07:30 +00:00
dgp 04432d4dd1 Reduce copies in the pure binary implementation of [string cat]. 2016-10-31 18:10:21 +00:00
dgp 3e4f5907b6 Complete the "pure binary" implementation of the [string cat] engine. 2016-10-31 16:15:16 +00:00
dgp 4a159c5199 merge trunk 2016-10-31 14:18:03 +00:00
dgp b53cf6d38c Coverage tests for INST_STR_CONCAT1 byterarray ops. 2016-10-31 14:17:31 +00:00
dkf 779b8dad76 [253ba6e818] Improved description of [variable] behaviour. 2016-10-30 16:52:50 +00:00
dkf cd428c1a44 [253ba6e818] Improved description of [variable] behaviour. 2016-10-30 16:16:29 +00:00
dkf 16dbe3f5a2 [1ae12987cb] Ensure that deleting the [history] command deletes its storage. 2016-10-30 08:31:21 +00:00
dkf 7b989f0312 [1ae12987cb] Ensure that deleting the [history] command deletes its storage. 2016-10-30 08:22:13 +00:00
dkf 994e1d8062 One more place where the internal API change can be used easily. 2016-10-30 05:07:47 +00:00
dkf de8e3be492 [b26e38a3e4] Ensure that compressing streams manage buffers correctly in all cases. 2016-10-30 05:05:46 +00:00
dkf d44a63b65b [b26e38a3e4] Ensure that compressing streams manage buffers correctly in all cases. 2016-10-30 05:04:54 +00:00
dkf 423d995e0d Fix the bug. Make use of zlib API in this area more like a Tcl API with wrapper function. 2016-10-30 05:02:46 +00:00
dkf 5c37d95180 Added test for bug 2016-10-29 21:03:25 +00:00
dgp 970922295a WIP 2016-10-28 20:33:55 +00:00
dgp 31690ce7fb revise [dict append] to make use of common [string cat] engine. 2016-10-28 16:55:44 +00:00
dgp 630d4b9211 merge trunk 2016-10-28 15:47:07 +00:00
dgp 7faf4f27a4 Add optimization to [dict append]. 2016-10-28 15:46:49 +00:00
dgp dd1c28a788 When appropriate, implement [join] with the common [string cat] engine. 2016-10-28 14:59:27 +00:00
dgp afd6d5649f Add obvious optimizations to [join] implementation. 2016-10-28 14:45:54 +00:00
dgp e9d7b07476 merge trunk 2016-10-28 14:28:40 +00:00
dgp b8ffbb14c4 Add warning commentary making important assumptions explicit. 2016-10-28 14:27:59 +00:00
dgp 39dbbd57af Add warning commentary making important assumptions explicit. 2016-10-28 14:26:18 +00:00
dgp bbfc83c86f Add warning commentary making important assumptions explicit. 2016-10-28 14:23:25 +00:00
dgp d31beb3e7f merge trunk 2016-10-28 14:06:36 +00:00
dgp aa3b157338 Add obvious optimization to Tcl_GetCharLength(). 2016-10-28 14:06:15 +00:00
dgp bf27b64405 Convert INST_STR_CONCAT1 to the common string cat implementation. 2016-10-27 20:06:36 +00:00
dgp 76b6b03be7 Start bringing all string cat operations into one place so it can be coded
correctly one time instead of badly multiple times.
2016-10-27 19:39:49 +00:00
venkat c205f272f7 Merge timezone data tzdata2016h 2016-10-26 08:04:36 +00:00
venkat 0551ecffd6 Merge timezone data tzdata2016h 2016-10-26 08:04:10 +00:00
venkat 13967f965d Update timezone data to tzdata2016h from IETF 2016-10-26 08:03:17 +00:00
dgp 79ff282b02 merge 8.6 2016-10-21 13:12:16 +00:00
dgp 9afdf28497 Repair recently opened memleak. 2016-10-20 20:02:19 +00:00
dgp bfae5bf492 EVIL HACKs are bad. Unnecessary ones are intolerable. Bad tests cause trouble. 2016-10-20 17:54:47 +00:00
dgp 925bd5794e Use memcmp where possible. 2016-10-18 19:16:35 +00:00
dgp ae54e070a1 [eb6b68c1a9] Simple fix for [string replace] error demonstrated by new test. 2016-10-14 19:29:52 +00:00
dgp 8b894ab295 [eb6b68c1a9] Simple fix for [string replace] error demonstrated by new test. 2016-10-14 19:28:46 +00:00
dgp e35292f314 Merge INST_STR_REPLACE fixes and improvements. 2016-10-13 16:56:23 +00:00
dgp 7f0e6652c7 Another streamline. 2016-10-13 16:50:06 +00:00
dgp 7634bdaef2 Stop invading the String internals to work around a bug. Fix it instead. 2016-10-13 16:43:05 +00:00
dgp 9cb330963b Streamline the substring copying case of [string replace] bytecode execution. 2016-10-13 15:37:45 +00:00
dgp 4dc1a8a588 merge TclParseNumber fixes 2016-10-12 13:47:32 +00:00
dgp 66f257a588 [be003d570f] TclParseNumber() failed to fully implement TCL_PARSE_BINARY_ONLY. 2016-10-12 13:46:14 +00:00
dgp 36825d23b9 [be003d570f] TclParseNumber() failed to fully implement TCL_PARSE_OCTAL_ONLY. 2016-10-12 13:42:40 +00:00
dgp 326e0a8fdf Add a test too. 2016-10-12 13:38:28 +00:00
dgp 29fdaa6dcd [be003d570f] TclParseNumber() failed to fully implement TCL_PARSE_OCTAL_ONLY. 2016-10-12 13:31:07 +00:00
dkf ae0ad313fd [74bc0e44f5] Doc tweak. 2016-10-12 09:58:12 +00:00
dkf ec64cc0418 [74bc0e44f5] Doc tweak. 2016-10-12 09:57:49 +00:00
dkf c482675d84 [74bc0e44f5] Doc tweak. 2016-10-12 09:57:15 +00:00
jan.nijtmans 7dd13b72b6 Fix [3cc1d91345]: duplicate calls to TclpFreeAllocCache() on thread exists 2016-10-11 21:52:57 +00:00
jan.nijtmans 54c0881e9d Fix [3cc1d91345]: duplicate calls to TclpFreeAllocCache() on thread exists 2016-10-11 21:43:44 +00:00
jan.nijtmans d81daf76bd Fix [3cc1d91345]: duplicate calls to TclpFreeAllocCache() on thread exists 2016-10-11 21:35:27 +00:00
dkf 11e9b6a9a5 [62b36e326c] Noted edge case in behaviour of [concat] with empty arguments. 2016-10-09 16:02:38 +00:00
dkf 8fe7f3fcdf [62b36e326c] Noted edge case in behaviour of [concat] with empty arguments. 2016-10-09 16:02:16 +00:00
dkf f3e9f9caa3 [62b36e326c] Noted edge case in behaviour of [concat] with empty arguments. 2016-10-09 16:01:53 +00:00
dkf 28d5ff4eb5 [7114ac6141] Improve testing and docs of Tcl_GetInt and Tcl_GetDouble. No behaviour change. 2016-10-09 15:22:20 +00:00
dkf 71c2d1a883 [7114ac6141] Improve testing and docs of Tcl_GetInt and Tcl_GetDouble. No behaviour change. 2016-10-09 15:21:26 +00:00
dkf c8597887e4 Be more accurate about scan's %i 2016-10-09 12:03:30 +00:00
ferrieux 05009534ee Be more accurate about scan's %i 2016-10-09 10:35:24 +00:00
dkf f50a4eed54 [74bc0e44f5] Document result of [http::unregister]. 2016-10-08 17:10:40 +00:00
dkf 90813dfce8 [74bc0e44f5] Document result of [http::unregister]. 2016-10-08 17:10:21 +00:00
dkf a16868a54c [74bc0e44f5] Document result of [http::unregister]. 2016-10-08 17:10:02 +00:00
dkf c4eac3e8eb [838e99a76d] Ensure that encodings are handled with application/xml and friends. 2016-10-08 16:41:51 +00:00
dkf 7b78869343 [838e99a76d] Ensure that encodings are handled with application/xml and friends. 2016-10-08 16:40:35 +00:00
dkf ab8a39e6b9 [838e99a76d] Ensure that encodings are handled with application/xml and friends. 2016-10-08 16:38:42 +00:00
dgp 870f61c05d Update [string map] tests to get illustration of need for pure dict
restriction up to date with ordered dicts.
2016-10-07 18:52:57 +00:00
pooryorick 6585306973 Fix typos in expr documentation. 2016-10-05 04:53:49 +00:00
pooryorick b1d510f1db Rewrite expr documentation. Among other things, fixes [ef5373e6fa0617ee]. 2016-10-05 00:05:55 +00:00
dkf 111f52e7ed [4d5ae7d88a] Stop crashes with asynchronous connects to hosts without addresses. 2016-10-04 19:12:33 +00:00
dkf 6548fc4ad1 [4d5ae7d88a] Stop crashes with asynchronous connects to hosts without addresses. 2016-10-04 19:11:07 +00:00
max a629b0ba31 When opening a server socket on an ephemeral port, make sure that the
port number that gets picked for IPv4 is also available on IPv6. If
not, start all over for up to ten times to find a port number that is
available on both protocols.
2016-10-04 13:31:49 +00:00
pooryorick 8c066a970f Fix documentation of [expr] operators, replacing "divisor" with "dividend" 2016-10-03 16:49:58 +00:00
jan.nijtmans 29b9de871c (cherry-pick): Fix [2bf561854c55a], interp alias to command whose name is the empty string. 2016-10-03 14:53:32 +00:00
pooryorick a9dbadf46a Fix [2bf561854c55a], interp alias to command whose name is the empty string. 2016-10-03 01:10:16 +00:00
venkat 02e79b9ec1 Merge tzdata2016g from ietf.org 2016-10-02 19:26:30 +00:00
venkat 5aa514f49a Merge tzdata2016g from ietf.org 2016-10-02 19:25:58 +00:00
venkat 2bc8d915a2 Update tzdata to 2016g from ietf.org 2016-10-02 19:24:52 +00:00
gahr c4f7e08fc6 [4d5ae7d88a] Restore default-to-error logic in TcpConnect 2016-09-27 20:06:49 +00:00
jan.nijtmans 008c7038cb merge core-8-6-branch 2016-09-26 09:10:35 +00:00
jan.nijtmans dfb2a3f2e2 Fix the 'htmlhelp' target so that it compiles cleanly and includes all the appropriate HTML files.
Permit static linking to the MSVCRT as a stand-alone option. 
Patch by Joe Mistachkin.
2016-09-26 09:08:13 +00:00
jan.nijtmans e8aa220d08 merge core-8-6-branch. Undo changes to coffbase.txt (they cause overlap with Tk) 2016-09-21 09:36:35 +00:00
jan.nijtmans 8d3c0c2e81 Merge core-8-6-branch. Add more comments to tclLiteral.c, contributed by mr_calvin 2016-09-21 09:28:39 +00:00
jan.nijtmans 3adfe07f74 Make it more likely that compiles with VS2012/VS2013 actually work on Windows XP. See: [https://tedwvc.wordpress.com/2014/01/01/how-to-target-xp-with-vc2012-or-vc2013-and-continue-to-use-the-windows-8-x-sdk/] 2016-09-21 09:20:54 +00:00
jan.nijtmans 7aae664d12 Make it more likely that compiled with VS2012/VS2013 actually work on Windows XP. See: [https://tedwvc.wordpress.com/2014/01/01/how-to-target-xp-with-vc2012-or-vc2013-and-continue-to-use-the-windows-8-x-sdk/] 2016-09-21 09:15:34 +00:00
Joe Mistachkin cdb1ef8aac Permit static linking to the MSVCRT as a stand-alone option. Enable WinXP SDK compatibility. 2016-09-19 18:48:16 +00:00
jan.nijtmans e7e4c74b7f merge core-8-6-branch 2016-09-16 09:09:25 +00:00
jan.nijtmans 3d6c6683bb Fix [c7d0bc9a549714e0]: Newly introduced unshared (local-only) literals from cmd resolvers cause Tcl_Obj leaks. 2016-09-16 09:06:41 +00:00
jan.nijtmans bf9e61ca6a Proposed fix for [c7d0bc9a549714e0]. Thanks to mr_calvin 2016-09-15 13:22:49 +00:00
dgp db811061d4 Revert b98ee56376. The "bug" fixed was documented behavior. 2016-09-09 12:36:53 +00:00
gahr 63a316c43b Remove unnecessary use of fpsetround. See https://bugs.freebsd.org/212512 2016-09-09 07:28:45 +00:00
dgp 3da8f74e75 [7f02ff1efa] Fix scope for var unset traces when procs return.
*** POTENTIAL INCOMPATIBILITY ***
2016-09-08 02:38:39 +00:00
dgp 3833c42f54 New test trace-18.5 for the bug. Updated trace-18.1 which was tuned to it. 2016-09-08 02:34:37 +00:00
dgp 2bfb7b96c0 Attempt to fix [7f02ff1efa]. Make trace-18.1 fail. Suspect test is an
experiment that preserves the bug.
2016-09-07 18:31:58 +00:00
dgp 35141afcc9 [4dbdd9af14] Plug mem leak when var unset trace re-creates namespace var. Thanks mr_calvin for report and fix. 2016-09-07 18:09:30 +00:00
dgp 6053836b97 [4dbdd9af14] Plug mem leak when var unset trace re-creates namespace var. Thanks mr_calvin for report and fix. 2016-09-07 17:45:33 +00:00
dgp e13460b1fb [4dbdd9af14] Plug mem leak when var unset trace re-creates namespace var.
Thanks mr_calvin for report and fix.
2016-09-07 17:30:18 +00:00
dgp 41512fe1fa Improve the comments and add a test. 2016-09-07 16:19:42 +00:00
jan.nijtmans 4ef0c69aaa Fix [d4e7780ca1681cd095dbd81fe264feff75c988f7|d4e7780ca1]: "global" cmd literal sharing vs. per-interp resolvers 2016-09-07 13:34:41 +00:00
jan.nijtmans 7660c04aff Fix [d4e7780ca1681cd095dbd81fe264feff75c988f7|d4e7780ca1]: "global" cmd literal sharing vs. per-interp resolvers 2016-09-07 12:54:51 +00:00
dgp 7ca470456b [4dbdd9af14] Proposed fix for mem leak. 2016-09-06 20:30:07 +00:00
dkf ab18c108f7 Fixed bug in pushed transforms with full internal buffers not writing out. 2016-09-06 10:46:49 +00:00
dkf 7ccdd3657b Fixed bug in pushed transforms with full internal buffers not writing out. 2016-09-06 10:44:45 +00:00
jan.nijtmans 98dbefe2cc Additiona patch/suggestion from Gustaf. This indeed fixes the crash in oo.test. Looks good to me, so only waiting for final feedback from Gustaf and eventually feedback from other people. 2016-09-06 08:25:18 +00:00
jan.nijtmans b748232291 some more clean-up 2016-09-05 14:52:01 +00:00
jan.nijtmans d35a5023da merge core-8-6-branch 2016-09-05 14:12:48 +00:00
jan.nijtmans c4b6cab579 merge core-8-6-branch 2016-09-05 13:56:15 +00:00
jan.nijtmans cf8c1e7bdc Allow additional optional "interp" argument for testinterpresolver command. Not used yet in any test-case.
Protect panic in tclLiteral.c for possible null-pointer access. (cherry-picked from Gustaf Neuman's interpresolver patch).
Eliminate some unecessary spacing.
2016-09-05 13:55:00 +00:00
jan.nijtmans 6f860bc18d Some patch clean-up, no change in functionality 2016-09-05 13:14:45 +00:00
jan.nijtmans 2bd794f7cc Proposed patch for [d4e7780ca1681cd095dbd81fe264feff75c988f7|d4e7780ca1], by Gustaf Neumann 2016-09-02 12:11:01 +00:00
jan.nijtmans 5b7e79f851 Don't ever allow UTF-8 sequences of more than 4 characters to be generated or parsed, even when TCL_UTF_MAX>4: According to current Unicode standard, a byte string of >4 characters can never form a single UTF-8 character.
And a few minor micro-optimizations related to UTF-8 handling.
2016-08-30 13:07:10 +00:00
jan.nijtmans 3b2cb79ab1 Don't ever allow UTF-8 sequences of more than 4 characters to be generated or parsed, even when TCL_UTF_MAX>4: According to current Unicode standard, a byte string of >4 characters can never form a single UTF-8 character.
And a few minor micro-optimizations related to UTF-8 handling.
2016-08-30 13:00:32 +00:00
dgp 0cce018c67 Merge dup-removal into search loop so we avoid pre-processing efforts on data that are never used. Contributed patch from Brian Griffin. 2016-08-26 13:49:07 +00:00
dgp f2115ca085 Merge dup-removal into search loop so we avoid pre-processing efforts on
data that are never used. Contributed patch from Brian Griffin.
2016-08-26 13:46:37 +00:00
Joe Mistachkin ac673f63d0 Set the default topic, enable full-text search, and put all help output files under OUT_DIR. 2016-08-10 03:13:46 +00:00
Joe Mistachkin 5001d7d18c Fix the 'htmlhelp' target so that it compiles cleanly and includes all the appropriate HTML files. 2016-08-09 21:03:28 +00:00
dgp a134b03eda merge mark 2016-07-27 18:56:20 +00:00
dgp d823d4a2d5 merge release 2016-07-27 18:55:23 +00:00
dgp 27696b490b a few test & docs fixes 2016-07-26 13:54:57 +00:00
dkf b37c60fe43 [db0a5f6417] Make a few tests resilient to differences in semantics of pipes between OSs. 2016-07-26 10:09:06 +00:00
dkf d0af5aa92c [db0a5f6417] Make a few tests resilient to differences in semantics of pipes between OSs. 2016-07-26 10:08:29 +00:00
dkf d4eb48d90f [6a19dedc2e] "Clarified" what the units are that [chan copy] uses for -size and that synchronous copying returns. 2016-07-24 17:58:13 +00:00
dkf 9faead9d18 [6a19dedc2e] "Clarified" what the units are that [chan copy] uses for -size and that synchronous copying returns. 2016-07-24 13:09:40 +00:00
dkf 404eadfdaf Make a few tests more resilient to differences in the semantics of pipes between operating systems. 2016-07-24 12:45:07 +00:00
dgp 722ba1aa44 test repairs 2016-07-22 15:28:50 +00:00
dgp 4cead413c9 Set release date 2016-07-22 14:00:01 +00:00
dgp 2501dbb8d0 Update changes file. 2016-07-21 16:20:38 +00:00
dgp 0050652afb Stop internals intrusion into lists. 2016-07-20 20:39:16 +00:00
dgp 4704b442fb Streamline TclObjLookupVarEx 2016-07-20 17:39:04 +00:00
dgp 5b8d20e6de Use strchr() to parse array variable syntax. 2016-07-20 16:32:16 +00:00
dgp 2151838b5b Use the new private flag INDEX_TEMP_TABLE in testing command too. 2016-07-20 15:43:08 +00:00
dgp acb9c613f1 merge 8.6 2016-07-20 11:48:44 +00:00
venkat ee54cd02de Merge tzdata 2016f from ietf.org 2016-07-20 03:05:57 +00:00
venkat ad4538af95 Merge tzdata 2016f from ietf.org 2016-07-20 03:05:31 +00:00
venkat c2e7b1ce36 Update tzdata to 2016f from ietf.org 2016-07-20 03:05:01 +00:00
dgp a8f05c5339 Factor out common prologue. 2016-07-19 20:40:27 +00:00
dgp e26431e0f3 merge 8.6 2016-07-19 19:52:59 +00:00
dgp 23a34a26fe "array search" is no longer a registered Tcl_ObjType. 2016-07-19 19:33:35 +00:00
dgp 3cd3541039 [0363f0146c] Fix [array startsearch] id handling to support var name variations 2016-07-19 19:31:28 +00:00
dgp f846b3f965 Remove outdated comment. 2016-07-19 15:00:51 +00:00
dgp a22b8736ec merge 8.6 2016-07-18 17:47:23 +00:00
dgp 87a97e0609 [104f2885bb] Rework the "chan" Tcl_ObjType to properly validate cached channel name lookups.
Also merge backlog of test suite & doc improvements.
2016-07-18 16:50:22 +00:00
dgp f5bf1de995 [104f2885bb] Rework the "chan" Tcl_ObjType to properly validate cached channel name lookups. 2016-07-18 16:46:34 +00:00
dgp 6f9ac81ae9 [104f2885bb] Rework the "chan" Tcl_ObjType to properly validate cached
channel name lookups.
2016-07-18 16:26:44 +00:00
dgp c947326c4a merge mark 2016-07-18 16:14:30 +00:00
dkf 9b1a5dc878 [77d58e3a7a] Test case independence: var. 2016-07-17 12:02:27 +00:00
dkf 4bc50a0a12 [77d58e3a7a] Test case independence: unload. 2016-07-17 11:56:28 +00:00
dgp 26532df53f merge 8.6 2016-07-16 20:50:03 +00:00
dkf 0b8d92332a [77d58e3a7a] Test case independence: io, load, msgcat, namespace, safe. 2016-07-16 11:42:38 +00:00
dgp 0cf3369f9f Remove unmaintained disabled speculative code.
Such things are for branches and history.
2016-07-15 14:20:34 +00:00
dgp 8f28138f6e Factor the cmdName intrep setting code into common utility routine. 2016-07-15 14:19:07 +00:00
dgp c0d0df8550 Stop using the tclCmdNameType to store failed command lookups. If we don't
find a command, there's nothing to store, so better not to shimmer at all.
2016-07-15 12:36:33 +00:00
dkf 67a6300cc4 [77d58e3a7a] Test case independence: interp. 2016-07-15 05:39:09 +00:00
ashok fd72878261 Fix docs and test failures. I had rolled back .PS1 (Powershell files) as being executable without fixing tests and docs. 2016-07-15 03:12:09 +00:00
dgp 9df68a3879 One of the validity checks for the "cmdName" type is to see if the
resolved command has been deleted by checking for the CMD_IS_DELETED flag.
Only one thing sets this flag -- Tcl_DeleteCommandFromToken(), and
every time it sets that flag it also bumps the cmdEpoch of the Command
as well.  The "cmdName" type is already validating that epoch.  It gains
nothing to be checking the CMD_IS_DELETED flag too.  Eliminated the 
pointless test.
2016-07-15 02:33:11 +00:00
dgp bd8c790e2e Stop checking case that can never happen. 2016-07-14 17:58:45 +00:00
dgp 5c3b0101a2 Plug memory leak created in recent variable Tcl_ObjType reform. 2016-07-14 15:17:58 +00:00
dgp fed06f2292 New test demonstrates memleak discovered by Rolf Ade. 2016-07-14 14:40:37 +00:00
dkf 2edc274601 [77d58e3a7a] Test case independence: chanio, cmdah, env, history. 2016-07-14 08:31:00 +00:00
dkf f68e18d159 Tidy up some references to INDEX_TEMP_TABLE. 2016-07-14 08:05:35 +00:00
dgp 66a18f91c0 merge 8.6 2016-07-13 19:19:37 +00:00
dgp 4c4629d5fd New private flag value INDEX_TEMP_TABLE.
Used to signal to Tcl_GetIndexFromObj*() routines that the table in which
lookups are done has a fleeting existence.  Thus there is no value in caching
any results, since the cache can never be useful.  Improvement over existing
hackery where cache is stored and then freed to avoid bogus results.
Likely candidate to eventually push to the public interface.
2016-07-13 19:06:22 +00:00
dkf 89796adf9c [3606125] Make parser-related tests work on their own. 2016-07-12 21:30:34 +00:00
dkf 11b61660d2 [3606388] Make variable-related tests work on their own. 2016-07-12 21:25:27 +00:00
dgp d214692a28 tzdata2016f 2016-07-12 16:46:08 +00:00
dgp eec270dc08 Dup test name. Bump to TclOO 1.0.5. 2016-07-12 16:24:35 +00:00
dgp 34d3a97939 merge 8.6 2016-07-12 14:15:48 +00:00
jan.nijtmans 1f93e78598 Fix "file owned" for Cygwin: st_uid is only 16-bit there. 2016-07-12 14:03:36 +00:00
jan.nijtmans c3c52cf7b0 Fix "file owned" for Cygwin: st_uid is only 16-bit there. 2016-07-12 14:02:17 +00:00
jan.nijtmans b11d2bb62d Make hash type changable by compiling with -DTCL_HASH_TYPE=size_t (for example). Default (unsigned) cannot be changed in Tcl 8.x, that must wait until Tcl 9. 2016-07-12 13:44:26 +00:00
dgp 96d7deb99b Start RC branch for Tcl 8.6.6 2016-07-12 13:23:21 +00:00
dgp e0a4741204 merge 8.6 2016-07-11 22:04:02 +00:00
dgp 0ceae7a885 [cea0344a1] Restore a clearing of the ensemble rewrite in one execution path
so attempts to use the data after free are not made.
Test namespace-50.9 demonstrates the need for this.
2016-07-11 21:56:32 +00:00
dgp e19d125606 Avoid memory leak in test. 2016-07-11 17:13:09 +00:00
dgp 9b324cef64 merge 8.6 2016-07-10 19:33:46 +00:00
dgp 68432b7ed1 [96fe2f1cc7] Plug memory leak. 2016-07-10 19:28:57 +00:00
dkf f1f3820560 [3606121] Making tests less cross-dependent. 2016-07-10 14:15:12 +00:00
dkf 363cf0a6f1 Fixes to namespace-old.test 2016-07-10 14:14:28 +00:00
dkf 508b6fc60d Fix to resolver.test 2016-07-10 12:45:34 +00:00
dkf 75f3cb9d07 Fixes to namespace.test 2016-07-10 07:59:52 +00:00
ashok 31ec149e21 Bugfix [da340d4f32]. clock-55.9 and clock-55.10 test failures. 2016-07-10 06:41:54 +00:00
ashok 6076256c3f Fix compiler warnings (const-ness and unused label) that did not show up
in the non-optimized build before last checkin.
2016-07-10 06:33:20 +00:00
dgp 77e9a375ff merge 8.6 2016-07-09 15:47:28 +00:00
ashok 25f7d3b86e Fix missing constraints for Windows-specific tests 2016-07-09 14:30:54 +00:00
dgp 464153fecd Revise INST_INVOKE_REPLACE to call EvalObjv with TCL_EVAL_INVOKE and
no longer call EvalObjEx which does not support it reliably.  Also
convert to conventional list operations.
2016-07-09 14:26:56 +00:00
ashok 139a16f600 Fixed docs for prior check-in (exec of .CMD files on Windows) 2016-07-09 14:23:24 +00:00
ashok 600487a9d6 Bugfix [9ece99d58b]. Make exec understand .CMD files on Windows. 2016-07-09 14:18:22 +00:00
dkf a2962cc586 [1493a43044] Make [namespace upvar] ignore variable resolvers; the previous situation was completely unintuitive. 2016-07-09 13:26:46 +00:00
ashok d6ae741f7f Bugfix [3613671]. file owned implementation for Windows. 2016-07-09 11:13:48 +00:00
ashok 48e3873f19 Bugfix [ae61a67192]. file {stat, type, size} etc. support for built-in special Windows files/devices like CON. 2016-07-09 08:27:00 +00:00
dgp 57a42f683c Repair some memory corruption problems in EnsembleCmdRep. 2016-07-08 14:19:23 +00:00
jan.nijtmans b2e1bb03b1 (cherry-pick): Bugfix [5d7ea04580]. Treat .cmd and .ps1 files are executable on Windows. 2016-07-08 12:38:35 +00:00
jan.nijtmans d8785b8358 Merge core-8-6-branch: Bug [a47641a031]. TclJoinPath was calling TclNewFSPathObj with a first argument that was not an absolute path. Added a check for that. Fixes Windows test failures fileSystem-1.{3,4} 2016-07-08 10:30:07 +00:00
jan.nijtmans 7de7029fa5 Micro-optimization: Use TclGetStringFromObj in stead of Tcl_GetStringFromObj in many places where possible. 2016-07-08 10:28:48 +00:00
ashok 47620e4ba8 Bug [a47641a031]. TclJoinPath was calling TclNewFSPathObj with a
first argument that was not an absolute path. Added a check for that.
Fixes Windows test failures fileSystem-1.{3,4}
2016-07-08 07:58:00 +00:00
dgp f290d19b27 Missed a cleanup line, which created a memleak. 2016-07-07 19:50:02 +00:00
dgp 1446838d71 To use a Tcl_Command token [aka (Command *)] for epoch checking, we must not
permit it to be freed while we hold it or else it could be mistaken for another
token allocated later that just happens to reside at the same address.

(Command *) preservation machinery already exists, just need to use it.

An extension facing the same problem might have to rely on command delete
traces.  

Earlier revisions used (Namespace *) lifetime to achieve the same
results, but that's really an indirect (possibly non-robust) path to achieving
the proper goal.

Valgrind is happy now.
2016-07-07 18:44:56 +00:00
dkf 8c8c1a6415 Expose the AVOID_RESOLVERS flag to [namespace upvar] implementations, which seem to need it. 2016-07-07 10:08:44 +00:00
dkf 07f3d3e393 Also test the interpreted path. 2016-07-07 08:35:30 +00:00
jan.nijtmans 1e5db76cc1 Merge core-8-6-branch:
New tests to demo the remaining flaw in ensemble dispatch revisions. Itcl 4 also demonstrated these
[bd7f17bce8] Revise ensemble dispatch to call TclNREvalObjv() which supports the TCL_EVAL_INVOKE
Simplify all the Tcl_NRPostProc declarations
Create and use a utility Tcl_NRPostProc when decr ref count of values is all that is needed
Bugfix [5d7ea04580]. Treat .cmd and .ps1 files are executable on Windows
2016-07-07 07:48:53 +00:00
ashok 85d1666247 Bugfix [5d7ea04580]. Treat .cmd and .ps1 files are executable on Windows. 2016-07-07 06:30:58 +00:00
dgp bf0a1dc6c5 Create and use a utility Tcl_NRPostProc when decr ref count of values is
all that is needed.
2016-07-06 16:47:37 +00:00
dgp 31e1e2a8c4 Simplify all the Tcl_NRPostProc declarations. 2016-07-06 15:50:34 +00:00
dgp 8f4ed81159 [bd7f17bce8] Revise ensemble dispatch to call TclNREvalObjv() which supports
the TCL_EVAL_INVOKE flag that is needed.
2016-07-06 15:12:53 +00:00
dkf 966906b7ae Demonstrate that there is a problem. 2016-07-05 22:05:16 +00:00
dgp 20e8eaedc8 New tests to demo the remaining flaw in ensemble dispatch revisions.
Itcl 4 also demonstrated these problems.
2016-07-05 17:03:59 +00:00
jan.nijtmans d65776f03f Fixup the ensemble rewrite conversions 2016-07-05 08:55:04 +00:00
jan.nijtmans 7b6eaf23e9 Fixup the ensemble rewrite conversions (merge fork) 2016-07-05 08:53:17 +00:00
dgp bf33e5524b Fixup the ensemble rewrite conversions. 2016-07-04 20:39:43 +00:00
jan.nijtmans 2ee0bbf7fb Use conventional list operations for ensemble dispatch
Add ability to disassemble TclOO constructors and destructors
2016-07-04 08:39:28 +00:00
jan.nijtmans 23c3438aee typo and end-of-line spacing 2016-07-04 08:36:41 +00:00
dkf 21124cf6ab Add ability to disassemble TclOO constructors and destructors ([1493a43044] motivates) 2016-07-04 08:18:53 +00:00
dgp 1694cf05a6 Use conventional list operations for ensemble dispatch. 2016-07-03 14:09:45 +00:00
dgp 8e39be1340 [09fabeb1fd] test subdirs in sorted order. 2016-07-02 17:58:49 +00:00
dgp 4110638cdd [f961d7d1dd] Repair usage message for ensemble parameters with spaces. 2016-07-02 17:57:58 +00:00
dgp 65bd912b77 [09fabeb1fd] test subdirs in sorted order. 2016-07-02 17:55:51 +00:00
dgp dd879c794d [f961d7d1dd] Repair usage message for ensemble parameters with spaces. 2016-07-02 17:21:53 +00:00
dgp e68b3d0183 [4402cfa58c] Rework the spell check machinery into something that will not be foiled by value sharing. 2016-07-01 20:18:47 +00:00
dgp 1481e6f3da [4402cfa58c] Rework the spell check machinery into something that will not be foiled by value sharing.
Valgrind is not happy with this commit.
Likely suspect is the removal of the nsPtr
field and checking against it.

dkf tried to warn me.
2016-07-01 20:14:14 +00:00
dgp 42c2792287 The EnsembleCmdRep struct that is the internal rep for caching ensemble
dispatches and spelling corrections can now be file static.
2016-07-01 19:42:38 +00:00
dgp 08826b79fe merge 8.6 2016-07-01 19:20:36 +00:00
dgp d5617720bb Add some tests 2016-07-01 19:16:56 +00:00
dgp e95143affd [4402cfa58c] Rework the spell check machinery into something that will not be
foiled by value sharing.
2016-07-01 18:54:36 +00:00
jan.nijtmans a67b58390b Make test-case "for.test" pass, regardless of end-of-line spacing 2016-07-01 14:11:38 +00:00
dgp ced0d271ff Encapsulate the fetching of the ensemble rewrite root, used by [namespace]. 2016-07-01 14:08:22 +00:00
jan.nijtmans b6f5ea3c8f merge core-8-6-branch 2016-07-01 13:34:20 +00:00
jan.nijtmans 38e85a2dbe Use same internal representation for unicode strings in test-cases than in reality, in order to prevent surprises. 2016-07-01 13:32:19 +00:00
dgp 680d1a1513 Disable special hacks for Itcl 3 ensemble error message generation.
Migration paths are in place to bring this to an end.
2016-07-01 13:20:37 +00:00
dgp f2718ded6d Use the utility routines to eliminate the last bit of intrusion into the ensembleRewrite area. 2016-07-01 13:07:39 +00:00
dgp 221b47806c merge 8.6 2016-07-01 12:58:37 +00:00
dgp 286034431c Use the utility routines to eliminate the last bit of intrusion into the
ensembleRewrite area.
2016-07-01 12:21:15 +00:00
jan.nijtmans c1ce97106f Simplify use of "struct" keyword in many places. 2016-06-30 13:16:44 +00:00
jan.nijtmans c8212c36e9 Remove Tcl_Main() function, since it's no longer being used: It has been a macro already for ages. 2016-06-29 15:45:26 +00:00
jan.nijtmans 964477ea36 Eliminate internal use of TCL_STORAGE_CLASS, as it will be gone in 9.0 anyway 2016-06-29 15:28:36 +00:00
jan.nijtmans 88fc841203 Tcl_SetVar -> Tcl_SetVar2 and comparable replacements, eliminating functions which are deprecated. 2016-06-29 11:39:00 +00:00
dgp 04633c731b merge 8.6 2016-06-28 22:49:22 +00:00
jan.nijtmans ef99853da4 (cherry-pick) [c30087b04f] Install man pages with permissions 644 instead of 444. 2016-06-26 09:01:26 +00:00
gahr ed326ae9b5 Merge trunk 2016-06-10 12:10:41 +00:00
dgp 46d0e89d6e merge 8.6 2016-05-17 11:45:44 +00:00
dgp 84f95a3ef4 merge 8.6 2016-05-13 15:55:44 +00:00
dgp 76d0eb32fc Don't see why the intrep should make and keep copies of things already
stored in the hash table.
2016-05-12 20:23:23 +00:00
dgp 76f6131b81 The "ensembleCommand" Tcl_ObjType has no need for an UpdateString routine.
It is entirely a caching type.  No "pure" value can exist.
2016-05-12 19:49:06 +00:00
dgp 1438a1b7f7 Remove the nsPtr field from the EnsembleCmdRep struct. Cannot see any
justification for keeping it (can get via token), and test suite doesn't care.
2016-05-12 19:44:41 +00:00
gahr 99ac77fd22 [e6f27aa56f] Add files I missed in my previous commit 2016-03-13 17:23:31 +00:00
gahr 32d41dcbb5 [e6f27aa56f] Initial import of libtommath-1.0
This commit brings in libtommath-1.0, as of tag v1.0 of the upstream repository
at https://github.com/libtom/libtommath.

Only the top-level directory has been imported: the demo, etc, logs, mtest,
pics, pre_gen, and tombc directories have been removed from our repo.

The stubs tables have been regenerated to accomodate for the new function:
mp_expt_d_ex(mp_int *a, mp_digit b, mp_int *c, int fast);
See https://github.com/libtom/libtommath/commit/e9b1837 for details.

Only the unix build system has been modified for now. Windows and Mac OSX will
come later.
2016-03-11 17:13:38 +00:00
jan.nijtmans a3eb84e8cb Import of tommath 0.42.0 2011-03-14 12:08:07 +00:00
jan.nijtmans d5b999af66 Import of libtommath 0.41
Import of libtommath 0.41
2011-03-14 11:59:15 +00:00
jan.nijtmans 4878f1b6a4 Import of libtommath 0.40 2011-03-14 11:51:58 +00:00
jan.nijtmans c5e0f27a28 re-import ltm-0.39, with original RCS-ID's 2011-03-14 09:36:26 +00:00
507 changed files with 24039 additions and 49752 deletions
+18
View File
@@ -17,8 +17,26 @@
*/tclsh*
*/tcltest*
*/versions.vc
libtommath/bn.ilg
libtommath/bn.ind
libtommath/pretty.build
libtommath/tommath.src
libtommath/*.pdf
libtommath/*.pl
libtommath/*.sh
libtommath/tombc/*
libtommath/pre_gen/*
libtommath/pics/*
libtommath/mtest/*
libtommath/logs/*
libtommath/etc/*
libtommath/demo/*
libtommath/*.out
libtommath/*.tex
unix/autoMkindex.tcl
unix/dltest.marker
unix/tcl.pc
unix/tclIndex
unix/pkgs/*
win/pkgs/*
win/tcl.hpj
+1 -1
View File
@@ -414,7 +414,7 @@
Tcl_IsChannelExisting, and Tcl_ClearChannelHandlers to conform to the
new stacked channel implementation. Their stub slots were also moved
to give preference to the new 8.3.2 stub functions. This will cause an
incompatability with 8.4a1 only.
incompatibility with 8.4a1 only.
(StopCopy): fixed a bug introduced by a partial fix in 8.3.2 that
didn't set nonBlocking correctly when resetting the flags for the
write side. [Bug: 6261]
+3 -3
View File
@@ -847,7 +847,7 @@
exit.
* tests/exec.test: marked exec-18.1 unixOnly until the Windows
incompatability (in the test, not the core) can be resolved.
incompatibility (in the test, not the core) can be resolved.
* tests/http.test (http-3.11): added close $fp that was causing an
error on Windows because the file was not closed before deleting.
@@ -3642,7 +3642,7 @@
* compat/strtoll.c (strtoll):
* compat/strtoull.c (strtoull):
* unix/tclUnixPort.h:
* win/tclWinPort.h: Const-ing 64-bit compatability declarations. Note
* win/tclWinPort.h: Const-ing 64-bit compatibility declarations. Note
that the return pointer is non-const because it is entirely legal for
the functions to be called from somewhere that owns the string being
passed. Fixes problem reported by Larry Virden.
@@ -3779,7 +3779,7 @@
There are a lot of changes from this TIP, so please see
http://purl.org/tcl/tip/72.html for discussion of
backward-compatability issues, but the main ones modifications are in:
backward-compatibility issues, but the main ones modifications are in:
* generic/tcl.h: New types.
* generic/tcl.decls: New public functions.
+2 -2
View File
@@ -947,7 +947,7 @@
declarations match and will end up using the declarations in the
public code from now on because of #include ordering. Keeping the old
declarations in tclInt.decls; there's no need to gratuitously break
compatability for those extensions which are already clients of the
compatibility for those extensions which are already clients of the
namespace code.
2003-08-23 Zoran Vasiljevic <zoran@archiwrae.com>
@@ -1278,7 +1278,7 @@
* generic/tclVar.c (Tcl_ArrayObjCmd, TclArraySet): Made [array get]
and [array set] work with dictionaries, producing them and consuming
them. Note that for compatability reasons, you will never get a dict
them. Note that for compatibility reasons, you will never get a dict
from feeding a string literal to [array set] since that alters the
trace behaviour of "multi-key" sets. [Bug 759935]
+1 -1
View File
@@ -1356,7 +1356,7 @@
2004-10-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* *.3: Convert CONST to const and VOID to void so we document how
people should actually use the Tcl API and not the compatability hacks
people should actually use the Tcl API and not the compatibility hacks
that it has to have.
* doc/man.macros, *.3: Update .AS macro so it can know how wide to
+1 -1
View File
@@ -106,5 +106,5 @@ closedir(
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
ckfree((char *) dirp);
ckfree(dirp);
}
+1 -1
View File
@@ -100,7 +100,7 @@ waitpid(
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
ckfree((char *) waitPtr);
ckfree(waitPtr);
return result;
}
+1 -1
View File
@@ -119,7 +119,7 @@ retrieve the stack trace when script evaluation returns
\fBTCL_ERROR\fR, like so:
.PP
.CS
int code = Tcl_Eval(interp, script);
int code = Tcl_EvalEx(interp, script, -1, 0);
if (code == TCL_ERROR) {
Tcl_Obj *options = \fBTcl_GetReturnOptions\fR(interp, code);
Tcl_Obj *key = Tcl_NewStringObj("-errorinfo", -1);
+333
View File
@@ -0,0 +1,333 @@
'\"
'\" Copyright (c) 2016 Andy Goth
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_ArraySet 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_ArraySet, Tcl_ArrayUnset, Tcl_ArrayGet, Tcl_ArrayNames, Tcl_ArraySize, Tcl_ArrayExists, Tcl_ArraySearchStart, Tcl_ArraySearchPeek, Tcl_ArraySearchNext, Tcl_ArraySearchDone, Tcl_ArrayStatistics \- manipulate Tcl array variables
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_ArraySet\fR(\fIinterp, part1Ptr, dictPtr, flags\fR)
.sp
int
\fBTcl_ArrayUnset\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR)
.sp
int
\fBTcl_ArrayGet\fR(\fIinterp, part1Ptr, part2Ptr, dictPtr, flags\fR)
.sp
int
\fBTcl_ArrayNames\fR(\fIinterp, part1Ptr, part2Ptr, listPtr, flags\fR)
.sp
int
\fBTcl_ArraySize\fR(\fIinterp, part1Ptr, part2Ptr, intPtr, flags\fR)
.sp
int
\fBTcl_ArrayExists\fR(\fIinterp, part1Ptr, part2ptr, intPtr, flags\fR)
.sp
Tcl_ArraySearch
\fBTcl_ArraySearchStart\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR)
.sp
Tcl_Obj *
\fBTcl_ArraySearchPeek\fR(\fIsearch\fR)
.sp
Tcl_Obj *
\fBTcl_ArraySearchNext\fR(\fIsearch\fR)
.sp
void
\fBTcl_ArraySearchDone\fR(\fIsearch\fR)
.sp
int
\fBTcl_ArrayStatistics\fR(\fIinterp, part1Ptr, stringPtr, flags\fR)
.SH ARGUMENTS
.AS Tcl_ArraySearch search
.AP Tcl_Interp *interp in
Interpreter containing the variable. If an error occurs, an error message is
left in the interpreter's result.
.AP Tcl_Obj *part1Ptr in
Points to a Tcl value containing the array variable's name. The name may
include a series of \fB::\fR namespace qualifiers to specify a variable in a
particular namespace.
.AP Tcl_Obj *part2Ptr in
If non-NULL, points to a Tcl value containing an array element name filter
specification. The format and interpretation of \fIpart2Ptr\fR are determined
by the \fIflags\fR argument.
.AP int flags in
OR-ed combination of bits providing additional information. See below for valid
values.
.AP Tcl_Obj *dictPtr in/out
Points to the dictionary value to be read or manipulated. If \fIdictPtr\fR does
not already point to a dictionary value, an attempt will be made to convert it
to one. \fBTcl_ArraySet\fR allows \fIdictPtr\fR to be NULL, in which case it
creates an empty array if the array does not already exist.
.AP Tcl_Obj *listPtr in/out
Points to the list value to be manipulated. If \fIlistPtr\fR does not already
point to a list value, an attempt will be made to convert it to one.
.AP Tcl_Obj *stringPtr in/out
Points to the string value to be manipulated.
.AP int *intPtr out
Points to location where \fBTcl_ArrayExists\fR stores the array existence flag
or \fBTcl_ArraySize\fR stores the number of matching array elements.
.AP Tcl_ArraySearch search in/out
Token for tracking the progress of enumerating array elements.
.BE
.SH DESCRIPTION
.PP
These functions are used to create, modify, enumerate, analyze, read, and delete
Tcl array variables from C code.
.PP
The \fBTcl_ArraySet\fR, \fBTcl_ArrayUnset\fR, \fBTcl_ArrayGet\fR,
\fBTcl_ArrayNames\fR, \fBTcl_ArraySize\fR, \fBTcl_ArrayExists\fR, and
\fBTcl_ArrayStatistics\fR functions return \fBTCL_OK\fR on success and
\fBTCL_ERROR\fR on error. If an error occurs, an error message is left in the
interpreter's result. The possible errors are caused by format (invalid list,
dictionary, or regular expression) and traces (array, read, write, or unset).
.PP
Except for \fBTcl_ArraySet\fR, \fBTcl_ArraySearchStart\fR (not listed above),
and \fBTcl_ArrayStatistics\fR, the array functions do not consider it an error
for a namespace or variable to not exist or a variable to be a scalar or array
element instead of an array. \fBTcl_ArraySet\fR allows the array variable to
not exist, in which case it creates it, but it returns \fBTCL_ERROR\fR in all
the other situations listed in the previous sentence.
.PP
Array functions trigger array traces in the same manner as the \fBarray\fR
command. After the completion of any array traces, for each accessed array
element, \fBTcl_ArraySet\fR triggers write traces, \fBTcl_ArrayUnset\fR triggers
unset traces, and \fBTcl_ArrayGet\fR triggers read traces. As discussed above,
an error encountered during the execution of a trace causes the function to
place error information in the interpreter's result and return \fBTCL_ERROR\fR.
.PP
The \fBTcl_ArraySet\fR, \fBTcl_ArrayUnset\fR, \fBTcl_ArrayGet\fR,
\fBTcl_ArrayNames\fR, \fBTcl_ArraySize\fR, \fBTcl_ArrayExists\fR,
\fBTcl_ArraySearchStart\fR, and \fBTcl_ArrayStatistics\fR functions accept a
\fIflags\fR argument to control the scope of the variable lookup and to specify
the interpretation of \fIpart2Ptr\fR. It consists of an OR-ed combination of
zero or more of the following bits.
.TP
\fBTCL_GLOBAL_ONLY\fR
Under normal circumstances the functions look up variables as follows. If a
procedure call is active in \fIinterp\fR, the array variable is looked up at the
current level of procedure call. Otherwise, the array variable is looked up
first in the current namespace, then in the global namespace. However, if this
bit is set in \fIflags\fR then the array variable is looked up only in the
global namespace even if there is a procedure call active. If both
\fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given,
\fBTCL_GLOBAL_ONLY\fR is ignored.
.TP
\fBTCL_NAMESPACE_ONLY\fR
If this bit is set in \fIflags\fR then the array variable is looked up only in
the current namespace. If a procedure is active, its variables are ignored, and
the global namespace is also ignored unless it is the current namespace.
.PP
With the exception of \fBTcl_ArraySet\fR and \fBTcl_ArrayStatistics\fR which do
not support filtering, the \fIflags\fR argument is also OR-ed with zero or one
of the following values to select the type of filtering applied by
\fIpart2Ptr\fR. Setting more than one filter type may cause \fBTcl_Panic\fR to
be called. The filter type is ignored if \fIpart2Ptr\fR is NULL, in which case
no filtering is applied and all array elements are matched.
.TP
\fBTCL_MATCH_EXACT\fR
\fIpart2Ptr\fR is an array element name. The filter matches at most a single
array element whose name is exactly equal to the value of \fIpart2Ptr\fR. If no
filter type is explicitly specified in \fIflags\fR, \fBTCL_MATCH_EXACT\fR is
used by default. This differs from the \fBarray\fR commands which default to
\fB\-glob\fR.
.TP
\fBTCL_MATCH_GLOB\fR
\fIpart2Ptr\fR is a glob pattern, and it matches array element names according
to the rules of \fBstring match\fR. \fIpart2Ptr\fR must match the entire array
element name from beginning to end. To match substrings, place \fB*\fR at
either end of \fIpart2Ptr\fR.
.TP
\fBTCL_MATCH_REGEXP\fR
\fIpart2Ptr\fR is a regular expression, and it matches array element names
according to the rules of \fBregexp\fR. Unless anchored by the \fB^\fR and
\fB$\fR constraints, \fIpart2Ptr\fR matches substrings. Thus, an empty
\fIpart2Ptr\fR matches every possible array element name. It is an error for
\fIpart2Ptr\fR to not be a valid regular expression, but this error is only
detected and reported when \fIpart1Ptr\fR names a non-empty array.
.PP
The \fBTcl_ArraySet\fR, \fBTcl_ArrayGet\fR, and \fBTcl_ArrayNames\fR functions
accept \fIdictPtr\fR and \fIlistPtr\fR arguments referencing dictionary and list
values, respectively. If these values are not already dictionary and list
values, an attempt will be made to convert them. If the conversion fails,
\fBTCL_ERROR\fR will be returned and an error message will be left in the
interpreter's result.
.PP
\fBTcl_ArraySet\fR sets the values of zero or more elements in the array named
by \fIpart1Ptr\fR. If not NULL, \fIdictPtr\fR must be a valid dictionary, i.e.
it must be a list consisting of an even number of elements alternating between
key and value. Each key in \fIdictPtr\fR is treated as an element name within
the array, and its associated value is used as the new value for that array
element. If the variable named by \fIpart1Ptr\fR does not already exist and
\fIdictPtr\fR is empty or NULL, the variable is created as an empty array. It
is an error for \fIpart1Ptr\fR to name a scalar (non-array) variable or an array
element, or for it to reference a nonexistent namespace.
.PP
\fBTcl_ArrayUnset\fR unsets all elements in the array named by \fIpart1Ptr\fR
that match the filter specified by \fIpart2Ptr\fR and \fIflags\fR. It is not an
error for \fIpart1Ptr\fR to not name an array or for there to be no matching
elements in the array. If \fIpart2Ptr\fR is NULL and \fIpart1Ptr\fR names an
array, the entire array is unset, and future calls to \fBTcl_ArrayExists\fR will
report it as not existing. This is distinct from unsetting each element of the
array (e.g. if \fIpart2Ptr\fR is \fB*\fR and \fIflags\fR is
\fBTCL_MATCH_GLOB\fR), which does not cause future calls to
\fBTcl_ArrayExists\fR to report the array as not existing.
.PP
\fBTcl_ArrayGet\fR loads the contents of the array named by \fIpart1Ptr\fR into
the \fIdictPtr\fR dictionary object. The array element names and values are
used as the dictionary keys and values, respectively. If \fIpart2Ptr\fR is not
NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array
elements are loaded into \fIdictPtr\fR. If \fIpart1Ptr\fR does not name an
array or if there are no matching elements, \fIdictPtr\fR is not modified.
If \fIdictPtr\fR is not empty prior to calling \fBTcl_ArrayGet\fR, the array
data is merged into \fIdictPtr\fR. If an array element has the same name as an
existing dictionary key, the array element value replaces the existing
dictionary value.
.PP
\fBTcl_ArrayNames\fR loads the element names of the array named by
\fIpart1Ptr\fR into the \fIlistPtr\fR list object. If \fIpart2Ptr\fR is not
NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array
element names are loaded into \fIlistPtr\fR. If \fIpart1Ptr\fR does not name an
array or if there are no matching elements, \fIlistPtr\fR is not modified. If
\fIlistPtr\fR is not empty prior to calling \fBTcl_ArrayNames\fR, the array
element names are appended to \fIlistPtr\fR.
.PP
\fBTcl_ArraySize\fR stores the number of elements in the array named by
\fIpart1Ptr\fR into the address \fIintPtr\fR. If \fIpart2Ptr\fR is not NULL,
\fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array
elements count toward the total number of elements.
.PP
\fBTcl_ArrayExists\fR checks for the existence of an array variable named
\fIpart1Ptr\fR or (if \fIpart2Ptr\fR is not NULL) an array element within
matching the filter specified by \fIpart2Ptr\fR and \fIflags\fR. If the array
variable or array element exists, the value \fB1\fR is stored into the location
\fIintPtr\fR, even if the array is empty. If \fIpart1Ptr\fR does not name an
array variable (the variable does not exist, it is a scalar variable or array
element, or it references a nonexistent namespace), or if \fIpart2Ptr\fR is not
NULL and no elements match the filter, the value \fB0\fR is stored into the
location \fIintPtr\fR.
.PP
\fBTcl_ArraySearchStart\fR initiates an array search, i.e. an array element
enumeration yielding one element at a time. \fIpart1Ptr\fR must name an array.
If \fIpart2Ptr\fR is not NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter
used to limit which array elements are included in the enumeration. The return
value is a token used to track the progress of the search, and it is to be
passed to the \fBTcl_ArraySearchPeek\fR, \fBTcl_ArraySearchNext\fR, and
\fBTcl_ArraySearchDone\fR functions. If there is an error looking up the
variable, executing an array trace, or validating a regular expression filter,
NULL is returned and error information is placed in the interpreter result.
.PP
\fBTcl_ArraySearchPeek\fR and \fBTcl_ArraySearchNext\fR return the next array
element name in the search identified by the \fIsearch\fR argument. If there
are no remaining element names, NULL is returned. \fBTcl_ArraySearchPeek\fR
does not advance the enumeration, whereas \fBTcl_ArraySearchNext\fR does, so
\fBTcl_ArraySearchPeek\fR will return the same value each time it is called if
there are no intervening calls to \fBTcl_ArraySearchNext\fR with the same
\fIsearch\fR argument.
.PP
\fBTcl_ArraySearchDone\fR completes the search identified by the \fIsearch\fR
argument and deallocates associated resources. To avoid memory leaks,
\fBTcl_ArraySearchDone\fR must be called once for each search token returned by
\fBTcl_ArraySearchStart\fR.
.PP
\fBTcl_ArrayStatistics\fR produces statistics about the distribution of data
within the hash table underlying the array named by \fIpart1Ptr\fR. This
information includes the number of entries in the table, the number of buckets,
and the utilization of the buckets. The statistics information is appended to
the string value \fIstringPtr\fR.
.SH EXAMPLES
.PP
Common initialization used for subsequent examples:
.PP
.CS
int size, i;
Tcl_Obj *obj, **objPtr;
Tcl_Obj *varNameObj = Tcl_NewStringObj("colorcount", -1);
Tcl_Channel outChan = Tcl_GetChannel(interp, "stdout", NULL);
.CE
.PP
Create an array:
.PP
.CS
obj = Tcl_NewStringObj(
" red 1"
" green 5"
" blue 4"
" white 9", -1);
\fBTcl_ArraySet\fR(interp, varNameObj, obj, 0);
.CE
.PP
Load the full contents of an array into a single object:
.PP
.CS
Tcl_SetStringObj(obj, NULL, 0);
\fBTcl_ArrayGet\fR(interp, varNameObj, NULL, obj, 0);
Tcl_ListObjGetElements(interp, obj, &size, &objPtr);
for (i = 0; i < size; i += 2, objPtr += 2) {
Tcl_WriteChars(outChan, "Color: ", -1);
Tcl_WriteObj(outChan, objPtr[0]);
Tcl_WriteChars(outChan, " Count: ", -1);
Tcl_WriteObj(outChan, objPtr[1]);
Tcl_WriteChars(outChan, "\\n", -1);
}
\fB\(->\fR Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
.CE
.PP
Get an array element name list then individually look up each element value:
.PP
.CS
Tcl_SetStringObj(obj, NULL, 0);
\fBTcl_ArrayNames\fR(interp, varNameObj, NULL, obj, 0);
Tcl_ListObjGetElements(interp, obj, &size, &objPtr);
for (i = 0; i < size; ++i, ++objPtr) {
Tcl_WriteChars(outChan, "Color: ", -1);
Tcl_WriteObj(outChan, *objPtr);
Tcl_WriteChars(outChan, " Count: ", -1);
Tcl_WriteObj(outChan, Tcl_ObjGetVar2(
interp, varNameObj, *objPtr, 0));
Tcl_WriteChars(outChan, "\\n", -1);
}
\fB\(->\fR Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
.CE
.PP
Get array hash table statistics:
.PP
.CS
Tcl_SetStringObj(obj, NULL, 0);
\fBTcl_ArrayStatistics\fR(interp, varNameObj, obj, 0);
Tcl_WriteObj(outChan, obj);
Tcl_WriteChars(outChan, "\\n", -1);
\fB\(->\fR 4 entries in table, 4 buckets
number of buckets with 0 entries: 1
number of buckets with 1 entries: 2
number of buckets with 2 entries: 1
number of buckets with 3 entries: 0
number of buckets with 4 entries: 0
number of buckets with 5 entries: 0
number of buckets with 6 entries: 0
number of buckets with 7 entries: 0
number of buckets with 8 entries: 0
number of buckets with 9 entries: 0
number of buckets with 10 or more entries: 0
average search distance for entry: 1.2
.CE
.SH "SEE ALSO"
array(n), Tcl_NewObj(3), Tcl_NewListObj(3), Tcl_NewDictObj(3),
Tcl_ObjGetVar2(3), Tcl_GetObjResult(3), Tcl_TraceVar2(3)
.SH KEYWORDS
array, dict, dict value, dictionary, get variable, hash table, iteration,
interpreter, set, unset, value, variable
+23 -8
View File
@@ -51,27 +51,42 @@ in the interpreter's result, and nothing is stored at *\fIintPtr\fR
or *\fIdoublePtr\fR or *\fIboolPtr\fR.
.PP
\fBTcl_GetInt\fR expects \fIsrc\fR to consist of a collection
of integer digits, optionally signed and optionally preceded by
white space. If the first two characters of \fIsrc\fR
of integer digits, optionally signed and optionally preceded and
followed by white space. If the first two characters of \fIsrc\fR
after the optional white space and sign are
.QW 0x
.QW \fB0x\fR
then \fIsrc\fR is expected to be in hexadecimal form; otherwise,
if the first such characters are
.QW \fB0o\fR
then \fIsrc\fR is expected to be in octal form; otherwise,
if the first such characters are
.QW \fB0b\fR
then \fIsrc\fR is expected to be in binary form; otherwise,
if the first such character is
.QW 0
.QW \fB0\fR
then \fIsrc\fR
is expected to be in octal form; otherwise, \fIsrc\fR is
expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point
number, which is: white space; a sign; a sequence of digits; a
decimal point; a sequence of digits; the letter
.QW e ;
decimal point
.QW \fB.\fR ;
a sequence of digits; the letter
.QW \fBe\fR ;
a signed decimal exponent; and more white space.
Any of the fields may be omitted, except that
the digits either before or after the decimal point must be present
and if the
.QW e
is present then it must be followed by the exponent number.
.QW \fBe\fR
is present then it must be followed by the exponent number. If there
are no fields apart from the sign and initial sequence of digits
(i.e., no decimal point or exponent indicator), that
initial sequence of digits should take one of the forms that
\fBTcl_GetInt\fR supports, described above. The use of
.QW \fB,\fR
as a decimal point is not supported nor should any other sort of
inter-digit separator be present.
.PP
\fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean
value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR,
+1 -1
View File
@@ -281,7 +281,7 @@ The \fIhashKeyProc\fR member contains the address of a function called to
calculate a hash value for the key.
.PP
.CS
typedef unsigned int \fBTcl_HashKeyProc\fR(
typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
+3 -3
View File
@@ -23,11 +23,11 @@ Tcl interpreter handle.
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
Non-zero means that only the particular version specified by
1 means that only the particular version specified by
\fIversion\fR is acceptable.
Zero means that versions newer than \fIversion\fR are also
0 means that versions newer than \fIversion\fR are also
acceptable as long as they have the same major version number
as \fIversion\fR.
as \fIversion\fR. Other bits have no effect.
.BE
.SH INTRODUCTION
.PP
+1 -1
View File
@@ -164,7 +164,7 @@ The source interpreter will have its result reset by this operation.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
Use of the following procedures (is deprecated
Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as a value
+58 -22
View File
@@ -22,6 +22,42 @@ Unless otherwise specified for individual commands below,
\fIarrayName\fR must be the name of an existing array variable.
The \fIoption\fR argument determines what action is carried
out by the command.
.PP
Many array commands accept \fImode\fR and \fIpattern\fR arguments. These
arguments specify a filter to limit which array elements are included in the
operation. If neither argument is specified, no filtering is applied, and the
entire array is processed. If only one argument is specified, it is used as the
\fIpattern\fR argument, and \fB\-glob\fR is used as the default value for
\fImode\fR. If both arguments are specified, the first is used as \fImode\fR
and the second as \fIpattern\fR. The \fImode\fR argument designates which
matching rules to use to match \fIpattern\fR against the names of the elements
in the array. The legal \fImode\fR values are:
.TP
\fB\-exact\fR
.
\fIPattern\fR is a literal string that is compared for exact equality against
each array element name. This mode has limited utility because all uses of the
\fBarray\fR command with \fB-exact\fR matching can be implemented by operating
directly on the array element with standard \fIname\fB(\fIindex\fB)\fR notation.
.TP
\fB\-glob\fR
.
\fIPattern\fR is a glob-style pattern which is matched against each array
element name using the same rules as the \fBstring match\fR command.
\fIPattern\fR must match the entire array element name from beginning to end.
To match substrings, place \fB*\fR at either end of \fIpattern\fR. This mode is
the default if no \fImode\fR is specified.
.TP
\fB\-regexp\fR
.
\fIPattern\fR is treated as a regular expression and matched against each array
element name using the rules described in the \fBre_syntax\fR reference page.
Unless anchored by the \fB^\fR and \fB$\fR constraints, \fIpattern\fR matches
substrings. Thus, an empty \fIpattern\fR matches every possible array element
name. It is an error for \fIpattern\fR to not be a valid regular expression,
but this error condition is only detected and reported when \fIarrayName\fR is a
non-empty array.
.PP
The legal \fIoptions\fR (which may be abbreviated) are:
.TP
\fBarray anymore \fIarrayName searchId\fR
@@ -43,20 +79,20 @@ which search on \fIarrayName\fR to destroy, and must have
been the return value from a previous invocation of
\fBarray startsearch\fR. Returns an empty string.
.TP
\fBarray exists \fIarrayName\fR
\fBarray exists \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns 1 if \fIarrayName\fR is an array variable, 0 if there
is no variable by that name or if it is a scalar variable.
If \fIpattern\fR is specified, this command instead checks if one or more
elements of \fIarrayName\fR match the filter defined by \fImode\fR and
\fIpattern\fR, returning 1 or 0 if the match succeeds or fails, respectively.
.TP
\fBarray get \fIarrayName\fR ?\fIpattern\fR?
\fBarray get \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns a list containing pairs of elements. The first
element in each pair is the name of an element in \fIarrayName\fR
and the second element of each pair is the value of the
array element. The order of the pairs is undefined.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.
If \fIpattern\fR is specified, then only those elements whose names
match \fIpattern\fR (using the matching rules of
\fBstring match\fR) are included.
The \fImode\fR and \fIpattern\fR arguments can be used to limit which array
elements are included in the result.
If \fIarrayName\fR is not the name of an array variable, or if
the array contains no elements, then an empty list is returned.
If traces on the array modify the list of elements, the elements
@@ -65,15 +101,10 @@ returned are those that exist both before and after the call to
.TP
\fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns a list containing the names of all of the elements in
the array that match \fIpattern\fR. \fIMode\fR may be one of
\fB\-exact\fR, \fB\-glob\fR, or \fB\-regexp\fR. If specified, \fImode\fR
designates which matching rules to use to match \fIpattern\fR against
the names of the elements in the array. If not specified, \fImode\fR
defaults to \fB\-glob\fR. See the documentation for \fBstring match\fR
for information on glob style matching, and the documentation for
\fBregexp\fR for information on regexp matching.
If \fIpattern\fR is omitted then the command returns all of
the element names in the array. If there are no (matching) elements
the array.
The \fImode\fR and \fIpattern\fR arguments can be used to limit which array
element names are included in the result.
If there are no (matching) elements
in the array, or if \fIarrayName\fR is not the name of an array
variable, then an empty string is returned.
.TP
@@ -99,16 +130,20 @@ If the variable \fIarrayName\fR does not already exist
and \fIlist\fR is empty,
\fIarrayName\fR is created with an empty array value.
.TP
\fBarray size \fIarrayName\fR
Returns a decimal string giving the number of elements in the
\fBarray size \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns an integer giving the number of elements in the
array.
The \fImode\fR and \fIpattern\fR arguments can be used to limit which array
elements are counted toward the result.
If \fIarrayName\fR is not the name of an array then 0 is returned.
.TP
\fBarray startsearch \fIarrayName\fR
\fBarray startsearch \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
This command initializes an element-by-element search through the
array given by \fIarrayName\fR, such that invocations of the
\fBarray nextelement\fR command will return the names of the
individual elements in the array.
The \fImode\fR and \fIpattern\fR arguments can be used to limit which array
element names are returned by future invocations of \fBarray nextelement\fR.
When the search has been completed, the \fBarray donesearch\fR
command should be invoked.
The return value is a
@@ -126,9 +161,10 @@ that represents the array. This information includes the number of
entries in the table, the number of buckets, and the utilization of
the buckets.
.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR). If \fIarrayName\fR is not the name
\fBarray unset \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Unsets all of the elements in the array that match the filter specified by the
\fImode\fR and \fIpattern\fR arguments.
If \fIarrayName\fR is not the name
of an array variable or there are no matching elements in the array, no
error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is
an array variable, then the command unsets the entire array.
+20 -6
View File
@@ -287,12 +287,14 @@ slow destinations like network sockets.
.RS
.PP
The \fBchan copy\fR command transfers data from \fIinputChan\fR until
end of file or \fIsize\fR bytes have been transferred. If no
\fB\-size\fR argument is given, then the copy goes until end of file.
All the data read from \fIinputChan\fR is copied to \fIoutputChan\fR.
Without the \fB\-command\fR option, \fBchan copy\fR blocks until the
copy is complete and returns the number of bytes written to
\fIoutputChan\fR.
end of file or \fIsize\fR bytes or characters have been transferred;
\fIsize\fR is in bytes if the two channels are using the same encoding,
and is in characters otherwise. If no \fB\-size\fR argument is given,
then the copy goes until end of file. All the data read from
\fIinputChan\fR is copied to \fIoutputChan\fR. Without the
\fB\-command\fR option, \fBchan copy\fR blocks until the copy is
complete and returns the number of bytes or characters (using the same
rules as for the \fB\-size\fR option) written to \fIoutputChan\fR.
.PP
The \fB\-command\fR argument makes \fBchan copy\fR work in the
background. In this case it returns immediately and the
@@ -547,6 +549,18 @@ this, spawn with "2>@" or
">@" redirection operators onto the write side of a pipe, and then
immediately close it in the parent. This is necessary to get an EOF on
the read side once the child has exited or otherwise closed its output.
.RS
.PP
Note that the pipe buffering semantics can vary at the operating system level
substantially; it is not safe to assume that a write performed on the output
side of the pipe will appear instantly to the input side. This is a
fundamental difference and Tcl cannot conceal it. The overall stream semantics
\fIare\fR compatible, so blocking reads and writes will not see most of the
differences, but the details of what exactly gets written when are not. This
is most likely to show up when using pipelines for testing; care should be
taken to ensure that deadlocks do not occur and that potential short reads are
allowed for.
.RE
.VE 8.6
.TP
\fBchan pop \fIchannelId\fR
+1
View File
@@ -20,6 +20,7 @@ This command joins each of its arguments together with spaces after
trimming leading and trailing white-space from each of them. If all of the
arguments are lists, this has the same effect as concatenating them
into a single list.
Arguments that are empty (after trimming) are ignored entirely.
It permits any number of arguments;
if no \fIarg\fRs are supplied, the result is an empty string.
.SH EXAMPLES
+3 -2
View File
@@ -271,8 +271,9 @@ limitation as \fBexec\fR wants to communicate over pipes. The Expect
extension addresses this issue when communicating with a TUI application.
.PP
When attempting to execute an application, \fBexec\fR first searches for
the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and
\fB.bat\fR are appended to the end of the specified name and it searches
the name as it was specified. Then, in order,
\fB.com\fR, \fB.exe\fR, \fB.bat\fR and \fB.cmd\fR
are appended to the end of the specified name and it searches
for the longer name. If a directory name was not specified as part of the
application name, the following directories are automatically searched in
order when attempting to locate the application:
+171 -214
View File
@@ -17,14 +17,14 @@ expr \- Evaluate an expression
.BE
.SH DESCRIPTION
.PP
Concatenates \fIarg\fRs (adding separator spaces between them),
evaluates the result as a Tcl expression, and returns the value.
The operators permitted in Tcl expressions include a subset of
Concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates
that expression, returning its value.
The operators permitted in an expression include a subset of
the operators permitted in C expressions. For those operators
common to both Tcl and C, Tcl applies the same meaning and precedence
as the corresponding C operators.
Expressions almost always yield numeric results
(integer or floating-point values).
The value of an expression is often a numeric result, either an integer or a
floating-point value, but may also be a non-numeric value.
For example, the expression
.PP
.CS
@@ -32,78 +32,68 @@ For example, the expression
.CE
.PP
evaluates to 14.2.
Tcl expressions differ from C expressions in the way that
operands are specified. Also, Tcl expressions support
non-numeric operands and string comparisons, as well as some
Expressions differ from C expressions in the way that
operands are specified. Expressions also support
non-numeric operands, string comparisons, and some
additional operators not found in C.
.PP
When an expression evaluates to an integer, the value is the decimal form of
the integer, and when an expression evaluates to a floating-point number, the
value is the form produced by the \fB%g\fR format specifier of Tcl's
\fBformat\fR command.
.SS OPERANDS
.PP
A Tcl expression consists of a combination of operands, operators,
parentheses and commas.
White space may be used between the operands and operators and
parentheses (or commas); it is ignored by the expression's instructions.
Where possible, operands are interpreted as integer values.
Integer values may be specified in decimal (the normal case), in binary
(if the first two characters of the operand are \fB0b\fR), in octal
(if the first two characters of the operand are \fB0o\fR), or in hexadecimal
(if the first two characters of the operand are \fB0x\fR). For
compatibility with older Tcl releases, an octal integer value is also
indicated simply when the first character of the operand is \fB0\fR,
whether or not the second character is also \fBo\fR.
If an operand does not have one of the integer formats given
above, then it is treated as a floating-point number if that is
possible. Floating-point numbers may be specified in any of several
common formats making use of the decimal digits, the decimal point \fB.\fR,
the characters \fBe\fR or \fBE\fR indicating scientific notation, and
the sign characters \fB+\fR or \fB\-\fR. For example, all of the
following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
Also recognized as floating point values are the strings \fBInf\fR
and \fBNaN\fR making use of any case for each character.
If no numeric interpretation is possible (note that all literal
operands that are not numeric or boolean must be quoted with either
braces or with double quotes), then an operand is left as a string
(and only a limited set of operators may be applied to it).
An expression consists of a combination of operands, operators, parentheses and
commas, possibly with whitespace between any of these elements, which is
ignored.
An integer operand may be specified in decimal, binary
(the first two characters are \fB0b\fR), octal
(the first two characters are \fB0o\fR), or hexadecimal
(the first two characters are \fB0x\fR) form. For
compatibility with older Tcl releases, an operand that begins with \fB0\fR is
interpreted as an octal integer even if the second character is not \fBo\fR.
A floating-point number may be specified in any of several
common decimal formats, and may use the decimal point \fB.\fR,
\fBe\fR or \fBE\fR for scientific notation, and
the sign characters \fB+\fR and \fB\-\fR. The
following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
The strings \fBInf\fR
and \fBNaN\fR, in any combination of case, are also recognized as floating point
values. An operand that doesn't have a numeric interpretation must be quoted
with either braces or with double quotes.
.PP
Operands may be specified in any of the following ways:
An operand may be specified in any of the following ways:
.IP [1]
As a numeric value, either integer or floating-point.
.IP [2]
As a boolean value, using any form understood by \fBstring is\fR
\fBboolean\fR.
.IP [3]
As a Tcl variable, using standard \fB$\fR notation.
The variable's value will be used as the operand.
As a variable, using standard \fB$\fR notation.
The value of the variable is then the value of the operand.
.IP [4]
As a string enclosed in double-quotes.
The expression parser will perform backslash, variable, and
command substitutions on the information between the quotes,
and use the resulting value as the operand
Backslash, variable, and command substitution are performed as described in
\fBTcl\fR.
.IP [5]
As a string enclosed in braces.
The characters between the open brace and matching close brace
will be used as the operand without any substitutions.
The operand is treated as a braced value as described in \fBTcl\fR.
.IP [6]
As a Tcl command enclosed in brackets.
The command will be executed and its result will be used as
the operand.
Command substitution is performed as described in \fBTcl\fR.
.IP [7]
As a mathematical function whose arguments have any of the above
forms for operands, such as \fBsin($x)\fR. See \fBMATH FUNCTIONS\fR below for
As a mathematical function such as \fBsin($x)\fR, whose arguments have any of the above
forms for operands. See \fBMATH FUNCTIONS\fR below for
a discussion of how mathematical functions are handled.
.PP
Where the above substitutions occur (e.g. inside quoted strings), they
are performed by the expression's instructions.
However, the command parser may already have performed one round of
substitution before the expression processor was called.
As discussed below, it is usually best to enclose expressions
in braces to prevent the command parser from performing substitutions
on the contents.
Because \fBexpr\fR parses and performs substitutions on values that have
already been parsed and substituted by \fBTcl\fR, it is usually best to enclose
expressions in braces to avoid the first round of substitutions by
\fBTcl\fR.
.PP
For some examples of simple expressions, suppose the variable
\fBa\fR has the value 3 and
the variable \fBb\fR has the value 6.
Then the command on the left side of each of the lines below
will produce the value on the right side of the line:
Below are some examples of simple expressions where the value of \fBa\fR is 3
and the value of \fBb\fR is 6. The command on the left side of each line
produces the value on the right side.
.PP
.CS
.ta 6c
@@ -114,34 +104,41 @@ will produce the value on the right side of the line:
.CE
.SS OPERATORS
.PP
The valid operators (most of which are also available as commands in
the \fBtcl::mathop\fR namespace; see the \fBmathop\fR(n) manual page
for details) are listed below, grouped in decreasing order of precedence:
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
more versatile operators such as \fB==\fR.
.PP
Unless otherwise specified, operators accept non-numeric operands. The value
of a boolean operation is 1 if true, 0 otherwise. See also \fBstring is\fR
\fBboolean\fR. The valid operators, most of which are also available as
commands in the \fBtcl::mathop\fR namespace (see \fBmathop\fR(n)), are listed
below, grouped in decreasing order of precedence:
.TP 20
\fB\-\0\0+\0\0~\0\0!\fR
.
Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators
may be applied to string operands, and bit-wise NOT may be
applied only to integers.
Unary minus, unary plus, bit-wise NOT, logical NOT. These operators
may only be applied to numeric operands, and bit-wise NOT may only be
applied to integers.
.TP 20
\fB**\fR
.
Exponentiation. Valid for any numeric operands.
Exponentiation. Valid for numeric operands.
.TP 20
\fB*\0\0/\0\0%\fR
.
Multiply, divide, remainder. None of these operators may be
applied to string operands, and remainder may be applied only
to integers.
The remainder will always have the same sign as the divisor and
an absolute value smaller than the absolute value of the divisor.
Multiply and divide, which are valid for numeric operands, and remainder, which
is valid for integers. The remainder, an absolute value smaller than the
absolute value of the divisor, has the same sign as the divisor.
.RS
.PP
When applied to integers, the division and remainder operators can be
considered to partition the number line into a sequence of equal-sized
adjacent non-overlapping pieces where each piece is the size of the divisor;
the division result identifies which piece the divisor lay within, and the
remainder result identifies where within that piece the divisor lay. A
When applied to integers, division and remainder can be
considered to partition the number line into a sequence of
adjacent non-overlapping pieces, where each piece is the size of the divisor;
the quotient identifies which piece the dividend lies within, and the
remainder identifies where within that piece the dividend lies. A
consequence of this is that the result of
.QW "-57 \fB/\fR 10"
is always -6, and the result of
@@ -151,177 +148,157 @@ is always 3.
.TP 20
\fB+\0\0\-\fR
.
Add and subtract. Valid for any numeric operands.
Add and subtract. Valid for numeric operands.
.TP 20
\fB<<\0\0>>\fR
.
Left and right shift. Valid for integer operands only.
Left and right shift. Valid for integers.
A right shift always propagates the sign bit.
.TP 20
\fB<\0\0>\0\0<=\0\0>=\fR
.
Boolean less, greater, less than or equal, and greater than or equal.
Each operator produces 1 if the condition is true, 0 otherwise.
These operators may be applied to strings as well as numeric operands,
in which case string comparison is used.
Boolean less than, greater than, less than or equal, and greater than or equal.
.TP 20
\fB==\0\0!=\fR
.
Boolean equal and not equal. Each operator produces a zero/one result.
Valid for all operand types.
Boolean equal and not equal.
.TP 20
\fBeq\0\0ne\fR
.
Boolean string equal and string not equal. Each operator produces a
zero/one result. The operand types are interpreted only as strings.
Boolean string equal and string not equal.
.TP 20
\fBin\0\0ni\fR
.
List containment and negated list containment. Each operator produces
a zero/one result and treats its first argument as a string and its
second argument as a Tcl list. The \fBin\fR operator indicates
whether the first argument is a member of the second argument list;
the \fBni\fR operator inverts the sense of the result.
List containment and negated list containment. The first argument is
interpreted as a string, the second as a list. \fBin\fR tests for membership
in the list, and \fBni\fR is the inverse.
.TP 20
\fB&\fR
.
Bit-wise AND. Valid for integer operands only.
Bit-wise AND. Valid for integer operands.
.TP 20
\fB^\fR
.
Bit-wise exclusive OR. Valid for integer operands only.
Bit-wise exclusive OR. Valid for integer operands.
.TP 20
\fB|\fR
.
Bit-wise OR. Valid for integer operands only.
Bit-wise OR. Valid for integer operands.
.TP 20
\fB&&\fR
.
Logical AND. Produces a 1 result if both operands are non-zero,
0 otherwise.
Valid for boolean and numeric (integers or floating-point) operands only.
Logical AND. If both operands are true, the result is 1, or 0 otherwise.
.TP 20
\fB||\fR
.
Logical OR. Produces a 0 result if both operands are zero, 1 otherwise.
Valid for boolean and numeric (integers or floating-point) operands only.
Logical OR. If both operands are false, the result is 0, or 1 otherwise.
.TP 20
\fIx\fB?\fIy\fB:\fIz\fR
.
If-then-else, as in C. If \fIx\fR
evaluates to non-zero, then the result is the value of \fIy\fR.
Otherwise the result is the value of \fIz\fR.
The \fIx\fR operand must have a boolean or numeric value.
If-then-else, as in C. If \fIx\fR is false , the result is the value of
\fIy\fR. Otherwise the result is the value of \fIz\fR.
.PP
See the C manual for more details on the results
produced by each operator.
The exponentiation operator promotes types like the multiply and
divide operators, and produces a result that is the same as the output
of the \fBpow\fR function (after any type conversions.)
All of the binary operators but exponentiation group left-to-right
within the same precedence level; exponentiation groups right-to-left. For example, the command
The exponentiation operator promotes types in the same way that the multiply
and divide operators do, and the result is is the same as the result of
\fBpow\fR.
Exponentiation groups right-to-left within a precedence level. Other binary
operators group left-to-right. For example, the value of
.PP
.CS
\fBexpr\fR {4*2 < 7}
.CE
.PP
returns 0, while
is 0, while the value of
.PP
.CS
\fBexpr\fR {2**3**2}
.CE
.PP
returns 512.
is 512.
.PP
The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have
As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature
.QW "lazy evaluation" ,
just as in C, which means that operands are not evaluated if they are
not needed to determine the outcome. For example, in the command
which means that operands are not evaluated if they are
not needed to determine the outcome. For example, in
.PP
.CS
\fBexpr\fR {$v ? [a] : [b]}
.CE
.PP
only one of
.QW \fB[a]\fR
or
.QW \fB[b]\fR
will actually be evaluated,
depending on the value of \fB$v\fR. Note, however, that this is
only true if the entire expression is enclosed in braces; otherwise
the Tcl parser will evaluate both
.QW \fB[a]\fR
and
.QW \fB[b]\fR
before invoking the \fBexpr\fR command.
only one of \fB[a]\fR or \fB[b]\fR is evaluated,
depending on the value of \fB$v\fR. This is not true of the normal Tcl parser,
so it is normally recommended to enclose the arguments to \fBexpr\fR in braces.
Without braces, as in
\fBexpr\fR $v ? [a] : [b]
both \fB[a]\fR and \fB[b]\fR are evaluated before \fBexpr\fR is even called.
.PP
For more details on the results
produced by each operator, see the documentation for C.
.SS "MATH FUNCTIONS"
.PP
When the expression parser encounters a mathematical function
such as \fBsin($x)\fR, it replaces it with a call to an ordinary
Tcl function in the \fBtcl::mathfunc\fR namespace. The processing
of an expression such as:
A mathematical function such as \fBsin($x)\fR is replaced with a call to an ordinary
Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation
of an expression such as
.PP
.CS
\fBexpr\fR {sin($x+$y)}
.CE
.PP
is the same in every way as the processing of:
is the same in every way as the evaluation of
.PP
.CS
\fBexpr\fR {[tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]]}
.CE
.PP
which in turn is the same as the processing of:
which in turn is the same as the evaluation of
.PP
.CS
tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]
.CE
.PP
The executor will search for \fBtcl::mathfunc::sin\fR using the usual
rules for resolving functions in namespaces. Either
\fB::tcl::mathfunc::sin\fR or \fB[namespace
current]::tcl::mathfunc::sin\fR will satisfy the request, and others
may as well (depending on the current \fBnamespace path\fR setting).
\fBtcl::mathfunc::sin\fR is resolved as described in
\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the
default value of \fBnamespace path\fR, \fB[namespace
current]::tcl::mathfunc::sin\fR or \fB::tcl::mathfunc::sin\fR are the typical
resolutions.
.PP
Some mathematical functions have several arguments, separated by commas like in C. Thus:
As in C, a mathematical function may accept multiple arguments separated by commas. Thus,
.PP
.CS
\fBexpr\fR {hypot($x,$y)}
.CE
.PP
ends up as
becomes
.PP
.CS
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) manual page for the math functions that are
See the \fBmathfunc\fR(n) documentation for the math functions that are
available by default.
.SS "TYPES, OVERFLOW, AND PRECISION"
.PP
All internal computations involving integers are done calling on the
LibTomMath multiple precision integer library as required so that all
integer calculations are performed exactly. Note that in Tcl releases
prior to 8.5, integer calculations were performed with one of the C types
When needed to guarantee exact performance, internal computations involving
integers use the LibTomMath multiple precision integer library. In Tcl releases
prior to 8.5, integer calculations were performed using one of the C types
\fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation
in those calculations where values overflowed the range of those types.
Any code that relied on these implicit truncations will need to explicitly
add \fBint()\fR or \fBwide()\fR function calls to expressions at the points
where such truncation is required to take place.
Any code that relied on these implicit truncations should instead call
\fBint()\fR or \fBwide()\fR, which do truncate.
.PP
All internal computations involving floating-point are
done with the C type \fIdouble\fR.
When converting a string to floating-point, exponent overflow is
Internal floating-point computations are
performed using the \fIdouble\fR C type.
When converting a string to floating-point value, exponent overflow is
detected and results in the \fIdouble\fR value of \fBInf\fR or
\fB\-Inf\fR as appropriate. Floating-point overflow and underflow
are detected to the degree supported by the hardware, which is generally
pretty reliable.
fairly reliable.
.PP
Conversion among internal representations for integer, floating-point,
and string operands is done automatically as needed.
For arithmetic computations, integers are used until some
floating-point number is introduced, after which floating-point is used.
For example,
Conversion among internal representations for integer, floating-point, and
string operands is done automatically as needed. For arithmetic computations,
integers are used until some floating-point number is introduced, after which
floating-point values are used. For example,
.PP
.CS
\fBexpr\fR {5 / 4}
@@ -335,82 +312,62 @@ returns 1, while
.CE
.PP
both return 1.25.
Floating-point values are always returned with a
A floating-point result can be distinguished from an integer result by the
presence of either
.QW \fB.\fR
or an
or
.QW \fBe\fR
so that they will not look like integer values. For example,
.PP
. For example,
.PP
.CS
\fBexpr\fR {20.0/5.0}
.CE
.PP
returns \fB4.0\fR, not \fB4\fR.
.SS "STRING OPERATIONS"
.PP
String values may be used as operands of the comparison operators,
although the expression evaluator tries to do comparisons as integer
or floating-point when it can,
i.e., when all arguments to the operator allow numeric interpretations,
except in the case of the \fBeq\fR and \fBne\fR operators.
If one of the operands of a comparison is a string and the other
has a numeric value, a canonical string representation of the numeric
operand value is generated to compare with the string operand.
Canonical string representation for integer values is a decimal string
format. Canonical string representation for floating-point values
is that produced by the \fB%g\fR format specifier of Tcl's
\fBformat\fR command. For example, the commands
.PP
.CS
\fBexpr\fR {"0x03" > "2"}
\fBexpr\fR {"0y" > "0x12"}
.CE
.PP
both return 1. The first comparison is done using integer
comparison, and the second is done using string comparison.
Because of Tcl's tendency to treat values as numbers whenever
possible, it is not generally a good idea to use operators like \fB==\fR
when you really want string comparison and the values of the
operands could be arbitrary; it is better in these cases to use
the \fBeq\fR or \fBne\fR operators, or the \fBstring\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
.PP
Enclose expressions in braces for the best speed and the smallest
storage requirements.
This allows the Tcl bytecode compiler to generate the best code.
.PP
As mentioned above, expressions are substituted twice:
once by the Tcl parser and once by the \fBexpr\fR command.
For example, the commands
Where an expression contains syntax that Tcl would otherwise perform
substitutions on, enclosing an expression in braces or otherwise quoting it
so that it's a static value allows the Tcl compiler to generate bytecode for
the expression, resulting in better speed and smaller storage requirements.
This also avoids issues that can arise if Tcl is allowed to perform
substitution on the value before \fBexpr\fR is called.
.PP
In the following example, the value of the expression is 11 because the Tcl parser first
substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR. Enclosing the
expression in braces would result in a syntax error.
.CS
set a 3
set b {$a + 2}
\fBexpr\fR $b*4
.CE
.PP
return 11, not a multiple of 4.
This is because the Tcl parser will first substitute \fB$a + 2\fR for
the variable \fBb\fR,
then the \fBexpr\fR command will evaluate the expression \fB$a + 2*4\fR.
.PP
Most expressions do not require a second round of substitutions.
Either they are enclosed in braces or, if not,
their variable and command substitutions yield numbers or strings
that do not themselves require substitutions.
However, because a few unbraced expressions
need two rounds of substitutions,
the bytecode compiler must emit
additional instructions to handle this situation.
The most expensive code is required for
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
When the expression is unbraced to allow the substitution of a function or
operator, consider using the commands documented in the \fBmathfunc\fR(n) or
\fBmathop\fR(n) manual pages directly instead.
When an expression is generated at runtime, like the one above is, the bytcode
compiler must ensure that new code is generated each time the expression
is evaluated. This is the most costly kind of expression from a performance
perspective. In such cases, consider directly using the commands described in
the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR.
Most expressions are not formed at runtime, but are literal strings or contain
substitutions that don't introduce other substitutions. To allow the bytecode
compiler to work with an expression as a string literal at compilation time,
ensure that it contains no substitutions or that it is enclosed in braces or
otherwise quoted to prevent Tcl from performing substitutions, allowing
\fBexpr\fR to perform them instead.
.SH EXAMPLES
.PP
A numeric comparison whose result is 1:
.CS
\fBexpr\fR {"0x03" > "2"}
.CE
.PP
A string comparison whose result is 1:
.CS
\fBexpr\fR {"0y" > "0x12"}
.CE
.PP
Define a procedure that computes an
.QW interesting
mathematical function:
@@ -444,8 +401,8 @@ each other:
puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]"
.CE
.PP
Set a variable to whether an environment variable is both defined at
all and also set to a true boolean value:
Set a variable indicating whether an environment variable is defined and has
value of true:
.PP
.CS
set isTrue [\fBexpr\fR {
+9 -3
View File
@@ -25,12 +25,15 @@ network sockets.
.PP
The \fBfcopy\fR
command transfers data from \fIinchan\fR until end of file
or \fIsize\fR bytes have been
transferred. If no \fB\-size\fR argument is given,
or \fIsize\fR bytes or characters have been
transferred; \fIsize\fR is in bytes if the two channels are using the
same encoding, and is in characters otherwise.
If no \fB\-size\fR argument is given,
then the copy goes until end of file.
All the data read from \fIinchan\fR is copied to \fIoutchan\fR.
Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete
and returns the number of bytes written to \fIoutchan\fR.
and returns the number of bytes or characters (using the same rules as
for the \fB\-size\fR option) written to \fIoutchan\fR.
.PP
The \fB\-command\fR argument makes \fBfcopy\fR work in the background.
In this case it returns immediately and the \fIcallback\fR is invoked
@@ -174,3 +177,6 @@ vwait done
eof(n), fblocked(n), fconfigure(n), file(n)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation
'\" Local Variables:
'\" mode: nroff
'\" End:
+7 -6
View File
@@ -162,7 +162,9 @@ returns \fB/home\fR (or something similar).
\fBfile executable \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is executable by the current user,
\fB0\fR otherwise.
\fB0\fR otherwise. On Windows, which does not have an executable attribute,
the command treats all directories and any files with extensions
\fBexe\fR, \fBcom\fR, \fBcmd\fR or \fBbat\fR as executable.
.TP
\fBfile exists \fIname\fR
.
@@ -388,7 +390,7 @@ that use the third component do not attempt to perform tilde
substitution.
.RE
.TP
\fBfile stat \fIname varName\fR
\fBfile stat \fIname varName\fR
.
Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable
given by \fIvarName\fR to hold information returned from the kernel call.
@@ -482,10 +484,9 @@ not the effective ones.
.TP
\fBWindows\fR\0\0\0\0
.
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.
The \fBfile owned\fR subcommand uses the user identifier (SID) of
the process token, not the thread token which may be impersonating
some other user.
.SH EXAMPLES
.PP
This procedure shows how to search for C files in a given directory
+4 -1
View File
@@ -418,7 +418,10 @@ set token [::http::geturl https://my.secure.site/]
\fB::http::unregister\fR \fIproto\fR
.
This procedure unregisters a protocol handler that was previously
registered via \fB::http::register\fR.
registered via \fB::http::register\fR, returning a two-item list of
the default port and handler command that was previously installed
(via \fB::http::register\fR) if there was such a handler, and an error if
there was no such handler.
.SH ERRORS
The \fB::http::geturl\fR procedure will raise errors in the following cases:
invalid command line options,
+1 -3
View File
@@ -123,9 +123,7 @@ with conversion character \fBu\fR.
.TP
\fBi\fR
.
The input substring must be an integer. The base (i.e. decimal, binary,
octal, or hexadecimal) is determined in the same fashion as described in
\fBexpr\fR. The integer value is stored in the variable,
The input substring must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined by the C convention (leading 0 for octal; prefix 0x for hexadecimal). The integer value is stored in the variable,
truncated as required by the size modifier value.
.TP
\fBc\fR
+6 -1
View File
@@ -45,7 +45,8 @@ linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
resolves variable names with respect to the global namespace instead
of the current namespace of the procedure.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
@@ -98,3 +99,7 @@ namespace eval foo {
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
+3 -3
View File
@@ -457,7 +457,7 @@ next(
if (ATEOS()) {
FAILW(REG_EESCAPE);
}
(DISCARD)lexescape(v);
(void)lexescape(v);
switch (v->nexttype) { /* not all escapes okay here */
case PLAIN:
return 1;
@@ -716,7 +716,7 @@ next(
}
RETV(PLAIN, *v->now++);
}
(DISCARD)lexescape(v);
(void)lexescape(v);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
@@ -1143,7 +1143,7 @@ skip(
/*
- newline - return the chr for a newline
* This helps confine use of CHR to this source file.
^ static chr newline(NOPARMS);
^ static chr newline(void);
*/
static chr
newline(void)
+1 -1
View File
@@ -1227,7 +1227,7 @@ cmp(
const chr *x, const chr *y, /* strings to compare */
size_t len) /* exact length of comparison */
{
return memcmp(VS(x), VS(y), len*sizeof(chr));
return memcmp((void*)(x), (void*)(y), len*sizeof(chr));
}
/*
+2 -2
View File
@@ -843,7 +843,7 @@ moveins(
/*
- copyins - copy in arcs of a state to another state
^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
^ static void copyins(struct nfa *, struct state *, struct state *, int);
*/
static void
copyins(
@@ -1100,7 +1100,7 @@ moveouts(
/*
- copyouts - copy out arcs of a state to another state
^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
^ static void copyouts(struct nfa *, struct state *, struct state *, int);
*/
static void
copyouts(
+6 -6
View File
@@ -82,7 +82,7 @@ static int lexescape(struct vars *);
static int lexdigits(struct vars *, int, int, int);
static int brenext(struct vars *, pchr);
static void skip(struct vars *);
static chr newline(NOPARMS);
static chr newline(void);
static chr chrnamed(struct vars *, const chr *, const chr *, pchr);
/* === regc_color.c === */
static void initcm(struct vars *, struct colormap *);
@@ -341,13 +341,13 @@ compile(
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
re->re_fns = VS(&functions);
re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
re->re_guts = VS(MALLOC(sizeof(struct guts)));
re->re_guts = (void*)(MALLOC(sizeof(struct guts)));
if (re->re_guts == NULL) {
return freev(v, REG_ESPACE);
}
@@ -434,7 +434,7 @@ compile(
* Can sacrifice main NFA now, so use it as work area.
*/
(DISCARD) optimize(v->nfa, debug);
(void) optimize(v->nfa, debug);
CNOERR();
makesearch(v, v->nfa);
CNOERR();
@@ -1920,10 +1920,10 @@ nfatree(
assert(t != NULL && t->begin != NULL);
if (t->left != NULL) {
(DISCARD) nfatree(v, t->left, f);
(void) nfatree(v, t->left, f);
}
if (t->right != NULL) {
(DISCARD) nfatree(v, t->right, f);
(void) nfatree(v, t->right, f);
}
return nfanode(v, t, f);
+3 -4
View File
@@ -36,10 +36,9 @@
* Overrides for regguts.h definitions, if any.
*/
#define FUNCPTR(name, args) (*name)args
#define MALLOC(n) VS(attemptckalloc(n))
#define FREE(p) ckfree(VS(p))
#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n))
#define MALLOC(n) (void*)(attemptckalloc(n))
#define FREE(p) ckfree((void*)(p))
#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n))
/*
* Do not insert extras between the "begin" and "end" lines - this chunk is
+2 -2
View File
@@ -44,7 +44,7 @@ struct sset { /* state set */
unsigned hash; /* hash of bitvector */
#define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
#define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0))
int flags;
#define STARTER 01 /* the initial state set */
#define POSTSTATE 02 /* includes the goal state */
@@ -268,7 +268,7 @@ exec(
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
zapallsubs(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t));
}
/*
+4 -30
View File
@@ -49,41 +49,15 @@
#include <assert.h>
#endif
/* voids */
#ifndef VOID
#define VOID void /* for function return values */
#endif
#ifndef DISCARD
#define DISCARD void /* for throwing values away */
#endif
#ifndef PVOID
#define PVOID void * /* generic pointer */
#endif
#ifndef VS
#define VS(x) ((void*)(x)) /* cast something to generic ptr */
#endif
#ifndef NOPARMS
#define NOPARMS void /* for empty parm lists */
#endif
/* function-pointer declarator */
#ifndef FUNCPTR
#if __STDC__ >= 1
#define FUNCPTR(name, args) (*name)args
#else
#define FUNCPTR(name, args) (*name)()
#endif
#endif
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
#endif
#ifndef REALLOC
#define REALLOC(p, n) realloc(VS(p), n)
#define REALLOC(p, n) realloc(p, n)
#endif
#ifndef FREE
#define FREE(p) free(VS(p))
#define FREE(p) free(p)
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
@@ -408,7 +382,7 @@ struct subre {
*/
struct fns {
void FUNCPTR(free, (regex_t *));
void (*free) (regex_t *);
};
/*
@@ -425,7 +399,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
int FUNCPTR(compare, (const chr *, const chr *, size_t));
int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
+45
View File
@@ -2326,6 +2326,51 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
# TIP #XXX
declare 631 {
int Tcl_ArraySet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *dictPtr,
int flags)
}
declare 632 {
int Tcl_ArrayUnset(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
int flags)
}
declare 633 {
int Tcl_ArrayGet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
Tcl_Obj *dictPtr, int flags)
}
declare 634 {
int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
Tcl_Obj *listPtr, int flags)
}
declare 635 {
int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
int *intPtr, int flags)
}
declare 636 {
int Tcl_ArrayExists(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int *intPtr, int flags)
}
declare 637 {
Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags)
}
declare 638 {
int Tcl_ArraySearchPeek(Tcl_Interp *interp, Tcl_ArraySearch search,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr)
}
declare 639 {
int Tcl_ArraySearchNext(Tcl_Interp *interp, Tcl_ArraySearch search,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr)
}
declare 640 {
int Tcl_ArraySearchDone(Tcl_Interp *interp, Tcl_ArraySearch search)
}
declare 641 {
int Tcl_ArrayStatistics(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *stringPtr, int flags)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
+23 -13
View File
@@ -532,6 +532,7 @@ typedef struct Tcl_Interp
#endif /* TCL_NO_DEPRECATED */
Tcl_Interp;
typedef struct Tcl_ArraySearch_ *Tcl_ArraySearch;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
@@ -831,19 +832,20 @@ typedef struct Tcl_Obj {
union { /* The internal representation: */
long longValue; /* - an long integer value. */
double doubleValue; /* - a double-precision floating value. */
void *otherValuePtr; /* - another, type-specific value,
not used internally any more. */
void *otherValuePtr; /* - another, type-specific value, not used
* internally any more. */
Tcl_WideInt wideValue; /* - a long long value. */
struct { /* - internal rep as two pointers.
* the main use of which is a bignum's
* Many uses in Tcl, including a bignum's
* tightly packed fields, where the alloc,
* used and signum flags are packed into
* ptr2 with everything else hung off ptr1. */
* ptr2 with everything else hung off
* ptr1. */
void *ptr1;
void *ptr2;
} twoPtrValue;
struct { /* - internal rep as a pointer and a long,
not used internally any more. */
* not used internally any more. */
void *ptr;
unsigned long value;
} ptrAndLongRep;
@@ -1082,9 +1084,10 @@ typedef struct Tcl_DString {
/*
* Flag values passed to variable-related functions.
* WARNING: these bit choices must not conflict with the bit choice for
* TCL_CANCEL_UNWIND, above.
* TCL_CANCEL_UNWIND, above, or TCL_VAR_CREATE (0x4000) in tclVar.c.
*/
#define TCL_MATCH_EXACT 0
#define TCL_GLOBAL_ONLY 1
#define TCL_NAMESPACE_ONLY 2
#define TCL_APPEND_VALUE 4
@@ -1095,14 +1098,19 @@ typedef struct Tcl_DString {
#define TCL_TRACE_DESTROYED 0x80
#define TCL_INTERP_DESTROYED 0x100
#define TCL_LEAVE_ERR_MSG 0x200
/* Value 0x400 is reserved for TCL_PARSE_PART1, conditionally defined below. */
#define TCL_TRACE_ARRAY 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
/* Required to support old variable/vdelete/vinfo traces. */
#define TCL_TRACE_OLD_STYLE 0x1000
#endif
#define TCL_MATCH_REGEXP 0x2000
/* Value 0x4000 is reserved for TCL_VAR_CREATE, defined in tclVar.c. */
/* Indicate the semantics of the result of a trace. */
#define TCL_TRACE_RESULT_DYNAMIC 0x8000
#define TCL_TRACE_RESULT_OBJECT 0x10000
#define TCL_MATCH_GLOB 0x20000
/* Value 0x100000 is reserved for TCL_CANCEL_UNWIND, defined above. */
/*
* Flag values for ensemble commands.
@@ -1157,11 +1165,15 @@ typedef struct Tcl_DString {
* Forward declarations of Tcl_HashTable and related types.
*/
#ifndef TCL_HASH_TYPE
# define TCL_HASH_TYPE unsigned
#endif
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr);
typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr,
void *keyPtr);
@@ -1315,9 +1327,9 @@ typedef struct Tcl_HashSearch {
* TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the
* pointer is stored in the entry.
*
* While maintaining binary compatability the above have to be distinct values
* While maintaining binary compatibility the above have to be distinct values
* as they are used to differentiate between old versions of the hash table
* which don't have a typePtr and new ones which do. Once binary compatability
* which don't have a typePtr and new ones which do. Once binary compatibility
* is discarded in favour of making more wide spread changes TCL_STRING_KEYS
* can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the
* same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is
@@ -2404,10 +2416,6 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#endif
/*
* TODO - tommath stubs export goes here!
*/
/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
@@ -2615,7 +2623,9 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define Tcl_Ckrealloc Tcl_Realloc
# define Tcl_Return Tcl_SetResult
# define Tcl_TildeSubst Tcl_TranslateFileName
#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */
# define panic Tcl_Panic
#endif
# define panicVA Tcl_PanicVA
#endif /* !TCL_NO_DEPRECATED */
+22 -22
View File
@@ -32,7 +32,7 @@
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
typedef unsigned long caddr_t;
typedef size_t caddr_t;
#endif
/*
@@ -56,7 +56,7 @@ union overhead {
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
unsigned long size; /* actual block size */
size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
@@ -133,7 +133,7 @@ static int allocInit = 0;
* a given block size.
*/
static unsigned int numMallocs[NBUCKETS+1];
static size_t numMallocs[NBUCKETS+1];
#endif
#if !defined(NDEBUG)
@@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
static void MoreCore(int bucket);
static void MoreCore(size_t bucket);
/*
*-------------------------------------------------------------------------
@@ -254,7 +254,7 @@ TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
register union overhead *overPtr;
register long bucket;
register size_t bucket;
register unsigned amount;
struct block *bigBlockPtr = NULL;
@@ -385,12 +385,12 @@ TclpAlloc(
static void
MoreCore(
int bucket) /* What bucket to allocat to. */
size_t bucket) /* What bucket to allocate to. */
{
register union overhead *overPtr;
register long size; /* size of desired block */
long amount; /* amount to allocate */
int numBlocks; /* how many blocks we get */
register size_t size; /* size of desired block */
size_t amount; /* amount to allocate */
size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
@@ -398,14 +398,14 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
size = 1 << (bucket + 3);
size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
blockPtr = (struct block *) TclpSysAlloc((unsigned)
blockPtr = (struct block *) TclpSysAlloc(
(sizeof(struct block) + amount), 1);
/* no more room! */
if (blockPtr == NULL) {
@@ -448,7 +448,7 @@ void
TclpFree(
char *oldPtr) /* Pointer to memory to free. */
{
register long size;
register size_t size;
register union overhead *overPtr;
struct block *bigBlockPtr;
@@ -518,7 +518,7 @@ TclpRealloc(
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
unsigned long maxSize;
size_t maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
@@ -645,30 +645,30 @@ void
mstats(
char *s) /* Where to write info. */
{
register int i, j;
register unsigned int i, j;
register union overhead *overPtr;
int totalFree = 0, totalUsed = 0;
size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
fprintf(stderr, " %d", j);
fprintf(stderr, " %u", j);
}
totalFree += j * (1 << (i + 3));
totalFree += ((size_t)j) * (1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
fprintf(stderr, " %d", numMallocs[i]);
fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]);
totalUsed += numMallocs[i] * (1 << (i + 3));
}
fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
totalUsed, totalFree);
fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
MAXMALLOC, numMallocs[NBUCKETS]);
fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n",
(Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree);
fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n",
MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
+26 -26
View File
@@ -1299,8 +1299,8 @@ AssembleOneLine(
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
@@ -1448,8 +1448,8 @@ AssembleOneLine(
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
@@ -1543,7 +1543,7 @@ AssembleOneLine(
* Add the (label_name, address) pair to the hash table.
*/
if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
@@ -1722,7 +1722,7 @@ AssembleOneLine(
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
Tcl_GetString(instNameObj));
TclGetString(instNameObj));
}
status = TCL_OK;
@@ -1985,15 +1985,15 @@ CreateMirrorJumpTable(
DEBUG_PRINT("jump table {\n");
for (i = 0; i < objc; i+=2) {
DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
Tcl_GetString(objv[i+1]));
hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]),
TclGetString(objv[i+1]));
hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
Tcl_GetString(objv[i])));
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
@@ -2288,7 +2288,7 @@ FindLocalVar(
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return -1;
}
varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return -1;
@@ -2801,7 +2801,7 @@ CalculateJumpRelocations(
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
TclGetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
@@ -2882,10 +2882,10 @@ CheckJumpTableLabels(
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(symbolObj));
TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj), (valEntryPtr != NULL));
TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
@@ -2923,9 +2923,9 @@ ReportUndefinedLabel(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"undefined label \"%s\"", Tcl_GetString(jumpTarget)));
"undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
Tcl_GetString(jumpTarget), NULL);
TclGetString(jumpTarget), NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
@@ -3008,7 +3008,7 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
@@ -3080,17 +3080,17 @@ ResolveJumpTableTargets(
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(symbolObj));
TclGetString(symbolObj));
jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj), jumpTargetBBPtr,
TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
@@ -3462,7 +3462,7 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(blockPtr->jumpTarget));
TclGetString(blockPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
@@ -3479,7 +3479,7 @@ StackCheckBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(targetLabel));
TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
@@ -3541,7 +3541,7 @@ StackCheckExit(
* Emit a 'push' of the empty literal.
*/
litIndex = TclRegisterNewLiteral(envPtr, "", 0);
litIndex = TclRegisterLiteral(envPtr, "", 0, 0);
/*
* Assumes that 'push' is at slot 0 in TalInstructionTable.
@@ -3784,7 +3784,7 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3800,7 +3800,7 @@ ProcessCatchesInBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(targetLabel));
TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -4104,7 +4104,7 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(catch->jumpTarget));
TclGetString(catch->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
+52 -39
View File
@@ -128,7 +128,7 @@ static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
static Tcl_NRPostProc NRCommand;
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
@@ -146,7 +146,6 @@ static int TEOV_RunEnterTraces(Tcl_Interp *interp,
Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc TEOEx_ListCallback;
static Tcl_NRPostProc TEOV_Error;
@@ -589,7 +588,7 @@ Tcl_CreateInterp(void)
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
iPtr->compileEpoch = 0;
iPtr->compileEpoch = 1;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
@@ -941,8 +940,8 @@ Tcl_CreateInterp(void)
* Set up other variables such as tcl_version and tcl_library
*/
Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
@@ -967,11 +966,11 @@ Tcl_CreateInterp(void)
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
@@ -981,7 +980,7 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
#endif
@@ -1636,7 +1635,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
ckfree((char *) iPtr->lineLAPtr);
ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -2404,7 +2403,7 @@ TclInvokeStringCommand(
TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
@@ -2658,7 +2657,7 @@ TclRenameCommand(
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -3024,13 +3023,6 @@ Tcl_DeleteCommandFromToken(
ImportRef *refPtr, *nextRefPtr;
Tcl_Command importCmd;
/*
* Bump the command epoch counter. This will invalidate all cached
* references that point to this command.
*/
cmdPtr->cmdEpoch++;
/*
* The code here is tricky. We can't delete the hash table entry before
* invoking the deletion callback because there are cases where the
@@ -3053,6 +3045,14 @@ Tcl_DeleteCommandFromToken(
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
/*
* Bump the command epoch counter. This will invalidate all cached
* references that point to this command.
*/
cmdPtr->cmdEpoch++;
return 0;
}
@@ -3155,6 +3155,13 @@ Tcl_DeleteCommandFromToken(
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
/*
* Bump the command epoch counter. This will invalidate all cached
* references that point to this command.
*/
cmdPtr->cmdEpoch++;
}
/*
@@ -3401,8 +3408,7 @@ TclCleanupCommand(
register Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
cmdPtr->refCount--;
if (cmdPtr->refCount <= 0) {
if (cmdPtr->refCount-- <= 1) {
ckfree(cmdPtr);
}
}
@@ -3524,7 +3530,7 @@ OldMathFuncProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
@@ -3944,7 +3950,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4043,7 +4049,7 @@ Tcl_CancelEval(
*/
if (resultObjPtr != NULL) {
result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length);
memcpy(cancelInfo->result, result, (size_t) cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
@@ -4555,7 +4561,7 @@ TEOV_Error(
*/
listPtr = Tcl_NewListObj(objc, objv);
cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
cmdString = TclGetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
@@ -4701,7 +4707,7 @@ TEOV_RunEnterTraces(
Command *cmdPtr = *cmdPtrPtr;
int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
const char *command = Tcl_GetStringFromObj(commandPtr, &length);
const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4753,7 +4759,7 @@ TEOV_RunLeaveTraces(
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
int length;
const char *command = Tcl_GetStringFromObj(commandPtr, &length);
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
@@ -5579,8 +5585,7 @@ TclArgumentRelease(
}
cfwPtr = Tcl_GetHashValue(hPtr);
cfwPtr->refCount--;
if (cfwPtr->refCount > 0) {
if (cfwPtr->refCount-- > 1) {
continue;
}
@@ -6118,7 +6123,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6149,7 +6154,7 @@ TEOEx_ByteCodeCallback(
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6848,7 +6853,7 @@ Tcl_VarEvalVA(
Tcl_DStringAppend(&buf, string, -1);
}
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
@@ -6918,7 +6923,7 @@ Tcl_GlobalEval(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
result = Tcl_Eval(interp, command);
result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
@@ -7885,7 +7890,7 @@ MathFuncWrongNumArgs(
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
const char *name = Tcl_GetString(objv[0]);
const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name+1) {
@@ -8372,7 +8377,7 @@ TclNRTailcallEval(
* a now-gone namespace: cleanup and return.
*/
TailcallCleanup(data, interp, result);
Tcl_DecrRefCount(listPtr);
return result;
}
@@ -8381,18 +8386,26 @@ TclNRTailcallEval(
*/
TclMarkTailcall(interp);
TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
static int
TailcallCleanup(
int
TclNRReleaseValues(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
int i = 0;
while (i < 4) {
if (data[i]) {
Tcl_DecrRefCount((Tcl_Obj *) data[i]);
} else {
break;
}
i++;
}
return result;
}
@@ -8810,7 +8823,7 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
Tcl_GetString(objv[0])));
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
+134 -44
View File
@@ -155,35 +155,108 @@ static const EnsembleImplMap decodeMap[] = {
};
/*
* The following object type represents an array of bytes. An array of bytes
* is not equivalent to an internationalized string. Conceptually, a string is
* an array of 16-bit quantities organized as a sequence of properly formed
* UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
* Accessor functions are provided to convert a ByteArray to a String or a
* String to a ByteArray. Two or more consecutive bytes in an array of bytes
* may look like a single UTF-8 character if the array is casually treated as
* a string. But obtaining the String from a ByteArray is guaranteed to
* produced properly formed UTF-8 sequences so that there is a one-to-one map
* between bytes and characters.
* The following object types represent an array of bytes. The intent is
* to allow arbitrary binary data to pass through Tcl as a Tcl value
* without loss or damage. Such values are useful for things like
* encoded strings or Tk images to name just two.
*
* Converting a ByteArray to a String proceeds by casting each byte in the
* array to a 16-bit quantity, treating that number as a Unicode character,
* and storing the UTF-8 version of that Unicode character in the String. For
* ByteArrays consisting entirely of values 1..127, the corresponding String
* representation is the same as the ByteArray representation.
* It's strange to have two Tcl_ObjTypes in place for this task when
* one would do, so a bit of detail and history how we got to this point
* and where we might go from here.
*
* Converting a String to a ByteArray proceeds by getting the Unicode
* representation of each character in the String, casting it to a byte by
* truncating the upper 8 bits, and then storing the byte in the ByteArray.
* Converting from ByteArray to String and back to ByteArray is not lossy, but
* converting an arbitrary String to a ByteArray may be.
* A bytearray is an ordered sequence of bytes. Each byte is an integer
* value in the range [0-255]. To be a Tcl value type, we need a way to
* encode each value in the value set as a Tcl string. The simplest
* encoding is to represent each byte value as the same codepoint value.
* A bytearray of N bytes is encoded into a Tcl string of N characters
* where the codepoint of each character is the value of corresponding byte.
* This approach creates a one-to-one map between all bytearray values
* and a subset of Tcl string values.
*
* When converting a Tcl string value to the bytearray internal rep, the
* question arises what to do with strings outside that subset? That is,
* those Tcl strings containing at least one codepoint greater than 255?
* The obviously correct answer is to raise an error! That string value
* does not represent any valid bytearray value. Full Stop. The
* setFromAnyProc signature has a completion code return value for just
* this reason, to reject invalid inputs.
*
* Unfortunately this was not the path taken by the authors of the
* original tclByteArrayType. They chose to accept all Tcl string values
* as acceptable string encodings of the bytearray values that result
* from masking away the high bits of any codepoint value at all. This
* meant that every bytearray value had multiple accepted string
* representations.
*
* The implications of this choice are truly ugly. When a Tcl value has
* a string representation, we are required to accept that as the true
* value. Bytearray values that possess a string representation cannot
* be processed as bytearrays because we cannot know which true value
* that bytearray represents. The consequence is that we drag around
* an internal rep that we cannot make any use of. This painful price
* is extracted at any point after a string rep happens to be generated
* for the value. This happens even when the troublesome codepoints
* outside the byte range never show up. This happens rather routinely
* in normal Tcl operations unless we burden the script writer with the
* cognitive burden of avoiding it. The price is also paid by callers
* of the C interface. The routine
*
* unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
*
* has a guarantee to always return a non-NULL value, but that value
* points to a byte sequence that cannot be used by the caller to
* process the Tcl value absent some sideband testing that objPtr
* is "pure". Tcl offers no public interface to perform this test,
* so callers either break encapsulation or are unavoidably buggy. Tcl
* has defined a public interface that cannot be used correctly. The
* Tcl source code itself suffers the same problem, and has been buggy,
* but progressively less so as more and more portions of the code have
* been retrofitted with the required "purity testing". The set of values
* able to pass the purity test can be increased via the introduction of
* a "canonical" flag marker, but the only way the broken interface itself
* can be discarded is to start over and define the Tcl_ObjType properly.
* Bytearrays should simply be usable as bytearrays without a kabuki
* dance of testing.
*
* The Tcl_ObjType "properByteArrayType" is (nearly) a correct
* implementation of bytearrays. Any Tcl value with the type
* properByteArrayType can have its bytearray value fetched and
* used with confidence that acting on that value is equivalent to
* acting on the true Tcl string value. This still implies a side
* testing burden -- past mistakes will not let us avoid that
* immediately, but it is at least a conventional test of type, and
* can be implemented entirely by examining the objPtr fields, with
* no need to query the intrep, as a canonical flag would require.
*
* Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can
* be revised to admit the possibility of returning NULL when the true
* value is not a valid bytearray, we need a mechanism to retain
* compatibility with the deployed callers of the broken interface.
* That's what the retained "tclByteArrayType" provides. In those
* unusual circumstances where we convert an invalid bytearray value
* to a bytearray type, it is to this legacy type. Essentially any
* time this legacy type gets used, it's a signal of a bug being ignored.
* A TIP should be drafted to remove this connection to the broken past
* so that Tcl 9 will no longer have any trace of it. Prescribing a
* migration path will be the key element of that work. The internal
* changes now in place are the limit of what can be done short of
* interface repair. They provide a great expansion of the histories
* over which bytearray values can be useful in the meanwhile.
*/
static const Tcl_ObjType properByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
UpdateStringOfByteArray,
NULL
};
const Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
UpdateStringOfByteArray,
NULL,
SetByteArrayFromAny
};
@@ -211,6 +284,12 @@ typedef struct ByteArray {
#define SET_BYTEARRAY(objPtr, baPtr) \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
int
TclIsPureByteArray(
Tcl_Obj * objPtr)
{
return (objPtr->typePtr == &properByteArrayType);
}
/*
*----------------------------------------------------------------------
@@ -341,7 +420,7 @@ Tcl_SetByteArrayObj(
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
}
objPtr->typePtr = &tclByteArrayType;
objPtr->typePtr = &properByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
@@ -371,7 +450,8 @@ Tcl_GetByteArrayFromObj(
{
ByteArray *baPtr;
if (objPtr->typePtr != &tclByteArrayType) {
if ((objPtr->typePtr != &properByteArrayType)
&& (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
baPtr = GET_BYTEARRAY(objPtr);
@@ -414,7 +494,8 @@ Tcl_SetByteArrayLength(
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
if (objPtr->typePtr != &tclByteArrayType) {
if ((objPtr->typePtr != &properByteArrayType)
&& (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
@@ -450,29 +531,37 @@ SetByteArrayFromAny(
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
int length;
size_t length;
int improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
if (objPtr->typePtr != &tclByteArrayType) {
src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += Tcl_UtfToUniChar(src, &ch);
*dst++ = UCHAR(ch);
}
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
TclFreeIntRep(objPtr);
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
if (objPtr->typePtr == &properByteArrayType) {
return TCL_OK;
}
if (objPtr->typePtr == &tclByteArrayType) {
return TCL_OK;
}
src = TclGetString(objPtr);
length = objPtr->length;
srcEnd = src + length;
byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += Tcl_UtfToUniChar(src, &ch);
improper = improper || (ch > 255);
*dst++ = UCHAR(ch);
}
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
TclFreeIntRep(objPtr);
objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
return TCL_OK;
}
@@ -535,7 +624,7 @@ DupByteArrayInternalRep(
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
SET_BYTEARRAY(copyPtr, copyArrayPtr);
copyPtr->typePtr = &tclByteArrayType;
copyPtr->typePtr = srcPtr->typePtr;
}
/*
@@ -642,7 +731,8 @@ TclAppendBytesToByteArray(
/* Append zero bytes is a no-op. */
return;
}
if (objPtr->typePtr != &tclByteArrayType) {
if ((objPtr->typePtr != &properByteArrayType)
&& (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
@@ -2500,7 +2590,7 @@ BinaryEncode64(
}
break;
case OPT_WRAPCHAR:
wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen);
wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen);
if (wrapcharlen == 0) {
maxlen = 0;
}
+27 -28
View File
@@ -34,14 +34,14 @@
*/
typedef struct MemTag {
int refCount; /* Number of mem_headers referencing this
size_t refCount; /* Number of mem_headers referencing this
* tag. */
char string[1]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString))
#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString)
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,14 +52,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* to help detect chunk under-runs.
*/
#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8)
struct mem_header {
struct mem_header *flink;
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
const char *file;
long length;
size_t length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
/* Aligns body on 8-byte boundary, plus
@@ -251,10 +251,10 @@ ValidateMemory(
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "low guard failed at %lx, %s %d\n",
(long unsigned) memHeaderP->body, file, line);
fprintf(stderr, "low guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -273,11 +273,11 @@ ValidateMemory(
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "high guard failed at %lx, %s %d\n",
(long unsigned) memHeaderP->body, file, line);
fprintf(stderr, "high guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n",
(Tcl_WideInt)memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -359,10 +359,10 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
(long unsigned) address,
(long unsigned) address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
fprintf(fileP, "%8" TCL_LL_MODIFIER "x - %8" TCL_LL_MODIFIER "x %7" TCL_LL_MODIFIER "d @ %s %d %s",
(Tcl_WideInt)(size_t)address,
(Tcl_WideInt)((size_t)address + memScanP->length - 1),
(Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
@@ -458,8 +458,8 @@ Tcl_DbCkalloc(
}
if (alloc_tracing) {
fprintf(stderr,"ckalloc %lx %u %s %d\n",
(long unsigned int) result->body, size, file, line);
fprintf(stderr,"ckalloc %p %u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
@@ -547,8 +547,8 @@ Tcl_AttemptDbCkalloc(
}
if (alloc_tracing) {
fprintf(stderr,"ckalloc %lx %u %s %d\n",
(long unsigned int) result->body, size, file, line);
fprintf(stderr,"ckalloc %p %u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
@@ -612,8 +612,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
fprintf(stderr, "ckfree %lx %ld %s %d\n",
(long unsigned int) memp->body, memp->length, file, line);
fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n",
memp->body, (Tcl_WideInt) memp->length, file, line);
}
if (validate_memory) {
@@ -623,7 +623,7 @@ Tcl_DbCkfree(
Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset(ptr, GUARD_VALUE, (size_t) memp->length);
memset(ptr, GUARD_VALUE, memp->length);
}
total_frees++;
@@ -631,8 +631,7 @@ Tcl_DbCkfree(
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
memp->tagPtr->refCount--;
if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
TclpFree((char *) memp->tagPtr);
}
}
@@ -675,7 +674,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
unsigned int copySize;
size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,7 +688,7 @@ Tcl_DbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > (unsigned int) memp->length) {
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_DbCkalloc(size, file, line);
@@ -706,7 +705,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
unsigned int copySize;
size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,7 +719,7 @@ Tcl_AttemptDbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > (unsigned int) memp->length) {
if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_AttemptDbCkalloc(size, file, line);
+14 -3
View File
@@ -92,7 +92,7 @@ static const char *const literals[] = {
*/
typedef struct ClockClientData {
int refCount; /* Number of live references. */
size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
@@ -1499,7 +1499,19 @@ GetJulianDayFromEraYearMonthDay(
* Try an initial conversion in the Gregorian calendar.
*/
#if 0 /* BUG http://core.tcl.tk/tcl/tktview?name=da340d4f32 */
ym1o4 = ym1 / 4;
#else
/*
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
if (ym1 >= 0)
ym1o4 = ym1 / 4;
else {
ym1o4 = - (int) (((unsigned int) -ym1) / 4);
}
#endif
if (ym1 % 4 < 0) {
ym1o4--;
}
@@ -2048,8 +2060,7 @@ ClockDeleteCmdProc(
ClockClientData *data = clientData;
int i;
data->refCount--;
if (data->refCount == 0) {
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
+31 -12
View File
@@ -12,6 +12,9 @@
*/
#include "tclInt.h"
#ifdef _WIN32
# include "tclWinInt.h"
#endif
#include <locale.h>
/*
@@ -1157,6 +1160,16 @@ FileAttrAccessTimeCmd(
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the access time not available */
if (buf.st_atime == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get access time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
@@ -1229,6 +1242,15 @@ FileAttrModifyTimeCmd(
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the modification time not available */
if (buf.st_mtime == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get modification time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
@@ -1574,28 +1596,25 @@ FileAttrIsOwnedCmd(
int objc,
Tcl_Obj *const objv[])
{
#ifdef __CYGWIN__
#define geteuid() (short)(geteuid)()
#endif
#if !defined(_WIN32)
Tcl_StatBuf buf;
#endif
int value = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
/*
* For Windows, there are no user ids associated with a file, so we
* always return 1.
*
* TODO: use GetSecurityInfo to get the real owner of the file and
* test for equivalence to the current user.
*/
#if defined(_WIN32) || defined(__CYGWIN__)
value = 1;
#if defined(_WIN32)
value = TclWinFileOwned(objv[1]);
#else
if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
value = (geteuid() == buf.st_uid);
#endif
}
#endif
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
return TCL_OK;
}
+40 -13
View File
@@ -105,8 +105,7 @@ typedef struct SortInfo {
*/
static int DictionaryCompare(const char *left, const char *right);
static int IfConditionCallback(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc IfConditionCallback;
static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
@@ -1678,7 +1677,7 @@ InfoLibraryCmd(
return TCL_ERROR;
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
@@ -1804,7 +1803,7 @@ InfoPatchLevelCmd(
return TCL_ERROR;
}
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
@@ -2156,8 +2155,8 @@ Tcl_JoinObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int listLen, i;
Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
int listLen;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2174,19 +2173,47 @@ Tcl_JoinObjCmd(
return TCL_ERROR;
}
if (listLen == 0) {
/* No elements to join; default empty result is correct. */
return TCL_OK;
}
if (listLen == 1) {
/* One element; return it */
Tcl_SetObjResult(interp, elemPtrs[0]);
return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
resObjPtr = Tcl_NewObj();
for (i = 0; i < listLen; i++) {
if (i > 0) {
Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
if (Tcl_GetCharLength(joinObjPtr) == 0) {
TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs,
&resObjPtr);
} else {
int i;
resObjPtr = Tcl_NewObj();
for (i = 0; i < listLen; i++) {
if (i > 0) {
/*
* NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
* to shimmer joinObjPtr. If it did, then the case where
* objv[1] and objv[2] are the same value would not be safe.
* Accessing elemPtrs would crash.
*/
Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
}
Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_DecrRefCount(joinObjPtr);
Tcl_SetObjResult(interp, resObjPtr);
return TCL_OK;
if (resObjPtr) {
Tcl_SetObjResult(interp, resObjPtr);
return TCL_OK;
}
return TCL_ERROR;
}
/*
+41 -207
View File
@@ -22,14 +22,10 @@
static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode,
Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
static int SwitchPostProc(ClientData data[], Tcl_Interp *interp,
int result);
static int TryPostBody(ClientData data[], Tcl_Interp *interp,
int result);
static int TryPostFinal(ClientData data[], Tcl_Interp *interp,
int result);
static int TryPostHandler(ClientData data[], Tcl_Interp *interp,
int result);
static Tcl_NRPostProc SwitchPostProc;
static Tcl_NRPostProc TryPostBody;
static Tcl_NRPostProc TryPostFinal;
static Tcl_NRPostProc TryPostHandler;
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
@@ -327,7 +323,7 @@ Tcl_RegexpObjCmd(
if (match == 0) {
/*
* We want to set the value of the intepreter result only when
* We want to set the value of the interpreter result only when
* this is the first time through the loop.
*/
@@ -1180,8 +1176,7 @@ StringFirstCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *needleStr, *haystackStr;
int match, start, needleLen, haystackLen;
int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1189,82 +1184,23 @@ StringFirstCmd(
return TCL_ERROR;
}
/*
* We are searching haystackStr for the sequence needleStr.
*/
match = -1;
start = 0;
haystackLen = -1;
needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (objc == 4) {
/*
* If a startIndex is specified, we will need to fast forward to that
* point in the string before we think about a match.
*/
int size = Tcl_GetCharLength(objv[2]);
if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
&start) != TCL_OK){
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
/*
* Reread to prevent shimmering problems.
*/
needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (start >= haystackLen) {
goto str_first_done;
} else if (start > 0) {
haystackStr += start;
haystackLen -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start; Bug #423581
*/
if (start < 0) {
start = 0;
}
}
/*
* If the length of the needle is more than the length of the haystack, it
* cannot be contained in there so we can avoid searching. [Bug 2960021]
*/
if (needleLen > 0 && needleLen <= haystackLen) {
register Tcl_UniChar *p, *end;
end = haystackStr + haystackLen - needleLen + 1;
for (p = haystackStr; p < end; p++) {
/*
* Scan forward to find the first character.
*/
if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p,
(unsigned long) needleLen) == 0)) {
match = p - haystackStr;
break;
}
if (start >= size) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
return TCL_OK;
}
}
/*
* Compute the character index of the matching string by counting the
* number of characters before the match.
*/
if ((match != -1) && (objc == 4)) {
match += start;
}
str_first_done:
Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1],
objv[2], start)));
return TCL_OK;
}
@@ -1293,76 +1229,31 @@ StringLastCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *needleStr, *haystackStr, *p;
int match, start, needleLen, haystackLen;
int last = INT_MAX - 1;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?startIndex?");
"needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
/*
* We are searching haystackString for the sequence needleString.
*/
match = -1;
start = 0;
haystackLen = -1;
needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (objc == 4) {
/*
* If a startIndex is specified, we will need to restrict the string
* range to that char index in the string
*/
int size = Tcl_GetCharLength(objv[2]);
if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
&start) != TCL_OK){
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
/*
* Reread to prevent shimmering problems.
*/
needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
if (start < 0) {
goto str_last_done;
} else if (start < haystackLen) {
p = haystackStr + start + 1 - needleLen;
} else {
p = haystackStr + haystackLen - needleLen;
if (last < 0) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
return TCL_OK;
}
} else {
p = haystackStr + haystackLen - needleLen;
}
/*
* If the length of the needle is more than the length of the haystack, it
* cannot be contained in there so we can avoid searching. [Bug 2960021]
*/
if (needleLen > 0 && needleLen <= haystackLen) {
for (; p >= haystackStr; p--) {
/*
* Scan backwards to find the first character.
*/
if ((*p == *needleStr) && !memcmp(needleStr, p,
sizeof(Tcl_UniChar) * (size_t)needleLen)) {
match = p - haystackStr;
break;
}
if (last >= size) {
last = size - 1;
}
}
str_last_done:
Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1],
objv[2], last)));
return TCL_OK;
}
@@ -1877,7 +1768,7 @@ StringMapCmd(
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20 for illustration why!)
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){
@@ -2227,9 +2118,7 @@ StringReptCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1;
char *string2;
int count, index, length1, length2;
int count;
Tcl_Obj *resultPtr;
if (objc != 3) {
@@ -2247,70 +2136,15 @@ StringReptCmd(
if (count == 1) {
Tcl_SetObjResult(interp, objv[1]);
goto done;
return TCL_OK;
} else if (count < 1) {
goto done;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (length1 <= 0) {
goto done;
return TCL_OK;
}
/*
* Only build up a string that has data. Instead of building it up with
* repeated appends, we just allocate the necessary space once and copy
* the string value in.
*
* We have to worry about overflow [Bugs 714106, 2561746].
* At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX.
* We need to keep 2 <= length2 <= INT_MAX.
*/
if (count > INT_MAX/length1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"result exceeds max size for a Tcl value (%d bytes)",
INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) {
return TCL_ERROR;
}
length2 = length1 * count;
/*
* Include space for the NUL.
*/
string2 = attemptckalloc((unsigned) length2 + 1);
if (string2 == NULL) {
/*
* Alloc failed. Note that in this case we try to do an error message
* since this is a case that's most likely when the alloc is large and
* that's easy to do with this API. Note that if we fail allocating a
* short string, this will likely keel over too (and fatally).
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow, out of memory allocating %u bytes",
length2 + 1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1, (size_t) length1);
}
string2[length2] = '\0';
/*
* We have to directly assign this instead of using Tcl_SetStringObj (and
* indirectly TclInitStringRep) because that makes another copy of the
* data.
*/
TclNewObj(resultPtr);
resultPtr->bytes = string2;
resultPtr->length = length2;
Tcl_SetObjResult(interp, resultPtr);
done:
return TCL_OK;
}
@@ -2859,7 +2693,7 @@ StringCatCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i;
int code;
Tcl_Obj *objResultPtr;
if (objc < 2) {
@@ -2876,16 +2710,16 @@ StringCatCmd(
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
objResultPtr = objv[1];
if (Tcl_IsShared(objResultPtr)) {
objResultPtr = Tcl_DuplicateObj(objResultPtr);
}
for(i = 2;i < objc;i++) {
Tcl_AppendObjToObj(objResultPtr, objv[i]);
}
Tcl_SetObjResult(interp, objResultPtr);
return TCL_OK;
code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1,
&objResultPtr);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, objResultPtr);
return TCL_OK;
}
return code;
}
/*
@@ -4323,7 +4157,7 @@ TclNRTryObjCmd(
}
info[0] = objv[i]; /* type */
TclNewIntObj(info[1], code); /* returnCode */
TclNewLongObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
TclNewObj(info[2]);
}
+6 -17
View File
@@ -801,7 +801,7 @@ TclCompileConcatCmd(
Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
bytes = Tcl_GetStringFromObj(objPtr, &len);
bytes = TclGetStringFromObj(objPtr, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
@@ -1209,7 +1209,7 @@ TclCompileDictCreateCmd(
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
bytes = Tcl_GetStringFromObj(dictObj, &len);
bytes = TclGetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
@@ -2650,7 +2650,7 @@ CompileEachloopCmd(
int numBytes, varIndex;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
bytes = TclGetStringFromObj(varNameObj, &numBytes);
varIndex = LocalScalar(bytes, numBytes, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
@@ -3087,7 +3087,7 @@ TclCompileFormatCmd(
* literal. Job done.
*/
bytes = Tcl_GetStringFromObj(tmpObj, &len);
bytes = TclGetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
@@ -3158,7 +3158,7 @@ TclCompileFormatCmd(
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
char *b = Tcl_GetStringFromObj(tmpObj, &len);
char *b = TclGetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
@@ -3192,7 +3192,7 @@ TclCompileFormatCmd(
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
bytes = Tcl_GetStringFromObj(tmpObj, &len);
bytes = TclGetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
@@ -3206,17 +3206,6 @@ TclCompileFormatCmd(
*/
TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr);
} else {
/*
* EVIL HACK! Force there to be a string representation in the case
* where there's just a "%s" in the format; case covered by the test
* format-20.1 (and it is horrible...)
*/
TclEmitOpcode(INST_DUP, envPtr);
PushStringLiteral(envPtr, "");
TclEmitOpcode(INST_STR_EQ, envPtr);
TclEmitOpcode(INST_POP, envPtr);
}
return TCL_OK;
}
+3 -3
View File
@@ -2451,7 +2451,7 @@ TclCompileRegsubCmd(
* replacement "simple"?
*/
bytes = Tcl_GetStringFromObj(patternObj, &len);
bytes = TclGetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
@@ -2499,7 +2499,7 @@ TclCompileRegsubCmd(
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(replacementObj, &len);
bytes = TclGetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
TclEmitOpcode( INST_STR_MAP, envPtr);
@@ -2761,7 +2761,7 @@ TclCompileSyntaxError(
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
+16 -16
View File
@@ -312,7 +312,7 @@ TclCompileStringCatCmd(
Tcl_DecrRefCount(obj);
if (folded) {
int len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -330,7 +330,7 @@ TclCompileStringCatCmd(
}
if (folded) {
int len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -948,12 +948,12 @@ TclCompileStringMapCmd(
* correct semantics for mapping.
*/
bytes = Tcl_GetStringFromObj(objv[0], &len);
bytes = TclGetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(objv[1], &len);
bytes = TclGetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
@@ -1456,8 +1456,8 @@ TclSubstCompile(
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
literal = TclRegisterNewLiteral(envPtr,
tokenPtr->start, tokenPtr->size);
literal = TclRegisterLiteral(envPtr,
tokenPtr->start, tokenPtr->size, 0);
TclEmitPush(literal, envPtr);
TclAdvanceLines(&bline, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
@@ -1466,7 +1466,7 @@ TclSubstCompile(
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
literal = TclRegisterNewLiteral(envPtr, buf, length);
literal = TclRegisterLiteral(envPtr, buf, length, 0);
TclEmitPush(literal, envPtr);
count++;
continue;
@@ -1902,10 +1902,10 @@ TclCompileSwitchCmd(
}
if (numWords % 2) {
abort:
ckfree((char *) bodyToken);
ckfree((char *) bodyTokenArray);
ckfree((char *) bodyLines);
ckfree((char *) bodyContLines);
ckfree(bodyToken);
ckfree(bodyTokenArray);
ckfree(bodyLines);
ckfree(bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
@@ -2825,7 +2825,7 @@ TclCompileTryCmd(
}
if (objc > 0) {
int len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
const char *varname = TclGetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
@@ -2837,7 +2837,7 @@ TclCompileTryCmd(
}
if (objc == 2) {
int len;
const char *varname = Tcl_GetStringFromObj(objv[1], &len);
const char *varname = TclGetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
@@ -3040,7 +3040,7 @@ IssueTryClausesInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &len);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
@@ -3251,7 +3251,7 @@ IssueTryClausesFinallyInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &len);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
@@ -3579,7 +3579,7 @@ TclCompileUnsetCmd(
const char *bytes;
int len;
bytes = Tcl_GetStringFromObj(leadingWord, &len);
bytes = TclGetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
+9 -9
View File
@@ -2267,9 +2267,9 @@ CompileExprTree(
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName)), envPtr);
Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
/*
@@ -2376,8 +2376,8 @@ CompileExprTree(
pc1 = CurrentOffset(envPtr);
TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
: INST_JUMP_TRUE1, 0, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
TclEmitPush(TclRegisterLiteral(envPtr,
(nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr);
pc2 = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
@@ -2386,8 +2386,8 @@ CompileExprTree(
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
pc2 += 3;
}
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
TclEmitPush(TclRegisterLiteral(envPtr,
(nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
envPtr->codeStart + pc2 + 1);
convert = 0;
@@ -2421,7 +2421,7 @@ CompileExprTree(
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
int index = TclRegisterNewLiteral(envPtr, bytes, length);
int index = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
@@ -2479,8 +2479,8 @@ CompileExprTree(
if (objPtr->bytes) {
Tcl_Obj *tableValue;
index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
objPtr->length);
index = TclRegisterLiteral(envPtr, objPtr->bytes,
objPtr->length, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
+27 -16
View File
@@ -765,7 +765,8 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
int length, result = TCL_OK;
size_t length;
int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -780,7 +781,8 @@ TclSetByteCodeFromAny(
}
#endif
stringPtr = TclGetStringFromObj(objPtr, &length);
stringPtr = TclGetString(objPtr);
length = objPtr->length;
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
@@ -1002,7 +1004,7 @@ void
TclReleaseByteCode(
register ByteCode *codePtr)
{
if (--codePtr->refCount) {
if (codePtr->refCount-- > 1) {
return;
}
@@ -1314,7 +1316,7 @@ CompileSubstObj(
if (objPtr->typePtr != &substCodeType) {
CompileEnv compEnv;
int numBytes;
const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
@@ -1380,14 +1382,14 @@ ReleaseCmdWordData(
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
ckfree((char *) eclPtr->loc[i].line);
ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree((char *) eclPtr->loc);
ckfree(eclPtr->loc);
}
ckfree((char *) eclPtr);
ckfree(eclPtr);
}
/*
@@ -1792,9 +1794,17 @@ CompileCmdLiteral(
CompileEnv *envPtr)
{
int numBytes;
const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
const char *bytes;
Command *cmdPtr;
int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &numBytes);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
@@ -1829,8 +1839,8 @@ TclCompileInvocation(
continue;
}
objIdx = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
objIdx = TclRegisterLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1879,8 +1889,8 @@ CompileExpanded(
continue;
}
objIdx = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
objIdx = TclRegisterLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -2729,7 +2739,7 @@ PreventCycle(
* the intrep.
*/
int numBytes;
const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
Tcl_IncrRefCount(copyPtr);
@@ -2968,7 +2978,8 @@ TclFindCompiledLocal(
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
localName = Tcl_GetStringFromObj(*varNamePtr, &len);
localName = TclGetString(*varNamePtr);
len = (*varNamePtr)->length;
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
+5 -27
View File
@@ -417,7 +417,7 @@ typedef struct ByteCode {
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
int compileEpoch; /* Value of iPtr->compileEpoch when this
unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
@@ -1095,7 +1095,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
int length, unsigned int hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
@@ -1210,29 +1210,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
/*
* Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
* cast away constness, and it is cleanest to do that here, all in one place.
*
* int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes,
* int length);
*/
#define TclRegisterNewLiteral(envPtr, bytes, length) \
TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)
/*
* Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it
* is safe to cast away constness, and it is cleanest to do that here, all in
* one place.
*
* int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
* int length);
*/
#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
#define LITERAL_UNSHARED 0x04
/*
* Macro used to manually adjust the stack requirements; used in cases where
@@ -1549,9 +1527,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
*/
#define PushLiteral(envPtr, string, length) \
TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr))
#define PushStringLiteral(envPtr, string) \
PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
PushLiteral(envPtr, string, (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
+4 -4
View File
@@ -232,7 +232,7 @@ QueryConfigObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
Tcl_GetString(pkgName), NULL);
TclGetString(pkgName), NULL);
return TCL_ERROR;
}
@@ -247,7 +247,7 @@ QueryConfigObjCmd(
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
Tcl_GetString(objv[2]), NULL);
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -333,9 +333,9 @@ QueryConfigDelete(
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
ckfree((char *)cdPtr->encoding);
ckfree(cdPtr->encoding);
}
ckfree((char *)cdPtr);
ckfree(cdPtr);
}
/*
+73
View File
@@ -1816,6 +1816,46 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
/* 631 */
EXTERN int Tcl_ArraySet(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *dictPtr, int flags);
/* 632 */
EXTERN int Tcl_ArrayUnset(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags);
/* 633 */
EXTERN int Tcl_ArrayGet(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *dictPtr,
int flags);
/* 634 */
EXTERN int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *listPtr,
int flags);
/* 635 */
EXTERN int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int *intPtr, int flags);
/* 636 */
EXTERN int Tcl_ArrayExists(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
int *intPtr, int flags);
/* 637 */
EXTERN Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
int flags);
/* 638 */
EXTERN int Tcl_ArraySearchPeek(Tcl_Interp *interp,
Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr,
Tcl_Obj **valuePtrPtr);
/* 639 */
EXTERN int Tcl_ArraySearchNext(Tcl_Interp *interp,
Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr,
Tcl_Obj **valuePtrPtr);
/* 640 */
EXTERN int Tcl_ArraySearchDone(Tcl_Interp *interp,
Tcl_ArraySearch search);
/* 641 */
EXTERN int Tcl_ArrayStatistics(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *stringPtr,
int flags);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2482,6 +2522,17 @@ typedef struct TclStubs {
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
int (*tcl_ArraySet) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *dictPtr, int flags); /* 631 */
int (*tcl_ArrayUnset) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 632 */
int (*tcl_ArrayGet) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *dictPtr, int flags); /* 633 */
int (*tcl_ArrayNames) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *listPtr, int flags); /* 634 */
int (*tcl_ArraySize) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int *intPtr, int flags); /* 635 */
int (*tcl_ArrayExists) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int *intPtr, int flags); /* 636 */
Tcl_ArraySearch (*tcl_ArraySearchStart) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 637 */
int (*tcl_ArraySearchPeek) (Tcl_Interp *interp, Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); /* 638 */
int (*tcl_ArraySearchNext) (Tcl_Interp *interp, Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); /* 639 */
int (*tcl_ArraySearchDone) (Tcl_Interp *interp, Tcl_ArraySearch search); /* 640 */
int (*tcl_ArrayStatistics) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *stringPtr, int flags); /* 641 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3774,6 +3825,28 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#define Tcl_ZlibStreamSetCompressionDictionary \
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
#define Tcl_ArraySet \
(tclStubsPtr->tcl_ArraySet) /* 631 */
#define Tcl_ArrayUnset \
(tclStubsPtr->tcl_ArrayUnset) /* 632 */
#define Tcl_ArrayGet \
(tclStubsPtr->tcl_ArrayGet) /* 633 */
#define Tcl_ArrayNames \
(tclStubsPtr->tcl_ArrayNames) /* 634 */
#define Tcl_ArraySize \
(tclStubsPtr->tcl_ArraySize) /* 635 */
#define Tcl_ArrayExists \
(tclStubsPtr->tcl_ArrayExists) /* 636 */
#define Tcl_ArraySearchStart \
(tclStubsPtr->tcl_ArraySearchStart) /* 637 */
#define Tcl_ArraySearchPeek \
(tclStubsPtr->tcl_ArraySearchPeek) /* 638 */
#define Tcl_ArraySearchNext \
(tclStubsPtr->tcl_ArraySearchNext) /* 639 */
#define Tcl_ArraySearchDone \
(tclStubsPtr->tcl_ArraySearchDone) /* 640 */
#define Tcl_ArrayStatistics \
(tclStubsPtr->tcl_ArrayStatistics) /* 641 */
#endif /* defined(USE_TCL_STUBS) */
+51 -32
View File
@@ -70,18 +70,12 @@ static inline void DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
Tcl_Obj *keyPtr, int *newPtr);
static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
static int FinalizeDictUpdate(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeDictWith(ClientData data[],
Tcl_Interp *interp, int result);
static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictForLoopCallback(ClientData data[],
Tcl_Interp *interp, int result);
static int DictMapLoopCallback(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
@@ -148,7 +142,7 @@ typedef struct Dict {
* the entries in the order that they are
* created. */
int epoch; /* Epoch counter */
int refcount; /* Reference counter (see above) */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
@@ -398,7 +392,7 @@ DupDictInternalRep(
newDict->epoch = 0;
newDict->chain = NULL;
newDict->refcount = 1;
newDict->refCount = 1;
/*
* Store in the object.
@@ -433,8 +427,7 @@ FreeDictInternalRep(
{
Dict *dict = DICT(dictPtr);
dict->refcount--;
if (dict->refcount <= 0) {
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
dictPtr->typePtr = NULL;
@@ -719,7 +712,7 @@ SetDictFromAny(
TclFreeIntRep(objPtr);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
dict->refCount = 1;
DICT(objPtr) = dict;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
@@ -1123,7 +1116,7 @@ Tcl_DictObjFirst(
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
dict->refcount++;
dict->refCount++;
if (keyPtrPtr != NULL) {
*keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
@@ -1237,8 +1230,7 @@ Tcl_DictObjDone(
if (searchPtr->epoch != -1) {
searchPtr->epoch = -1;
dict = (Dict *) searchPtr->dictionaryPtr;
dict->refcount--;
if (dict->refcount <= 0) {
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
@@ -1390,7 +1382,7 @@ Tcl_NewDictObj(void)
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -1440,7 +1432,7 @@ Tcl_DbNewDictObj(
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -2288,7 +2280,7 @@ DictAppendCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0;
int allocatedDict = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
@@ -2311,17 +2303,44 @@ DictAppendCmd(
return TCL_ERROR;
}
if (valuePtr == NULL) {
TclNewObj(valuePtr);
} else if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
if ((objc > 3) || (valuePtr == NULL)) {
/* Only go through append activites when something will change. */
Tcl_Obj *appendObjPtr = NULL;
if (objc > 3) {
/* Something to append */
if (objc == 4) {
appendObjPtr = objv[3];
} else if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
objc-3, objv+3, &appendObjPtr)) {
return TCL_ERROR;
}
}
if (appendObjPtr == NULL) {
/* => (objc == 3) => (valuePtr == NULL) */
TclNewObj(valuePtr);
} else if (valuePtr == NULL) {
valuePtr = appendObjPtr;
appendObjPtr = NULL;
}
if (appendObjPtr) {
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
}
Tcl_AppendObjToObj(valuePtr, appendObjPtr);
}
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
for (i=3 ; i<objc ; i++) {
Tcl_AppendObjToObj(valuePtr, objv[i]);
}
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
/*
* Even if nothing changed, we still overwrite so that variable
* trace expectations are met.
*/
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+136 -3
View File
@@ -6,7 +6,7 @@
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2013 Donal K. Fellows.
* Copyright (c) 2013-2016 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -193,7 +193,7 @@ TclPrintObject(
char *bytes;
int length;
bytes = Tcl_GetStringFromObj(objPtr, &length);
bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
@@ -650,7 +650,7 @@ FormatInstruction(
int length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
@@ -1279,9 +1279,11 @@ Tcl_DisassembleObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const types[] = {
"constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
};
enum Types {
DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR,
DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
DISAS_SCRIPT
};
@@ -1290,6 +1292,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
Method *methodPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "type ...");
@@ -1384,6 +1387,136 @@ Tcl_DisassembleObjCmd(
codeObjPtr = objv[2];
break;
case DISAS_CLASS_CONSTRUCTOR:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "className");
return TCL_ERROR;
}
/*
* Look up the body of a constructor.
*/
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
methodPtr = oPtr->classPtr->constructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined constructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"CONSRUCTOR", NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
Command cmd;
/*
* Yes, this is ugly, but we need to pass the namespace in to the
* compiler in two places.
*/
cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
procPtr->cmdPtr = &cmd;
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
(Namespace *) oPtr->namespacePtr, "body of constructor",
TclGetString(objv[2]));
procPtr->cmdPtr = NULL;
if (result != TCL_OK) {
return result;
}
}
codeObjPtr = procPtr->bodyPtr;
break;
case DISAS_CLASS_DESTRUCTOR:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "className");
return TCL_ERROR;
}
/*
* Look up the body of a destructor.
*/
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
methodPtr = oPtr->classPtr->destructorPtr;
if (methodPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" has no defined destructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"DESRUCTOR", NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of destructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
/*
* Compile if necessary.
*/
if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
Command cmd;
/*
* Yes, this is ugly, but we need to pass the namespace in to the
* compiler in two places.
*/
cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
procPtr->cmdPtr = &cmd;
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
(Namespace *) oPtr->namespacePtr, "body of destructor",
TclGetString(objv[2]));
procPtr->cmdPtr = NULL;
if (result != TCL_OK) {
return result;
}
}
codeObjPtr = procPtr->bodyPtr;
break;
case DISAS_CLASS_METHOD:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
+15 -18
View File
@@ -46,7 +46,7 @@ typedef struct Encoding {
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
* terminated string. */
int refCount; /* Number of uses of this structure. */
size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -305,7 +305,7 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
const char *name = Tcl_GetString(objPtr);
const char *name = TclGetString(objPtr);
if (objPtr->typePtr != &encodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
@@ -705,7 +705,7 @@ Tcl_GetDefaultEncodingDir(void)
}
Tcl_ListObjIndex(NULL, searchPath, 0, &first);
return Tcl_GetString(first);
return TclGetString(first);
}
/*
@@ -844,11 +844,7 @@ FreeEncoding(
if (encodingPtr == NULL) {
return;
}
if (encodingPtr->refCount<=0) {
Tcl_Panic("FreeEncoding: refcount problem !!!");
}
encodingPtr->refCount--;
if (encodingPtr->refCount == 0) {
if (encodingPtr->refCount-- <= 1) {
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
@@ -977,7 +973,7 @@ Tcl_GetEncodingNames(
* Side effects:
* The reference count of the new system encoding is incremented. The
* reference count of the old system encoding is decremented and it may
* be freed.
* be freed. All VFS cached information is invalidated.
*
*------------------------------------------------------------------------
*/
@@ -1008,6 +1004,7 @@ Tcl_SetSystemEncoding(
FreeEncoding(systemEncoding);
systemEncoding = encoding;
Tcl_MutexUnlock(&encodingMutex);
Tcl_FSMountsChanged(NULL);
return TCL_OK;
}
@@ -1518,10 +1515,10 @@ OpenEncodingFileChannel(
}
}
if (!verified) {
const char *dirString = Tcl_GetString(directory);
const char *dirString = TclGetString(directory);
for (i=0; i<numDirs && !verified; i++) {
if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) {
if (strcmp(dirString, TclGetString(dir[i])) == 0) {
verified = 1;
}
}
@@ -1762,7 +1759,7 @@ LoadTableEncoding(
const char *p;
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
p = Tcl_GetString(objPtr);
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
@@ -3599,11 +3596,11 @@ unilen(
static void
InitializeEncodingSearchPath(
char **valuePtr,
int *lengthPtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
int i, numDirs, numBytes;
int i, numDirs;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
@@ -3633,11 +3630,11 @@ InitializeEncodingSearchPath(
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
bytes = TclGetString(searchPathObj);
*lengthPtr = numBytes;
*valuePtr = ckalloc(numBytes + 1);
memcpy(*valuePtr, bytes, (size_t) numBytes + 1);
*lengthPtr = searchPathObj->length;
*valuePtr = ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
+254 -143
View File
@@ -30,11 +30,10 @@ static int NsEnsembleStringOrder(const void *strPtr1,
const void *strPtr2);
static void DeleteEnsembleConfig(ClientData clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
const char *subcmdName, Tcl_Obj *prefixObjPtr);
EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
Tcl_Obj *fix);
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
Command *cmdPtr, CompileEnv *envPtr);
@@ -42,6 +41,8 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr);
static Tcl_NRPostProc FreeER;
/*
* The lists of subcommands and options for the [namespace ensemble] command.
*/
@@ -77,14 +78,30 @@ enum EnsConfigOpts {
* that implements it.
*/
const Tcl_ObjType tclEnsembleCmdType = {
static const Tcl_ObjType ensembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
StringOfEnsembleCmdRep, /* updateStringProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* The internal rep for caching ensemble subcommand lookups and
* spell corrections.
*/
typedef struct {
int epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
* hash table. */
} EnsembleCmdRep;
static inline Tcl_Obj *
NewNsObj(
@@ -1588,7 +1605,7 @@ TclMakeEnsemble(
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
ckfree((char *) nameParts);
ckfree(nameParts);
}
return ensemble;
}
@@ -1643,6 +1660,8 @@ NsEnsembleImplementationCmdNR(
* names. */
int reparseCount = 0; /* Number of reparses. */
Tcl_Obj *errorObj; /* Used for building error messages. */
Tcl_Obj *subObj;
int subIdx;
/*
* Must recheck objc, since numParameters might have changed. Cf. test
@@ -1650,24 +1669,18 @@ NsEnsembleImplementationCmdNR(
*/
restartEnsembleParse:
if (objc < 2 + ensemblePtr->numParameters) {
subIdx = 1 + ensemblePtr->numParameters;
if (objc < subIdx + 1) {
/*
* We don't have a subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
Tcl_Obj **elemPtrs; /* Parameter names */
int len; /* Number of parameters to append */
Tcl_DStringInit(&buf);
if (ensemblePtr->parameterList == NULL) {
len = 0;
} else if (TclListObjGetElements(NULL, ensemblePtr->parameterList,
&len, &elemPtrs) != TCL_OK) {
Tcl_Panic("List of ensemble parameters is not a list");
}
for (; len>0; len--,elemPtrs++) {
TclDStringAppendObj(&buf, *elemPtrs);
if (ensemblePtr->parameterList) {
Tcl_DStringAppend(&buf,
TclGetString(ensemblePtr->parameterList), -1);
TclDStringAppendLiteral(&buf, " ");
}
TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
@@ -1695,6 +1708,8 @@ NsEnsembleImplementationCmdNR(
* up in there and go straight to dispatch.
*/
subObj = objv[subIdx];
if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
/*
* Table of subcommands is still valid; therefore there might be a
@@ -1703,15 +1718,16 @@ NsEnsembleImplementationCmdNR(
* part where we do the invocation of the subcommand.
*/
if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
->internalRep.twoPtrValue.ptr1;
if (subObj->typePtr==&ensembleCmdType){
EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == ensemblePtr->token) {
prefixObj = ensembleCmd->realPrefixObj;
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
}
goto runResultingSubcommand;
}
}
@@ -1726,18 +1742,14 @@ NsEnsembleImplementationCmdNR(
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
TclGetString(objv[1 + ensemblePtr->numParameters]));
TclGetString(subObj));
if (hPtr != NULL) {
char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
prefixObj = Tcl_GetHashValue(hPtr);
/*
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
ensemblePtr, fullName, prefixObj);
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
* Could not map, no prefixing, go to unknown/error handling.
@@ -1757,9 +1769,9 @@ NsEnsembleImplementationCmdNR(
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]);
stringLength = objv[1 + ensemblePtr->numParameters]->length;
subcmdName = TclGetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
register int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
@@ -1799,16 +1811,22 @@ NsEnsembleImplementationCmdNR(
Tcl_Panic("full name %s not found in supposedly synchronized hash",
fullName);
}
prefixObj = Tcl_GetHashValue(hPtr);
/*
* Record the spelling correction for usage message.
*/
fix = Tcl_NewStringObj(fullName, -1);
/*
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
ensemblePtr, fullName, prefixObj);
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
prefixObj = Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
@@ -1827,46 +1845,26 @@ NsEnsembleImplementationCmdNR(
*/
{
Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
* target command prefix. */
Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
* Will be freed by the dispatch engine. */
int prefixObjc, copyObjc;
Tcl_Obj **copyObjv;
int copyObjc, prefixObjc;
/*
* Get the prefix that we're rewriting to. To do this we need to
* ensure that the internal representation of the list does not change
* so that we can safely keep the internal representations of the
* elements in the list.
*
* TODO: Use conventional list operations to make this code sane!
*/
Tcl_ListObjLength(NULL, prefixObj, &prefixObjc);
TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
copyObjc = objc - 2 + prefixObjc;
copyPtr = Tcl_NewListObj(copyObjc, NULL);
if (copyObjc > 0) {
register Tcl_Obj **copyObjv;
/* Space used to construct the list of
* arguments to pass to the command that
* implements the ensemble subcommand. */
register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
register int i;
listRepPtr->elemCount = copyObjc;
copyObjv = &listRepPtr->elements;
memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
memcpy(copyObjv+prefixObjc, objv+1,
sizeof(Tcl_Obj *) * ensemblePtr->numParameters);
memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters,
objv+ensemblePtr->numParameters+2,
sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2));
for (i=0; i < copyObjc; i++) {
Tcl_IncrRefCount(copyObjv[i]);
}
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
ensemblePtr->numParameters, objv + 1);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - 2 - ensemblePtr->numParameters,
objv + 2 + ensemblePtr->numParameters);
}
Tcl_IncrRefCount(copyPtr);
TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL);
TclDecrRefCount(prefixObj);
/*
@@ -1886,7 +1884,8 @@ NsEnsembleImplementationCmdNR(
*/
TclSkipTailcall(interp);
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
Tcl_ListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
@@ -1918,20 +1917,17 @@ NsEnsembleImplementationCmdNR(
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
TclGetString(subObj), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown subcommand \"%s\": namespace %s does not"
" export any commands",
TclGetString(objv[1+ensemblePtr->numParameters]),
" export any commands", TclGetString(subObj),
ensemblePtr->nsPtr->fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
return TCL_ERROR;
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
TclGetString(objv[1+ensemblePtr->numParameters]));
TclGetString(subObj));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
@@ -2037,6 +2033,149 @@ TclResetRewriteEnsemble(
}
}
/*
*----------------------------------------------------------------------
*
* TclSpellFix --
*
* Record a spelling correction that needs making in the
* generation of the WrongNumArgs usage message.
*
* Results:
* None.
*
* Side effects:
* Can create an alternative ensemble rewrite structure.
*
*----------------------------------------------------------------------
*/
static int
FreeER(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **)data[0];
ckfree(tmp[2]);
ckfree(tmp);
return result;
}
void
TclSpellFix(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
int objc,
int badIdx,
Tcl_Obj *bad,
Tcl_Obj *fix)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *const *search;
Tcl_Obj **store;
int idx;
int size;
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = 0;
iPtr->ensembleRewrite.numInsertedObjs = 0;
}
/* Compute the valid length of the ensemble root */
size = iPtr->ensembleRewrite.numRemovedObjs + objc
- iPtr->ensembleRewrite.numInsertedObjs;
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
/* Awful casting abuse here */
search = (Tcl_Obj *const *) search[1];
}
if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
/*
* Misspelled value was inserted. We cannot directly jump
* to the bad value, but have to search.
*/
idx = 1;
while (idx < size) {
if (search[idx] == bad) {
break;
}
idx++;
}
if (idx == size) {
return;
}
} else {
/* Jump to the misspelled value. */
idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
- iPtr->ensembleRewrite.numInsertedObjs;
/* Verify */
if (search[idx] != bad) {
Tcl_Panic("SpellFix: programming error");
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **)search[2];
} else {
Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
tmp[0] = NULL;
tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs;
tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *));
memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *));
iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL);
store = (Tcl_Obj **)tmp[2];
}
store[idx] = fix;
Tcl_IncrRefCount(fix);
TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* TclFetchEnsembleRoot --
*
* Returns the root of ensemble rewriting, if any.
* If no root exists, returns objv instead.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *const *
TclFetchEnsembleRoot(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
int objc,
int *objcPtr)
{
Interp *iPtr = (Interp *) interp;
if (iPtr->ensembleRewrite.sourceObjs) {
*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
return iPtr->ensembleRewrite.sourceObjs;
}
*objcPtr = objc;
return objv;
}
/*
* ----------------------------------------------------------------------
*
@@ -2202,17 +2341,17 @@ static void
MakeCachedEnsembleCommand(
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
const char *subcommandName,
Tcl_Obj *prefixObjPtr)
Tcl_HashEntry *hPtr,
Tcl_Obj *fix)
{
register EnsembleCmdRep *ensembleCmd;
int length;
if (objPtr->typePtr == &tclEnsembleCmdType) {
if (objPtr->typePtr == &ensembleCmdType) {
ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
TclNsDecrRefCount(ensembleCmd->nsPtr);
ckfree(ensembleCmd->fullSubcmdName);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
/*
* Kill the old internal rep, and replace it with a brand new one of
@@ -2222,22 +2361,21 @@ MakeCachedEnsembleCommand(
TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
objPtr->typePtr = &tclEnsembleCmdType;
objPtr->typePtr = &ensembleCmdType;
}
/*
* Populate the internal rep.
*/
ensembleCmd->nsPtr = ensemblePtr->nsPtr;
ensembleCmd->epoch = ensemblePtr->epoch;
ensembleCmd->token = ensemblePtr->token;
ensemblePtr->nsPtr->refCount++;
ensembleCmd->realPrefixObj = prefixObjPtr;
length = strlen(subcommandName)+1;
ensembleCmd->fullSubcmdName = ckalloc(length);
memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
ensembleCmd->token = (Command *) ensemblePtr->token;
ensembleCmd->token->refCount++;
if (fix) {
Tcl_IncrRefCount(fix);
}
ensembleCmd->fix = fix;
ensembleCmd->hPtr = hPtr;
}
/*
@@ -2618,9 +2756,10 @@ FreeEnsembleCmdRep(
{
EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ckfree(ensembleCmd->fullSubcmdName);
TclNsDecrRefCount(ensembleCmd->nsPtr);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
objPtr->typePtr = NULL;
}
@@ -2650,48 +2789,17 @@ DupEnsembleCmdRep(
{
EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
int length = strlen(ensembleCmd->fullSubcmdName);
copyPtr->typePtr = &tclEnsembleCmdType;
copyPtr->typePtr = &ensembleCmdType;
copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->nsPtr->refCount++;
ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
ensembleCopy->fullSubcmdName = ckalloc(length + 1);
memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
(unsigned) length+1);
}
/*
*----------------------------------------------------------------------
*
* StringOfEnsembleCmdRep --
*
* Creates a string representation of a Tcl_Obj that holds a subcommand
* of an ensemble.
*
* Results:
* None.
*
* Side effects:
* The object gains a string (UTF-8) representation.
*
*----------------------------------------------------------------------
*/
static void
StringOfEnsembleCmdRep(
Tcl_Obj *objPtr)
{
EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
int length = strlen(ensembleCmd->fullSubcmdName);
objPtr->length = length;
objPtr->bytes = ckalloc(length + 1);
memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
ensembleCopy->token->refCount++;
ensembleCopy->fix = ensembleCmd->fix;
if (ensembleCopy->fix) {
Tcl_IncrRefCount(ensembleCopy->fix);
}
ensembleCopy->hPtr = ensembleCmd->hPtr;
}
/*
@@ -2809,7 +2917,7 @@ TclCompileEnsemble(
goto failed;
}
for (i=0 ; i<len ; i++) {
str = Tcl_GetStringFromObj(elems[i], &sclen);
str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
@@ -3027,7 +3135,7 @@ TclCompileEnsemble(
* any extra elements that might have been appended by failing
* pathways above.
*/
(void) Tcl_ListObjReplace(NULL, replaced, depth-1, INT_MAX, 0, NULL);
(void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL);
/*
* TODO: Reconsider whether we ought to call CompileToInvokedCommand()
@@ -3198,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
int length, i, numWords, cmdLit;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
@@ -3211,15 +3319,15 @@ CompileToInvokedCommand(
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
bytes = TclGetString(words[i-1]);
PushLiteral(envPtr, bytes, words[i-1]->length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterNewLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size);
int literal = TclRegisterLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
@@ -3240,8 +3348,11 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
bytes = TclGetString(objPtr);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
+110 -330
View File
@@ -19,7 +19,6 @@
#include "tclCompile.h"
#include "tclOOInt.h"
#include "tommath.h"
#include "tclStringRep.h"
#include <math.h>
#include <assert.h>
@@ -326,7 +325,7 @@ VarHashCreateVar(
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -347,7 +346,7 @@ VarHashCreateVar(
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -358,7 +357,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -367,7 +366,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -1275,7 +1274,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
ckfree((char *) freePtr);
ckfree(freePtr);
return;
}
@@ -1542,11 +1541,10 @@ CompileExprObj(
* TIP #280: No invoker (yet) - Expression compilation.
*/
int length;
const char *string = TclGetStringFromObj(objPtr, &length);
const char *string = TclGetString(objPtr);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv, 0);
TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -1554,7 +1552,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -2071,11 +2069,16 @@ TclNRExecuteByteCode(
#endif
/*
* Push the callback for bytecode execution
* Test namespace-50.9 demonstrates the need for this call.
* Use a --enable-symbols=mem bug to see.
*/
TclResetRewriteEnsemble(interp, 1);
/*
* Push the callback for bytecode execution
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
/* cleanup */ INT2PTR(0), NULL);
return TCL_OK;
@@ -2533,7 +2536,7 @@ TEBCresume(
/* FIXME: What is the right thing to trace? */
fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
Tcl_GetString(valuePtr));
TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2680,154 +2683,18 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
}
case INST_STR_CONCAT1: {
int appendLen = 0;
char *bytes, *p;
Tcl_Obj **currPtr;
int onlyb = 1;
case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
/*
* Detect only-bytearray-or-null case.
*/
for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
if (((*currPtr)->typePtr != &tclByteArrayType)
&& ((*currPtr)->bytes != tclEmptyStringRep)) {
onlyb = 0;
break;
} else if (((*currPtr)->typePtr == &tclByteArrayType) &&
((*currPtr)->bytes != NULL)) {
onlyb = 0;
break;
}
}
/*
* Compute the length to be appended.
*/
if (onlyb) {
for (currPtr = &OBJ_AT_DEPTH(opnd-2);
appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
if ((*currPtr)->bytes != tclEmptyStringRep) {
Tcl_GetByteArrayFromObj(*currPtr, &length);
appendLen += length;
}
}
} else {
for (currPtr = &OBJ_AT_DEPTH(opnd-2);
appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
bytes = TclGetStringFromObj(*currPtr, &length);
if (bytes != NULL) {
appendLen += length;
}
}
}
if (appendLen < 0) {
/* TODO: convert panic to error ? */
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
/*
* If nothing is to be appended, just return the first object by
* dropping all the others from the stack; this saves both the
* computation and copy of the string rep of the first object,
* enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
*/
if (appendLen == 0) {
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, (opnd-1), 0);
}
/*
* If the first object is shared, we need a new obj for the result;
* otherwise, we can reuse the first object. In any case, make sure it
* has enough room to accomodate all the concatenated bytes. Note that
* if it is unshared its bytes are copied by ckrealloc, so that we set
* the loop parameters to avoid copying them again: p points to the
* end of the already copied bytes, currPtr to the second object.
*/
objResultPtr = OBJ_AT_DEPTH(opnd-1);
if (!onlyb) {
bytes = TclGetStringFromObj(objResultPtr, &length);
if (length + appendLen < 0) {
/* TODO: convert panic to error ? */
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
#ifndef TCL_COMPILE_DEBUG
if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
TclFreeIntRep(objResultPtr);
objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
objResultPtr->length = length + appendLen;
p = TclGetString(objResultPtr) + length;
currPtr = &OBJ_AT_DEPTH(opnd - 2);
} else
#endif
{
p = ckalloc(length + appendLen + 1);
TclNewObj(objResultPtr);
objResultPtr->bytes = p;
objResultPtr->length = length + appendLen;
currPtr = &OBJ_AT_DEPTH(opnd - 1);
}
/*
* Append the remaining characters.
*/
for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
bytes = TclGetStringFromObj(*currPtr, &length);
if (bytes != NULL) {
memcpy(p, bytes, (size_t) length);
p += length;
}
}
*p = '\0';
} else {
bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
if (length + appendLen < 0) {
/* TODO: convert panic to error ? */
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
#ifndef TCL_COMPILE_DEBUG
if (!Tcl_IsShared(objResultPtr)) {
bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
length + appendLen);
p = bytes + length;
currPtr = &OBJ_AT_DEPTH(opnd - 2);
} else
#endif
{
TclNewObj(objResultPtr);
bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
length + appendLen);
p = bytes;
currPtr = &OBJ_AT_DEPTH(opnd - 1);
}
/*
* Append the remaining characters.
*/
for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
if ((*currPtr)->bytes != tclEmptyStringRep) {
bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
memcpy(p, bytes, (size_t) length);
p += length;
}
}
if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
case INST_CONCAT_STK:
/*
@@ -3155,20 +3022,7 @@ TEBCresume(
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
{
Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
Tcl_Obj **copyObjv = &listRepPtr->elements;
int i;
listRepPtr->elemCount = objc - opnd + 1;
copyObjv[0] = objPtr;
memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd));
for (i=1 ; i<objc-opnd+1 ; i++) {
Tcl_IncrRefCount(copyObjv[i]);
}
objPtr = copyPtr;
}
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
@@ -3176,13 +3030,26 @@ TEBCresume(
}
TclInitRewriteEnsemble(interp, opnd, 1, objv);
{
Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
Tcl_ListObjAppendElement(NULL, copyPtr, objPtr);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - opnd, objv + opnd);
Tcl_DecrRefCount(objPtr);
objPtr = copyPtr;
}
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
/*
* -----------------------------------------------------------------
@@ -4167,12 +4034,13 @@ TEBCresume(
}
TRACE(("%s %u \"%.30s\" => ",
(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)
&& !TclIsVarArraySearched(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
/*
* No nasty traces and element exists, so we can proceed to
* unset it. Might still not exist though...
* No nasty traces or searchesw and element exists, so we can
* proceed to unset it. Might still not exist though...
*/
if (!TclIsVarUndefined(varPtr)) {
@@ -4415,8 +4283,8 @@ TEBCresume(
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
"access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr->nsPtr = savedNsPtr;
if (!otherPtr) {
TRACE_ERROR(interp);
@@ -4661,7 +4529,7 @@ TEBCresume(
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TclNewLongObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
@@ -5030,7 +4898,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
TclNewIntObj(objResultPtr, length);
TclNewLongObj(objResultPtr, length);
TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
@@ -5278,23 +5146,10 @@ TEBCresume(
toIdx = objc-1;
}
if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) {
/*
* BEWARE! This is looking inside the implementation of the
* list type.
*/
List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1;
if (listPtr->refCount == 1) {
for (index=toIdx+1; index<objc ; index++) {
TclDecrRefCount(objv[index]);
}
listPtr->elemCount = toIdx+1;
listPtr->canonicalFlag = 1;
TclInvalidateStringRep(valuePtr);
TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
NEXT_INST_F(9, 0, 0);
}
Tcl_ListObjReplace(interp, valuePtr,
toIdx + 1, LIST_MAX, 0, NULL);
TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
NEXT_INST_F(9, 0, 0);
}
objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
} else {
@@ -5514,7 +5369,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
TclNewLongObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5719,17 +5574,6 @@ TEBCresume(
length3 = Tcl_GetCharLength(value3Ptr);
/*
* Remove substring. In-place.
*/
if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) {
TclDecrRefCount(value3Ptr);
Tcl_SetObjLength(valuePtr, fromIdx);
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
/*
* See if we can splice in place. This happens when the number of
* characters being replaced is the same as the number of characters
@@ -5739,51 +5583,29 @@ TEBCresume(
if (length3 - 1 == toIdx - fromIdx) {
unsigned char *bytes1, *bytes2;
/*
* Flush the info in the string internal rep that refers to the
* about-to-be-invalidated UTF-8 rep. This indicates that a new
* buffer needs to be allocated, and assumes that the value is
* already of tclStringTypePtr type, which should be true provided
* we call it after Tcl_GetUnicodeFromObj.
*/
#define MarkStringInternalRepForFlush(objPtr) \
(GET_STRING(objPtr)->allocated = 0)
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_DuplicateObj(valuePtr);
if (TclIsPureByteArray(objResultPtr)
&& TclIsPureByteArray(value3Ptr)) {
bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
memcpy(bytes1 + fromIdx, bytes2, length3);
} else {
ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
memcpy(ustring1 + fromIdx, ustring2,
length3 * sizeof(Tcl_UniChar));
MarkStringInternalRepForFlush(objResultPtr);
}
Tcl_InvalidateStringRep(objResultPtr);
TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
if (TclIsPureByteArray(valuePtr)
&& TclIsPureByteArray(value3Ptr)) {
bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL);
bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
memcpy(bytes1 + fromIdx, bytes2, length3);
} else {
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL);
ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
memcpy(ustring1 + fromIdx, ustring2,
length3 * sizeof(Tcl_UniChar));
MarkStringInternalRepForFlush(valuePtr);
}
Tcl_InvalidateStringRep(valuePtr);
TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
objResultPtr = valuePtr;
}
if (TclIsPureByteArray(objResultPtr)
&& TclIsPureByteArray(value3Ptr)) {
bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
memcpy(bytes1 + fromIdx, bytes2, length3);
} else {
ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
memcpy(ustring1 + fromIdx, ustring2,
length3 * sizeof(Tcl_UniChar));
}
Tcl_InvalidateStringRep(objResultPtr);
TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
if (objResultPtr == valuePtr) {
NEXT_INST_F(1, 0, 0);
} else {
NEXT_INST_F(1, 1, 1);
}
}
@@ -5799,54 +5621,38 @@ TEBCresume(
* Remove substring using copying.
*/
if (length3 == 0) {
if (fromIdx > 0) {
objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
if (toIdx < length) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
}
objResultPtr = NULL;
if (fromIdx > 0) {
objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
}
if (length3 > 0) {
if (objResultPtr) {
Tcl_AppendObjToObj(objResultPtr, value3Ptr);
} else if (Tcl_IsShared(value3Ptr)) {
objResultPtr = Tcl_DuplicateObj(value3Ptr);
} else {
objResultPtr = value3Ptr;
}
}
if (toIdx < length) {
if (objResultPtr) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
} else {
objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
length - toIdx);
}
TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
/*
* Splice string pieces by full copying.
*/
if (fromIdx > 0) {
objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
Tcl_AppendObjToObj(objResultPtr, value3Ptr);
if (toIdx < length) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
}
} else if (Tcl_IsShared(value3Ptr)) {
objResultPtr = Tcl_DuplicateObj(value3Ptr);
if (toIdx < length) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
}
} else {
/*
* Be careful with splicing the stack in this case; we have a
* refCount:1 object in value3Ptr and we want to append to it and
* make it be the refCount:1 object at the top of the stack
* afterwards. [Bug 82e7f67325]
*/
if (toIdx < length) {
Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1,
length - toIdx);
}
if (objResultPtr == NULL) {
/* This has to be the case [string replace $s 0 end {}] */
/* which has result {} which is same as value3Ptr. */
objResultPtr = value3Ptr;
}
if (objResultPtr == value3Ptr) {
/* See [Bug 82e7f67325] */
TclDecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = value3Ptr;
TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
TclDecrRefCount(valuePtr);
OBJ_AT_TOS = value3Ptr; /* Tricky! */
NEXT_INST_F(1, 0, 0);
}
TclDecrRefCount(value3Ptr);
@@ -5914,45 +5720,19 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
match = -1;
if (length2 > 0 && length2 <= length) {
end = ustring1 + length - length2 + 1;
for (p=ustring1 ; p<end ; p++) {
if ((*p == *ustring2) &&
memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
match = p - ustring1;
break;
}
}
}
match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
TclNewIntObj(objResultPtr, match);
TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
match = -1;
if (length2 > 0 && length2 <= length) {
for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
if ((*p == *ustring2) &&
memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
match = p - ustring1;
break;
}
}
}
match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
TclNewIntObj(objResultPtr, match);
TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -6156,7 +5936,7 @@ TEBCresume(
type1 = TCL_NUMBER_WIDE;
}
}
TclNewIntObj(objResultPtr, type1);
TclNewLongObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
@@ -6363,7 +6143,7 @@ TEBCresume(
if (l1 > 0L) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
TclNewLongObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -7263,7 +7043,7 @@ TEBCresume(
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
TclNewIntObj(objResultPtr, result);
TclNewLongObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
@@ -9155,7 +8935,7 @@ ExecuteExtendedBinaryMathOp(
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
mp_init(&bigResult);
mp_expt_d(&big1, big2.dp[0], &bigResult);
mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1);
mp_clear(&big1);
mp_clear(&big2);
BIG_RESULT(&bigResult);
@@ -9679,9 +9459,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n",
codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr,
(Tcl_WideInt)iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
@@ -9778,7 +9558,7 @@ ValidatePcAndStackTop(
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
fprintf(stderr,"%s\n", Tcl_GetString(message));
fprintf(stderr,"%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
@@ -9828,7 +9608,7 @@ IllegalExprOperandType(
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
int numBytes;
const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
@@ -10241,7 +10021,7 @@ TclExprFloatError(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
Tcl_GetString(objPtr), NULL);
TclGetString(objPtr), NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
@@ -10457,7 +10237,7 @@ EvalStatsCmd(
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
(void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
@@ -10679,7 +10459,7 @@ EvalStatsCmd(
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
char *str = Tcl_GetStringFromObj(objv[1], &length);
char *str = TclGetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {
+2 -8
View File
@@ -1079,12 +1079,9 @@ TclFileAttrsCmd(
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", 0, &index) != TCL_OK) {
"option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (attributeStringsAllocated != NULL) {
TclFreeIntRep(objv[0]);
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
@@ -1107,12 +1104,9 @@ TclFileAttrsCmd(
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
"option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (attributeStringsAllocated != NULL) {
TclFreeIntRep(objv[i]);
}
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
+16 -16
View File
@@ -387,7 +387,7 @@ TclpGetNativePathType(
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -578,7 +578,7 @@ Tcl_SplitPath(
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
Tcl_GetStringFromObj(eltPtr, &len);
TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
@@ -597,7 +597,7 @@ Tcl_SplitPath(
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
str = Tcl_GetStringFromObj(eltPtr, &len);
str = TclGetStringFromObj(eltPtr, &len);
memcpy(p, str, (size_t) len+1);
p += len+1;
}
@@ -857,7 +857,7 @@ TclpNativeJoinPath(
const char *p;
const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
start = TclGetStringFromObj(prefix, &length);
/*
* Remove the ./ from tilde prefixed elements, and drive-letter prefixed
@@ -885,7 +885,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
Tcl_GetStringFromObj(prefix, &length);
TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -921,7 +921,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
Tcl_GetStringFromObj(prefix, &length);
TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -1003,7 +1003,7 @@ Tcl_JoinPath(
* Store the result.
*/
resultStr = Tcl_GetStringFromObj(resultObj, &len);
resultStr = TclGetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
@@ -1249,7 +1249,7 @@ Tcl_GlobObjCmd(
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
string = Tcl_GetStringFromObj(objv[i], &length);
string = TclGetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal an
@@ -1357,7 +1357,7 @@ Tcl_GlobObjCmd(
if (dir == PATH_GENERAL) {
int pathlength;
const char *last;
const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
@@ -1460,7 +1460,7 @@ Tcl_GlobObjCmd(
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
@@ -1992,7 +1992,7 @@ TclGlob(
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
pre = TclGetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
@@ -2010,7 +2010,7 @@ TclGlob(
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
@@ -2362,7 +2362,7 @@ DoGlob(
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = Tcl_GetStringFromObj(fixme, &numBytes);
bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
@@ -2400,7 +2400,7 @@ DoGlob(
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
(void) Tcl_GetStringFromObj(pathPtr, &length);
(void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
@@ -2446,7 +2446,7 @@ DoGlob(
*/
int len;
const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
Tcl_AppendToObj(joinedPtr, "/", 1);
@@ -2483,7 +2483,7 @@ DoGlob(
*/
int len;
const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
+8 -8
View File
@@ -43,7 +43,7 @@
static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the one word hash key methods. Not actually declared because
@@ -65,7 +65,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr);
static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr,
void *keyPtr);
static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Function prototypes for static functions in this file:
@@ -774,7 +774,7 @@ CompareArrayKeys(
*----------------------------------------------------------------------
*/
static unsigned int
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -787,7 +787,7 @@ HashArrayKey(
count--, array++) {
result += *array;
}
return result;
return (TCL_HASH_TYPE) result;
}
/*
@@ -870,7 +870,7 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
static unsigned
static TCL_HASH_TYPE
HashStringKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -916,7 +916,7 @@ HashStringKey(
result += (result << 3) + UCHAR(c);
}
}
return result;
return (TCL_HASH_TYPE) result;
}
/*
@@ -924,7 +924,7 @@ HashStringKey(
*
* BogusFind --
*
* This function is invoked when an Tcl_FindHashEntry is called on a
* This function is invoked when Tcl_FindHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -951,7 +951,7 @@ BogusFind(
*
* BogusCreate --
*
* This function is invoked when an Tcl_CreateHashEntry is called on a
* This function is invoked when Tcl_CreateHashEntry is called on a
* table that has been deleted.
*
* Results:
+74 -87
View File
@@ -313,15 +313,20 @@ static int WillRead(Channel *chanPtr);
&& (strncmp(optionName, (nameString), len) == 0))
/*
* The ChannelObjType type. We actually store the ChannelState structure
* as that lives longest and we want to return the bottomChanPtr when
* requested (consistent with Tcl_GetChannel). The setFromAny and
* updateString can be NULL as they should not be called.
* The ChannelObjType type. Used to store the result of looking up
* a channel name in the context of an interp. Saves the lookup
* result and values needed to check its continued validity.
*/
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
int epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static int SetChannelFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void FreeChannelIntRep(Tcl_Obj *objPtr);
static const Tcl_ObjType chanObjType = {
@@ -329,18 +334,9 @@ static const Tcl_ObjType chanObjType = {
FreeChannelIntRep, /* freeIntRepProc */
DupChannelIntRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc SetChannelFromAny */
NULL /* setFromAnyProc */
};
#define GET_CHANNELSTATE(objPtr) \
((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_CHANNELSTATE(objPtr, storePtr) \
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
#define GET_CHANNELINTERP(objPtr) \
((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
#define SET_CHANNELINTERP(objPtr, storePtr) \
((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr))
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -1021,7 +1017,7 @@ DeleteChannelTable(
*/
Tcl_DeleteHashEntry(hPtr);
SetFlag(statePtr, CHANNEL_TAINTED);
statePtr->epoch++;
if (statePtr->refCount-- <= 1) {
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
@@ -1365,7 +1361,7 @@ DetachChannel(
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
SetFlag(statePtr, CHANNEL_TAINTED);
statePtr->epoch++;
/*
* Remove channel handlers that refer to this interpreter, so that
@@ -1498,12 +1494,57 @@ TclGetChannelFromObj(
int flags)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
if (SetChannelFromAny(interp, objPtr) != TCL_OK) {
if (interp == NULL) {
return TCL_ERROR;
}
statePtr = GET_CHANNELSTATE(objPtr);
if (objPtr->typePtr == &chanObjType) {
/*
* Confirm validity of saved lookup results.
*/
resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1;
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
&& (resPtr->epoch == statePtr->epoch)) {
/* Have a valid saved lookup. Jump to end to return it. */
goto valid;
}
}
chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
if (chan == NULL) {
if (resPtr) {
FreeChannelIntRep(objPtr);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
/* Re-use the ResolvedCmdName struct */
Tcl_Release((ClientData) resPtr->statePtr);
} else {
TclFreeIntRep(objPtr);
resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
resPtr->refCount = 1;
objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr;
objPtr->typePtr = &chanObjType;
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
Tcl_Preserve((ClientData) statePtr);
resPtr->interp = interp;
resPtr->epoch = statePtr->epoch;
valid:
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
@@ -1676,6 +1717,8 @@ Tcl_CreateChannel(
statePtr->chanMsg = NULL;
statePtr->unreportedMsg = NULL;
statePtr->epoch = 0;
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels in
@@ -7086,7 +7129,7 @@ Tcl_Tell(
*
* Tcl_SeekOld, Tcl_TellOld --
*
* Backward-compatability versions of the seek/tell interface that do not
* Backward-compatibility versions of the seek/tell interface that do not
* support 64-bit offsets. This interface is not documented or expected
* to be supported indefinitely.
*
@@ -11121,75 +11164,13 @@ DupChannelIntRep(
register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
ChannelState *statePtr = GET_CHANNELSTATE(srcPtr);
ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
SET_CHANNELSTATE(copyPtr, statePtr);
SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr));
Tcl_Preserve(statePtr);
resPtr->refCount++;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->typePtr = srcPtr->typePtr;
}
/*
*----------------------------------------------------------------------
*
* SetChannelFromAny --
*
* Create an internal representation of type "Channel" for an object.
*
* Results:
* This operation always succeeds and returns TCL_OK.
*
* Side effects:
* Any old internal reputation for objPtr is freed and the internal
* representation is set to "Channel".
*
*----------------------------------------------------------------------
*/
static int
SetChannelFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
ChannelState *statePtr;
if (interp == NULL) {
return TCL_ERROR;
}
if (objPtr->typePtr == &chanObjType) {
/*
* TODO: TAINT Flag and dup'd channel values?
* The channel is valid until any call to DetachChannel occurs.
* Ensure consistency checks are done.
*/
statePtr = GET_CHANNELSTATE(objPtr);
if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
ResetFlag(statePtr, CHANNEL_TAINTED);
Tcl_Release(statePtr);
objPtr->typePtr = NULL;
} else if (interp != GET_CHANNELINTERP(objPtr)) {
Tcl_Release(statePtr);
objPtr->typePtr = NULL;
}
}
if (objPtr->typePtr != &chanObjType) {
Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
TclFreeIntRep(objPtr);
statePtr = ((Channel *) chan)->state;
Tcl_Preserve(statePtr);
SET_CHANNELSTATE(objPtr, statePtr);
SET_CHANNELINTERP(objPtr, interp);
objPtr->typePtr = &chanObjType;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -11210,8 +11191,14 @@ static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
Tcl_Release(GET_CHANNELSTATE(objPtr));
ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
ckfree(resPtr);
}
#if 0
+2 -4
View File
@@ -214,6 +214,8 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
int epoch; /* Used to test validity of stored channelname
* lookup results. */
} ChannelState;
/*
@@ -275,10 +277,6 @@ typedef struct ChannelState {
* usable, but it may not be closed
* again from within the close
* handler. */
#define CHANNEL_TAINTED (1<<20) /* Channel stack structure has changed.
* Used by Channel Tcl_Obj type to
* determine if we have to revalidate
* the channel. */
#define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed.
* No further Tcl-level write IO on
* the channel is allowed. */
+2 -2
View File
@@ -211,7 +211,7 @@ struct TransformChannelData {
* a transformation of incoming data. Also
* serves as buffer of all data not yet
* consumed by the reader. */
int refCount;
size_t refCount;
};
static void
@@ -225,7 +225,7 @@ static void
ReleaseData(
TransformChannelData *dataPtr)
{
if (--dataPtr->refCount) {
if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
+13 -13
View File
@@ -591,7 +591,7 @@ TclChanCreateObjCmd(
if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -617,35 +617,35 @@ TclChanCreateObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"read\" method",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"write\" method",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
@@ -1152,7 +1152,7 @@ ReflectClose(
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
ckfree((char *)tctPtr);
ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
@@ -1221,7 +1221,7 @@ ReflectClose(
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
ckfree((char *)tctPtr);
ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
@@ -1946,7 +1946,7 @@ ReflectGetOption(
goto error;
} else {
int len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
@@ -2319,7 +2319,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
int cmdLen;
const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
@@ -2398,7 +2398,7 @@ ErrnoReturn(
if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK)
|| (code >= 0))) {
if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) {
if (strcmp("EAGAIN", TclGetString(resObj)) == 0) {
code = -EAGAIN;
} else {
code = 0;
@@ -3174,7 +3174,7 @@ ForwardProc(
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
@@ -3273,7 +3273,7 @@ ForwardSetObjError(
Tcl_Obj *obj)
{
int len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
+15 -15
View File
@@ -554,7 +554,7 @@ TclChanPushObjCmd(
*/
chanObj = objv[CHAN];
parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode);
parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode);
if (parentChan == NULL) {
return TCL_ERROR;
}
@@ -608,7 +608,7 @@ TclChanPushObjCmd(
if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -619,7 +619,7 @@ TclChanPushObjCmd(
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
Tcl_GetString(cmdObj),
TclGetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
@@ -633,7 +633,7 @@ TclChanPushObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
@@ -655,7 +655,7 @@ TclChanPushObjCmd(
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
@@ -666,14 +666,14 @@ TclChanPushObjCmd(
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
Tcl_GetString(cmdObj)));
TclGetString(cmdObj)));
goto error;
}
@@ -694,14 +694,14 @@ TclChanPushObjCmd(
*/
rtmPtr = GetReflectedTransformMap(interp);
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
#endif /* TCL_THREADS */
@@ -1027,7 +1027,7 @@ ReflectClose(
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -2043,7 +2043,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
int cmdLen;
const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
@@ -2568,7 +2568,7 @@ ForwardProc(
*/
rtmPtr = GetReflectedTransformMap(interp);
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
/*
@@ -2578,7 +2578,7 @@ ForwardProc(
*/
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedTransformArgs(rtPtr);
@@ -2807,7 +2807,7 @@ ForwardSetObjError(
Tcl_Obj *obj)
{
int len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
@@ -2955,7 +2955,7 @@ ResultClear(
return;
}
ckfree((char *) rPtr->buf);
ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
+26 -24
View File
@@ -56,8 +56,8 @@ static const char *gai_strerror(int code) {
int
TclSockGetPort(
Tcl_Interp *interp,
const char *string, /* Integer or service name */
const char *proto, /* "tcp" or "udp", typically */
const char *string, /* Integer or service name */
const char *proto, /* "tcp" or "udp", typically */
int *portPtr) /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
@@ -154,15 +154,15 @@ TclSockMinimumBuffers(
int
TclCreateSocketAddress(
Tcl_Interp *interp, /* Interpreter for querying
* the desired socket family */
struct addrinfo **addrlist, /* Socket address list */
const char *host, /* Host. NULL implies INADDR_ANY */
int port, /* Port number */
int willBind, /* Is this an address to bind() to or
* to connect() to? */
const char **errorMsgPtr) /* Place to store the error message
* detail, if available. */
Tcl_Interp *interp, /* Interpreter for querying the desired socket
* family */
struct addrinfo **addrlist, /* Socket address list */
const char *host, /* Host. NULL implies INADDR_ANY */
int port, /* Port number */
int willBind, /* Is this an address to bind() to or to
* connect() to? */
const char **errorMsgPtr) /* Place to store the error message detail, if
* available. */
{
struct addrinfo hints;
struct addrinfo *p;
@@ -181,30 +181,31 @@ TclCreateSocketAddress(
* Workaround for OSX's apparent inability to resolve "localhost", "0"
* when the loopback device is the only available network interface.
*/
if (host != NULL && port == 0) {
portstring = NULL;
portstring = NULL;
} else {
TclFormatInt(portbuf, port);
portstring = portbuf;
TclFormatInt(portbuf, port);
portstring = portbuf;
}
(void) memset(&hints, 0, sizeof(hints));
hints.ai_family = AF_UNSPEC;
/*
* Magic variable to enforce a certain address family - to be superseded
* by a TIP that adds explicit switches to [socket]
* Magic variable to enforce a certain address family; to be superseded
* by a TIP that adds explicit switches to [socket].
*/
if (interp != NULL) {
family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0);
if (family != NULL) {
if (strcmp(family, "inet") == 0) {
hints.ai_family = AF_INET;
} else if (strcmp(family, "inet6") == 0) {
hints.ai_family = AF_INET6;
}
}
family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0);
if (family != NULL) {
if (strcmp(family, "inet") == 0) {
hints.ai_family = AF_INET;
} else if (strcmp(family, "inet6") == 0) {
hints.ai_family = AF_INET6;
}
}
}
hints.ai_socktype = SOCK_STREAM;
@@ -251,6 +252,7 @@ TclCreateSocketAddress(
*
* There might be more elegant/efficient ways to do this.
*/
if (willBind) {
for (p = *addrlist; p != NULL; p = p->ai_next) {
if (p->ai_family == AF_INET) {
+17 -18
View File
@@ -71,8 +71,7 @@ typedef struct ThreadSpecificData {
* Prototypes for functions defined later in this file.
*/
static int EvalFileCallback(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc EvalFileCallback;
static FilesystemRecord*FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
@@ -545,8 +544,8 @@ TclFSCwdPointerEquals(
int len1, len2;
const char *str1, *str2;
str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* They are equal, but different objects. Update so they will be
@@ -639,8 +638,8 @@ FsGetFirstFilesystem(void)
}
/*
* The epoch can be changed both by filesystems being added or removed and by
* env(HOME) changing.
* The epoch can be changed by filesystems being added or removed, by changing
* the "system encoding" and by env(HOME) changing.
*/
int
@@ -689,7 +688,7 @@ FsUpdateCwd(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
str = TclGetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
@@ -1225,8 +1224,8 @@ FsAddMountsToGlobResult(
if (norm != NULL) {
const char *path, *mount;
mount = Tcl_GetStringFromObj(mElt, &mlen);
path = Tcl_GetStringFromObj(norm, &len);
mount = TclGetStringFromObj(mElt, &mlen);
path = TclGetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
@@ -1817,7 +1816,7 @@ Tcl_FSEvalFileEx(
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
string = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280 Force the evaluator to open a frame for a sourced file.
@@ -1844,7 +1843,7 @@ Tcl_FSEvalFileEx(
* Record information telling where the error occurred.
*/
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
const char *pathString = TclGetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
@@ -1995,7 +1994,7 @@ EvalFileCallback(
*/
int length;
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
const char *pathString = TclGetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
@@ -2847,8 +2846,8 @@ Tcl_FSGetCwd(
int len1, len2;
const char *str1, *str2;
str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = Tcl_GetStringFromObj(norm, &len2);
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
* If the paths were equal, we can be more efficient and
@@ -4116,7 +4115,7 @@ TclGetPathType(
* caller. */
{
int pathLen;
const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
@@ -4228,7 +4227,7 @@ TclFSNonnativePathType(
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = Tcl_GetStringFromObj(vol,&len);
strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
@@ -4575,8 +4574,8 @@ Tcl_FSRemoveDirectory(
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
normPathStr = TclGetStringFromObj(normPath, &normLen);
cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
(size_t) normLen) == 0)) {
/*
+28 -35
View File
@@ -114,14 +114,13 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
/*
* See if there is a valid cached result from a previous lookup (doing the
* check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
* the common case where the result is cached).
*/
if (objPtr->typePtr == &indexType) {
if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
@@ -211,13 +210,8 @@ GetIndexFromObjList(
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags, indexPtr);
sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr);
/*
* The internal rep must be cleared since tablePtr will go away.
*/
TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
@@ -279,7 +273,7 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &indexType) {
if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
@@ -340,17 +334,19 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
if (!(flags & INDEX_TEMP_TABLE)) {
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
*indexPtr = index;
return TCL_OK;
@@ -712,10 +708,10 @@ PrefixAllObjCmd(
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
string = Tcl_GetStringFromObj(objv[2], &length);
string = TclGetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
@@ -768,13 +764,13 @@ PrefixLongestObjCmd(
if (result != TCL_OK) {
return result;
}
string = Tcl_GetStringFromObj(objv[2], &length);
string = TclGetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
@@ -924,6 +920,14 @@ Tcl_WrongNumArgs(
int toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
/*
* Check for spelling fixes, and substitute the fixed values.
*/
if (origObjv[0] == NULL) {
origObjv = (Tcl_Obj *const *)origObjv[2];
}
/*
* We only know how to do rewriting if all the replaced objects are
* actually arguments (in objv) to this function. Otherwise it just
@@ -957,12 +961,6 @@ Tcl_WrongNumArgs(
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
@@ -1011,11 +1009,6 @@ Tcl_WrongNumArgs(
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
@@ -1151,7 +1144,7 @@ Tcl_ParseArgsObjv(
curArg = objv[srcIndex];
srcIndex++;
objc--;
str = Tcl_GetStringFromObj(curArg, &length);
str = TclGetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
+2 -2
View File
@@ -1009,7 +1009,7 @@ declare 250 {
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
char *bytes, int length, int flags)
const char *bytes, int length, int flags)
}
##############################################################################
@@ -1246,7 +1246,7 @@ declare 19 macosx {
}
declare 29 {win unix} {
int TclWinCPUID(unsigned int index, unsigned int *regs)
int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
+81 -54
View File
@@ -25,6 +25,19 @@
#undef ACCEPT_NAN
/*
* In Tcl 8.7, stop supporting special hacks for legacy Itcl 3.
* Itcl 4 doesn't need them. Itcl 3 can be updated to not need them
* using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+
* releases. Perhaps Tcl 8.7 will add even better public interfaces
* supporting all the re-invocation mechanisms extensions like Itcl 3
* need. As an absolute last resort, folks who must make Itcl 3 work
* unchanged with Tcl 8.7 can remove this line to regain the migration
* support. Tcl 9 will no longer offer even that option.
*/
#define AVOID_HACKS_FOR_ITCL 1
/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
@@ -169,6 +182,21 @@ typedef struct Tcl_ResolverInfo {
* at compile time. */
} Tcl_ResolverInfo;
/*
* This flag bit should not interfere with TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable
* lookup is performed for upvar (or similar) purposes, with slightly
* different rules:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*
* It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
* (Bug #835020)
*/
#define TCL_AVOID_RESOLVERS 0x40000
/*
*----------------------------------------------------------------
* Data structures related to namespaces.
@@ -389,27 +417,6 @@ struct NamespacePathEntry {
#define TCL_CREATE_NS_IF_UNKNOWN 0x800
#define TCL_FIND_ONLY_NS 0x1000
/*
* The data cached in an ensemble subcommand's Tcl_Obj rep (reference in
* twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs
* referring to the same subcommand, even where one is a duplicate of another.
*/
typedef struct {
Namespace *nsPtr; /* The namespace backing the ensemble which
* this is a subcommand of. */
int epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Tcl_Command token; /* Reference to the comamnd for which this
* structure is a cache of the resolution. */
char *fullSubcmdName; /* The full (local) name of the subcommand,
* allocated with ckalloc(). */
Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the
* command that implements this ensemble
* subcommand. */
} EnsembleCmdRep;
/*
* The client data for an ensemble command. This consists of the table of
* commands that are actually exported by the namespace, and an epoch counter
@@ -797,6 +804,7 @@ typedef struct VarInHash {
* MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
* MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
* MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
* MODULE_SCOPE int TclIsVarArraySearched(Var *varPtr);
*/
#define TclIsVarScalar(varPtr) \
@@ -838,6 +846,9 @@ typedef struct VarInHash {
#define TclIsVarDeadHash(varPtr) \
((varPtr)->flags & VAR_DEAD_HASH)
#define TclIsVarArraySearched(varPtr) \
((varPtr)->flags & VAR_SEARCH_ACTIVE)
#define TclGetVarNsPtr(varPtr) \
(TclIsVarInHash(varPtr) \
? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
@@ -1683,11 +1694,13 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
#define CMD_IS_DELETED 0x1
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
#define CMD_COMPILES_EXPANDED 0x8
#define CMD_IS_DELETED 0x01
#define CMD_TRACE_ACTIVE 0x02
#define CMD_HAS_EXEC_TRACES 0x04
#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
#define CMD_VIA_RESOLVER 0x20
/*
*----------------------------------------------------------------
@@ -1889,7 +1902,7 @@ typedef struct Interp {
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
int compileEpoch; /* Holds the current "compilation epoch" for
unsigned int compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
@@ -2540,6 +2553,15 @@ typedef struct TclFileAttrProcs {
TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;
/*
* Private flag value which controls Tcl_GetIndexFromObj*() routines
* to instruct them not to cache lookups because the table will not
* live long enough to make it worthwhile. Must not clash with public
* flag value TCL_EXACT.
*/
#define INDEX_TEMP_TABLE 2
/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
@@ -2590,7 +2612,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2602,9 +2624,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
*/
typedef struct ProcessGlobalValue {
int epoch; /* Epoch counter to detect changes in the
size_t epoch; /* Epoch counter to detect changes in the
* master value. */
int numBytes; /* Length of the master string. */
size_t numBytes; /* Length of the master string. */
char *value; /* The master string value. */
Tcl_Encoding encoding; /* system encoding when master string was
* initialized. */
@@ -2691,7 +2713,6 @@ MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
#ifndef TCL_WIDE_INT_IS_LONG
MODULE_SCOPE const Tcl_ObjType tclWideIntType;
@@ -2762,6 +2783,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues;
MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
@@ -2872,8 +2894,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE int TclClearRootEnsemble(ClientData data[],
Tcl_Interp *interp, int result);
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
@@ -2909,6 +2930,8 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -3053,7 +3076,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
int *lengthPtr, Tcl_Encoding *encodingPtr);
size_t *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void TclpInitLock(void);
MODULE_SCOPE void TclpInitPlatform(void);
MODULE_SCOPE void TclpInitUnlock(void);
@@ -3111,13 +3134,25 @@ MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int subIdx,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int inPlace,
int objc, Tcl_Obj *const objv[],
Tcl_Obj **objPtrPtr);
MODULE_SCOPE int TclStringFind(Tcl_Obj *needle, Tcl_Obj *haystack,
int start);
MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
int last);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
MODULE_SCOPE int TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
int count, Tcl_Obj **objPtrPtr);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, int line,
struct CompileEnv *envPtr);
@@ -3965,7 +4000,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
@@ -4045,7 +4080,7 @@ typedef const char *TclDTraceStr;
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
&& ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
ckfree((objPtr)->bytes); \
} \
(objPtr)->length = -1; \
TclFreeObjStorage(objPtr); \
@@ -4068,7 +4103,7 @@ typedef const char *TclDTraceStr;
(objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
ckfree((char *) (objPtr))
ckfree(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
@@ -4227,7 +4262,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
@@ -4262,11 +4297,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclInvalidateStringRep(objPtr) \
if (objPtr->bytes != NULL) { \
if (objPtr->bytes != tclEmptyStringRep) { \
ckfree((char *) objPtr->bytes); \
if ((objPtr)->bytes != NULL) { \
if ((objPtr)->bytes != tclEmptyStringRep) { \
ckfree((objPtr)->bytes); \
} \
objPtr->bytes = NULL; \
(objPtr)->bytes = NULL; \
}
/*
@@ -4396,8 +4431,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
#define TclIsPureByteArray(objPtr) \
(((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------
@@ -4532,13 +4566,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
* MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
* MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
* MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
@@ -4555,9 +4588,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewIntObj(objPtr, l) \
TclNewLongObj(objPtr, l)
/*
* NOTE: There is to be no such thing as a "pure" boolean.
* See comment above TclSetBooleanObj macro above.
@@ -4587,9 +4617,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, i) \
(objPtr) = Tcl_NewIntObj(i)
#define TclNewLongObj(objPtr, l) \
(objPtr) = Tcl_NewLongObj(l)
@@ -4677,7 +4704,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#define TclCleanupCommandMacro(cmdPtr) \
if ((cmdPtr)->refCount-- <= 1) { \
ckfree((char *) (cmdPtr));\
ckfree(cmdPtr);\
}
/*
@@ -4835,7 +4862,7 @@ typedef struct NRE_callback {
#else
#define TCLNR_ALLOC(interp, ptr) \
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
+2 -2
View File
@@ -615,7 +615,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
/* 251 */
EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes,
int length, int flags);
typedef struct TclIntStubs {
@@ -873,7 +873,7 @@ typedef struct TclIntStubs {
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
+6 -6
View File
@@ -98,7 +98,7 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst,
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -173,7 +173,7 @@ EXTERN void TclWinFlushDirtyChannels(void);
/* 28 */
EXTERN void TclWinResetInterfaces(void);
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -247,7 +247,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode(
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -288,7 +288,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
@@ -321,7 +321,7 @@ typedef struct TclIntPlatStubs {
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -354,7 +354,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
+15 -19
View File
@@ -336,7 +336,7 @@ Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
return TCL_ERROR;
}
}
@@ -382,7 +382,7 @@ Tcl_Init(
* alternate tclInit command before calling Tcl_Init().
*/
return Tcl_Eval(interp,
return Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
" proc tclInit {} {\n"
" global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -410,6 +410,7 @@ Tcl_Init(
" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
" {file join $parentDir library} \\\n"
" {file join $grandParentDir library} \\\n"
" {file join $grandParentDir tcl[info tclversion] library} \\\n"
" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
" {\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
@@ -444,7 +445,7 @@ Tcl_Init(
" error $msg\n"
" }\n"
"}\n"
"tclInit");
"tclInit", -1, 0);
}
/*
@@ -660,14 +661,9 @@ NRInterpCmd(
if (masterInterp == NULL) {
return TCL_ERROR;
}
if (TclGetString(objv[5])[0] == '\0') {
if (objc == 6) {
return AliasDelete(interp, slaveInterp, objv[3]);
}
} else {
return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
objv[5], objc - 6, objv + 6);
}
return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
objv[5], objc - 6, objv + 6);
}
goto aliasArgs;
}
@@ -2368,7 +2364,7 @@ SlaveCreate(
SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
@@ -3195,8 +3191,8 @@ Tcl_MakeSafe(
* Assume these functions all work. [Bug 2895741]
*/
(void) Tcl_Eval(interp,
"namespace eval ::tcl {namespace eval mathfunc {}}");
(void) Tcl_EvalEx(interp,
"namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
(void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master,
"::tcl::mathfunc::min", 0, NULL);
(void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master,
@@ -4502,7 +4498,7 @@ SlaveCommandLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
(void) TclGetStringFromObj(scriptObj, &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4519,7 +4515,7 @@ SlaveCommandLimitCmd(
break;
case OPT_VAL:
limitObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
(void) TclGetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
@@ -4711,7 +4707,7 @@ SlaveTimeLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
(void) TclGetStringFromObj(objv[i+1], &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4728,7 +4724,7 @@ SlaveTimeLimitCmd(
break;
case OPT_MILLI:
milliObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
(void) TclGetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
@@ -4746,7 +4742,7 @@ SlaveTimeLimitCmd(
break;
case OPT_SEC:
secObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &secLen);
(void) TclGetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
+25 -18
View File
@@ -393,8 +393,9 @@ LinkTraceProc(
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
} else {
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
@@ -407,8 +408,9 @@ LinkTraceProc(
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have real value";
#ifdef ACCEPT_NAN
} else {
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
}
LinkedVar(double) = linkPtr->lastValue.d;
@@ -425,7 +427,7 @@ LinkTraceProc(
break;
case TCL_LINK_CHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -436,7 +438,7 @@ LinkTraceProc(
break;
case TCL_LINK_UCHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -447,7 +449,7 @@ LinkTraceProc(
break;
case TCL_LINK_SHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -458,7 +460,7 @@ LinkTraceProc(
break;
case TCL_LINK_USHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -469,35 +471,38 @@ LinkTraceProc(
break;
case TCL_LINK_UINT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned int value";
} else {
linkPtr->lastValue.ui = (unsigned int)valueWide;
}
linkPtr->lastValue.ui = (unsigned int)valueWide;
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
case TCL_LINK_LONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have long value";
} else {
linkPtr->lastValue.l = (long)valueWide;
}
linkPtr->lastValue.l = (long)valueWide;
LinkedVar(long) = linkPtr->lastValue.l;
break;
case TCL_LINK_ULONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
} else {
linkPtr->lastValue.ul = (unsigned long)valueWide;
}
linkPtr->lastValue.ul = (unsigned long)valueWide;
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
break;
@@ -505,28 +510,30 @@ LinkTraceProc(
/*
* FIXME: represent as a bignum.
*/
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
} else {
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
}
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
case TCL_LINK_FLOAT:
if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have float value";
} else {
linkPtr->lastValue.f = (float)valueDouble;
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
value = TclGetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **) linkPtr->addr;
@@ -577,7 +584,7 @@ ObjValue(
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
+8 -8
View File
@@ -897,18 +897,18 @@ Tcl_ListObjReplace(
}
if (count < 0) {
count = 0;
} else if (numElems < first+count || first+count < 0) {
/*
* The 'first+count < 0' condition here guards agains integer
* overflow in determining 'first+count'.
*/
} else if (first > INT_MAX - count /* Handle integer overflow */
|| numElems < first+count) {
count = numElems - first;
}
if (objc > LIST_MAX - (numElems - count)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded",
LIST_MAX));
}
return TCL_ERROR;
}
isShared = (listRepPtr->refCount > 1);
@@ -1898,7 +1898,7 @@ SetListFromAny(
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
ckfree((char *) listRepPtr);
ckfree(listRepPtr);
return TCL_ERROR;
}
if (elemStart == limit) {
+32 -23
View File
@@ -174,7 +174,7 @@ TclDeleteLiteralTable(
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
char *bytes, /* The start of the string. Note that this is
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
int length, /* Number of bytes in the string. */
unsigned hash, /* The string's hash. If -1, it will be
@@ -214,7 +214,7 @@ TclCreateLiteral(
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
if (flags & LITERAL_ON_HEAP) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
globalPtr->refCount++;
@@ -222,26 +222,40 @@ TclCreateLiteral(
}
}
if (!newPtr) {
if (flags & LITERAL_ON_HEAP) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
}
/*
* The literal is new to the interpreter. Add it to the global literal
* table.
* The literal is new to the interpreter.
*/
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
if (flags & LITERAL_ON_HEAP) {
objPtr->bytes = bytes;
if ((flags & LITERAL_ON_HEAP)) {
objPtr->bytes = (char *) bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
/* Should the new literal be shared globally? */
if ((flags & LITERAL_UNSHARED)) {
/*
* No, do *not* add it the global literal table
* Make clear, that no global value is returned
*/
if (globalPtrPtr != NULL) {
*globalPtrPtr = NULL;
}
return objPtr;
}
/*
* Yes, add it to the global literal table.
*/
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -251,6 +265,7 @@ TclCreateLiteral(
globalPtr = ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
@@ -360,7 +375,7 @@ int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
register char *bytes, /* Points to string for which to find or
register const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length, /* Number of bytes in the string. If < 0, the
@@ -398,7 +413,7 @@ TclRegisterLiteral(
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
if (flags & LITERAL_ON_HEAP) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
@@ -417,7 +432,7 @@ TclRegisterLiteral(
* the namespace as the interp's global NS.
*/
if (flags & LITERAL_CMD_NAME) {
if ((flags & LITERAL_CMD_NAME)) {
if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
nsPtr = iPtr->globalNsPtr;
} else {
@@ -431,12 +446,13 @@ TclRegisterLiteral(
* Is it in the interpreter's global literal table? If not, create it.
*/
globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
if (globalPtr->refCount < 1) {
if (globalPtr != NULL && globalPtr->refCount < 1) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -671,7 +687,7 @@ AddLocalLiteralEntry(
}
if (!found) {
bytes = Tcl_GetStringFromObj(objPtr, &length);
bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : length), bytes);
}
@@ -1025,7 +1041,7 @@ TclInvalidateCmdLiteral(
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL) {
@@ -1147,18 +1163,11 @@ TclVerifyLocalLiteralTable(
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != -1) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
bytes = TclGetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" is not global",
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
@@ -1205,7 +1214,7 @@ TclVerifyGlobalLiteralTable(
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount < 1) {
bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : length), bytes, globalPtr->refCount);
+1 -1
View File
@@ -1015,7 +1015,7 @@ Tcl_StaticPackage(
* TclGetLoadedPackages --
*
* This function returns information about all of the files that are
* loaded (either in a particular intepreter, or for all interpreters).
* loaded (either in a particular interpreter, or for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If successful, a
+12 -23
View File
@@ -112,7 +112,7 @@ typedef enum {
PROMPT_CONTINUE /* Print prompt for command continuation */
} PromptType;
typedef struct InteractiveState {
typedef struct {
Tcl_Channel input; /* The standard input channel from which lines
* are read. */
int tty; /* Non-zero means standard input is a
@@ -246,7 +246,7 @@ Tcl_SourceRCFile(
const char *fileName;
Tcl_Channel chan;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
@@ -266,14 +266,18 @@ Tcl_SourceRCFile(
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);
Tcl_Close(NULL, c);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
Tcl_IncrRefCount(fullNameObj);
if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
Tcl_DecrRefCount(fullNameObj);
}
}
Tcl_DStringFree(&temp);
@@ -283,7 +287,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
* Tcl_Main, Tcl_MainEx --
* Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -532,7 +536,7 @@ Tcl_MainEx(
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
TclGetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
@@ -549,7 +553,7 @@ Tcl_MainEx(
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
TclGetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
@@ -634,21 +638,6 @@ Tcl_MainEx(
Tcl_Exit(exitCode);
}
#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
#undef Tcl_Main
extern DLLEXPORT void
Tcl_Main(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc)
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
{
Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#ifndef TCL_ASCII_MAIN
@@ -808,7 +797,7 @@ StdinProc(
goto prompt;
}
isPtr->prompt = PROMPT_START;
Tcl_GetStringFromObj(commandPtr, &length);
TclGetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
@@ -839,7 +828,7 @@ StdinProc(
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
+15 -29
View File
@@ -32,7 +32,7 @@
*/
typedef struct ThreadSpecificData {
long numNsCreated; /* Count of the number of namespaces created
size_t numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
@@ -59,7 +59,7 @@ typedef struct ResolvedNsName {
* the name was resolved. NULL if the name is
* fully qualified and thus the resolution
* does not depend on the context. */
int refCount; /* Reference count: 1 for each nsName object
size_t refCount; /* Reference count: 1 for each nsName object
* that has a pointer to this ResolvedNsName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -1326,8 +1326,7 @@ void
TclNsDecrRefCount(
Namespace *nsPtr)
{
nsPtr->refCount--;
if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
}
@@ -2566,7 +2565,9 @@ Tcl_FindCommand(
}
if (result == TCL_OK) {
((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
} else if (result != TCL_CONTINUE) {
return NULL;
}
@@ -2658,6 +2659,7 @@ Tcl_FindCommand(
}
if (cmdPtr != NULL) {
cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
@@ -2883,9 +2885,9 @@ GetNamespaceFromObj(
resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
(!refNsPtr || ((interp == refNsPtr->interp) &&
(refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
&& (!refNsPtr || (refNsPtr ==
(Namespace *) TclGetCurrentNamespace(interp)))) {
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
@@ -3354,14 +3356,7 @@ NRNamespaceEvalCmd(
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
framePtr->objc = objc;
framePtr->objv = objv;
} else {
framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
if (objc == 3) {
/*
@@ -3768,7 +3763,6 @@ NRNamespaceInscopeCmd(
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
register Interp *iPtr = (Interp *) interp;
int i;
Tcl_Obj *cmdObjPtr;
@@ -3794,14 +3788,7 @@ NRNamespaceInscopeCmd(
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
framePtr->objc = objc;
framePtr->objv = objv;
} else {
framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
/*
* Execute the command. If there is just one argument, just treat it as a
@@ -4553,8 +4540,8 @@ NamespaceUpvarCmd(
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
"access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
if (otherPtr == NULL) {
return TCL_ERROR;
@@ -4683,8 +4670,7 @@ FreeNsNameInternalRep(
* references, free it up.
*/
resNamePtr->refCount--;
if (resNamePtr->refCount == 0) {
if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
@@ -4794,7 +4780,7 @@ SetNsNameFromAny(
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 1;
TclFreeIntRep(objPtr);
+5 -8
View File
@@ -68,12 +68,9 @@ static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
static void DeletedDefineNamespace(ClientData clientData);
static void DeletedObjdefNamespace(ClientData clientData);
static void DeletedHelpersNamespace(ClientData clientData);
static int FinalizeAlloc(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeNext(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeObjectCall(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
static Tcl_NRPostProc FinalizeObjectCall;
static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
@@ -269,7 +266,7 @@ TclOOInit(
* to be fully provided.
*/
if (Tcl_Eval(interp, initScript) != TCL_OK) {
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
@@ -463,7 +460,7 @@ InitFoundation(
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_Eval(interp, slotScript);
return Tcl_EvalEx(interp, slotScript, -1, 0);
}
/*
+4 -6
View File
@@ -70,15 +70,12 @@ static void AddSimpleClassChainToCallContext(Class *classPtr,
Class *const filterDecl);
static int CmpStr(const void *ptr1, const void *ptr2);
static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static int FinalizeMethodRefs(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc FinalizeMethodRefs;
static void FreeMethodNameRep(Tcl_Obj *objPtr);
static inline int IsStillValid(CallChain *callPtr, Object *oPtr,
int flags, int reuseMask);
static int ResetFilterFlags(ClientData data[],
Tcl_Interp *interp, int result);
static int SetFilterFlags(ClientData data[],
Tcl_Interp *interp, int result);
static Tcl_NRPostProc ResetFilterFlags;
static Tcl_NRPostProc SetFilterFlags;
static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
/*
@@ -182,6 +179,7 @@ StashCallChain(
CallChain *callPtr)
{
callPtr->refCount++;
TclGetString(objPtr);
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
+11 -11
View File
@@ -525,7 +525,7 @@ TclOOUnknownDefinition(
return TCL_ERROR;
}
soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
@@ -585,7 +585,7 @@ FindCommand(
Tcl_Namespace *const namespacePtr)
{
int length;
const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
register Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
@@ -774,7 +774,7 @@ GenerateErrorInfo(
int length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
const char *objName = TclGetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
@@ -1239,7 +1239,7 @@ TclOODefineConstructorObjCmd(
}
clsPtr = oPtr->classPtr;
Tcl_GetStringFromObj(objv[2], &bodyLength);
TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1358,7 +1358,7 @@ TclOODefineDestructorObjCmd(
}
clsPtr = oPtr->classPtr;
Tcl_GetStringFromObj(objv[1], &bodyLength);
TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -2217,7 +2217,7 @@ ClassSuperSet(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
ckfree(superclasses);
return TCL_ERROR;
}
}
@@ -2234,7 +2234,7 @@ ClassSuperSet(
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
}
ckfree((char *) oPtr->classPtr->superclasses.list);
ckfree(oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
oPtr->classPtr->superclasses.num = superc;
@@ -2323,7 +2323,7 @@ ClassVarsSet(
}
for (i=0 ; i<varc ; i++) {
const char *varName = Tcl_GetString(varv[i]);
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2349,7 +2349,7 @@ ClassVarsSet(
}
if (i != varc) {
if (varc == 0) {
ckfree((char *) oPtr->classPtr->variables.list);
ckfree(oPtr->classPtr->variables.list);
} else if (i) {
oPtr->classPtr->variables.list = (Tcl_Obj **)
ckrealloc((char *) oPtr->classPtr->variables.list,
@@ -2604,7 +2604,7 @@ ObjVarsSet(
}
for (i=0 ; i<varc ; i++) {
const char *varName = Tcl_GetString(varv[i]);
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2630,7 +2630,7 @@ ObjVarsSet(
}
if (i != varc) {
if (varc == 0) {
ckfree((char *) oPtr->variables.list);
ckfree(oPtr->variables.list);
} else if (i) {
oPtr->variables.list = (Tcl_Obj **)
ckrealloc((char *) oPtr->variables.list,
+1 -1
View File
@@ -592,7 +592,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do { \
if ((ptr)->refCount-- <= 1) { \
ckfree((char *) (ptr)); \
ckfree(ptr); \
} \
} while(0)
+3 -5
View File
@@ -70,10 +70,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
static int InvokeProcedureMethod(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp,
int result);
static int FinalizePMCall(ClientData data[], Tcl_Interp *interp,
int result);
static Tcl_NRPostProc FinalizeForwardCall;
static Tcl_NRPostProc FinalizePMCall;
static int PushMethodCallFrame(Tcl_Interp *interp,
CallContext *contextPtr, ProcedureMethod *pmPtr,
int objc, Tcl_Obj *const *objv,
@@ -1168,7 +1166,7 @@ MethodErrorHandler(
CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
TclGetStringFromObj(mPtr->namePtr, &nameLen);
Object *declarerPtr;
if (mPtr->declaringObjectPtr != NULL) {
+87 -101
View File
@@ -361,7 +361,7 @@ typedef struct ResolvedCmdName {
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
int refCount; /* Reference count: 1 for each cmdName object
size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -402,7 +402,6 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
@@ -663,7 +662,7 @@ TclContinuationsEnterDerived(
* better way which doesn't shimmer?)
*/
Tcl_GetStringFromObj(objPtr, &length);
TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
@@ -1811,7 +1810,7 @@ Tcl_DbNewBooleanObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (boolValue? 1 : 0);
objPtr->internalRep.longValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1989,7 +1988,7 @@ TclSetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
const char *str = TclGetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
@@ -2426,7 +2425,7 @@ Tcl_NewIntObj(
{
register Tcl_Obj *objPtr;
TclNewIntObj(objPtr, intValue);
TclNewLongObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -3253,13 +3252,11 @@ UpdateStringOfBignum(
if (status != MP_OKAY) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size == 3) {
if (size < 2) {
/*
* mp_radix_size() returns 3 when more than INT_MAX bytes would be
* mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
* integer overflow issues). When we know the string rep will be more
* than 3, we can conclude the string rep would overflow our string
* length limits.
* integer overflow issues).
*
* Note that so long as we enforce our bignums to the size that fits
* in a packed bignum, this branch will never be taken.
@@ -4048,7 +4045,7 @@ TclFreeObjEntry(
*----------------------------------------------------------------------
*/
unsigned int
TCL_HASH_TYPE
TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -4098,7 +4095,7 @@ TclHashObjKey(
result += (result << 3) + UCHAR(*++string);
}
}
return result;
return (TCL_HASH_TYPE) result;
}
/*
@@ -4152,11 +4149,10 @@ Tcl_GetCommandFromObj(
*/
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
if (objPtr->typePtr == &tclCmdNameType) {
register Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& !(cmdPtr->flags & CMD_IS_DELETED)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
register Namespace *refNsPtr = (Namespace *)
@@ -4204,6 +4200,59 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
static void
SetCmdNameObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Command *cmdPtr,
ResolvedCmdName *resPtr)
{
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
fillPtr = ckalloc(sizeof(ResolvedCmdName));
fillPtr->refCount = 1;
}
fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
/* NOTE: relying on NULL termination here. */
if ((name[0] == ':') && (name[1] == ':')) {
/*
* Fully qualified names always resolve to same thing. No need
* to record resolution context information.
*/
fillPtr->refNsPtr = NULL;
fillPtr->refNsId = 0; /* Will not be read */
fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
* Record current state of current namespace as the resolution
* context of this command name lookup.
*/
Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
fillPtr->refNsPtr = currNsPtr;
fillPtr->refNsId = currNsPtr->nsId;
fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
if (resPtr == NULL) {
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
}
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
@@ -4213,45 +4262,16 @@ TclSetCmdNameObj(
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Namespace *currNsPtr;
const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
return;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
return;
}
}
cmdPtr->refCount++;
resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
name = TclGetString(objPtr);
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
* NULL.
*/
resPtr->refNsPtr = NULL;
} else {
/*
* Get the current namespace.
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4282,13 +4302,12 @@ FreeCmdNameInternalRep(
{
register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
if (resPtr->refCount-- == 1) {
if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
@@ -4300,7 +4319,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
}
@@ -4333,9 +4351,7 @@ DupCmdNameInternalRep(
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
}
@@ -4365,10 +4381,8 @@ SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
if (interp == NULL) {
@@ -4388,59 +4402,31 @@ SetCmdNameFromAny(
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Free the old internalRep before setting the new one. Do this after
* getting the string rep to allow the conversion code (in particular,
* Tcl_GetStringFromObj) to use that old internalRep.
* Stop shimmering and caching nothing when we found nothing. Just
* report the failure to find the command as an error.
*/
if (cmdPtr) {
cmdPtr->refCount++;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
if (cmdPtr == NULL) {
return TCL_ERROR;
}
Command *oldCmdPtr = resPtr->cmdPtr;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
/*
* Re-use existing ResolvedCmdName struct when possible.
* Cleanup the old fields that need it.
*/
if (--oldCmdPtr->refCount == 0) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
TclFreeIntRep(objPtr);
resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->refCount = 1;
objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
* NULL.
*/
Command *oldCmdPtr = resPtr->cmdPtr;
resPtr->refNsPtr = NULL;
} else {
/*
* Get the current namespace.
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
if (oldCmdPtr->refCount-- <= 1) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
resPtr = NULL;
}
SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
return TCL_OK;
}
+2 -2
View File
@@ -233,7 +233,7 @@ ConvertZeroEffectToNOP(
TclGetUInt1AtPtr(currentInstPtr + 1));
int numBytes;
(void) Tcl_GetStringFromObj(litPtr, &numBytes);
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
@@ -248,7 +248,7 @@ ConvertZeroEffectToNOP(
TclGetUInt4AtPtr(currentInstPtr + 1));
int numBytes;
(void) Tcl_GetStringFromObj(litPtr, &numBytes);
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
+3 -3
View File
@@ -1022,7 +1022,7 @@ ParseComment(
if (parsePtr->commentStart == NULL) {
parsePtr->commentStart = p;
}
p++;
numBytes--;
while (numBytes) {
@@ -2220,7 +2220,7 @@ TclSubstTokens(
if (result == 0) {
clPos = 0;
} else {
Tcl_GetStringFromObj(result, &clPos);
TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
@@ -2496,7 +2496,7 @@ TclObjCommandComplete(
* check. */
{
int length;
const char *script = Tcl_GetStringFromObj(objPtr, &length);
const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
+33 -29
View File
@@ -231,7 +231,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
Tcl_GetStringFromObj(retVal, &curLen);
TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -257,7 +257,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
Tcl_GetStringFromObj(retVal, &curLen);
TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -288,7 +288,7 @@ TclFSNormalizeAbsolutePath(
*/
const char *path =
Tcl_GetStringFromObj(retVal, &curLen);
TclGetStringFromObj(retVal, &curLen);
while (--curLen >= 0) {
if (IsSeparatorOrNull(path[curLen])) {
@@ -303,7 +303,7 @@ TclFSNormalizeAbsolutePath(
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
linkStr = TclGetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
@@ -316,7 +316,7 @@ TclFSNormalizeAbsolutePath(
} else {
retVal = linkObj;
}
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
@@ -333,7 +333,7 @@ TclFSNormalizeAbsolutePath(
}
}
} else {
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
@@ -404,7 +404,7 @@ TclFSNormalizeAbsolutePath(
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
int len;
const char *path = Tcl_GetStringFromObj(retVal, &len);
const char *path = TclGetStringFromObj(retVal, &len);
if (len == 2 && path[0] != 0 && path[1] == ':') {
if (Tcl_IsShared(retVal)) {
@@ -579,7 +579,7 @@ TclPathPart(
int numBytes;
const char *rest =
Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -617,7 +617,7 @@ TclPathPart(
int numBytes;
const char *rest =
Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -646,7 +646,7 @@ TclPathPart(
const char *fileName, *extension;
int length;
fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
@@ -698,7 +698,7 @@ TclPathPart(
int length;
const char *fileName, *extension;
fileName = Tcl_GetStringFromObj(pathPtr, &length);
fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
@@ -869,19 +869,23 @@ TclJoinPath(
* object which can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements, but we
* could expand that in the future.
*
* Bugfix [a47641a0]. TclNewFSPathObj requires first argument
* to be an absolute path. Added a check for that elt is absolute.
*/
if ((i == (elements-2)) && (i == 0)
&& (elt->typePtr == &tclFsPathType)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) {
Tcl_Obj *tailObj = objv[i+1];
&& (elt->typePtr == &tclFsPathType)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
Tcl_Obj *tailObj = objv[i+1];
type = TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
str = Tcl_GetStringFromObj(tailObj, &len);
str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
@@ -943,7 +947,7 @@ TclJoinPath(
}
}
}
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
strElt = TclGetStringFromObj(elt, &strEltLen);
type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/*
@@ -1030,9 +1034,9 @@ TclJoinPath(
noQuickReturn:
if (res == NULL) {
res = Tcl_NewObj();
ptr = Tcl_GetStringFromObj(res, &length);
ptr = TclGetStringFromObj(res, &length);
} else {
ptr = Tcl_GetStringFromObj(res, &length);
ptr = TclGetStringFromObj(res, &length);
}
/*
@@ -1077,7 +1081,7 @@ TclJoinPath(
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
Tcl_GetStringFromObj(res, &length);
TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
@@ -1372,7 +1376,7 @@ AppendPath(
* intrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
bytes = Tcl_GetStringFromObj(tail, &numBytes);
bytes = TclGetStringFromObj(tail, &numBytes);
if (numBytes == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
@@ -1431,7 +1435,7 @@ TclFSMakePathRelative(
* too little below, leading to wrong answers returned by glob.
*/
tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
@@ -1451,7 +1455,7 @@ TclFSMakePathRelative(
}
break;
}
tempStr = Tcl_GetStringFromObj(pathPtr, &len);
tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -1715,7 +1719,7 @@ Tcl_FSGetTranslatedStringPath(
if (transPtr != NULL) {
int len;
const char *orig = Tcl_GetStringFromObj(transPtr, &len);
const char *orig = TclGetStringFromObj(transPtr, &len);
char *result = ckalloc(len+1);
memcpy(result, orig, (size_t) len+1);
@@ -1776,7 +1780,7 @@ Tcl_FSGetNormalizedPath(
UpdateStringOfFsPath(pathPtr);
}
Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
@@ -1789,7 +1793,7 @@ Tcl_FSGetNormalizedPath(
* We now own a reference on both 'dir' and 'copy'
*/
(void) Tcl_GetStringFromObj(dir, &cwdLen);
(void) TclGetStringFromObj(dir, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/* Normalize the combined string. */
@@ -1883,7 +1887,7 @@ Tcl_FSGetNormalizedPath(
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
(void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
(void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/*
@@ -2333,7 +2337,7 @@ SetFsPathFromAny(
* cmdAH.test exercise most of the code).
*/
name = Tcl_GetStringFromObj(pathPtr, &len);
name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
@@ -2602,7 +2606,7 @@ UpdateStringOfFsPath(
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
copy->bytes = tclEmptyStringRep;
copy->length = 0;
@@ -2663,7 +2667,7 @@ TclNativePathInFilesystem(
int len;
(void) Tcl_GetStringFromObj(pathPtr, &len);
(void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
+1 -1
View File
@@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec,
static TclFile
FileForRedirect(
Tcl_Interp *interp, /* Intepreter to use for error reporting. */
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *spec, /* Points to character just after redirection
* character. */
int atOK, /* Non-zero means that '@' notation can be
+4 -4
View File
@@ -842,7 +842,7 @@ Tcl_PackageObjCmd(
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
@@ -883,7 +883,7 @@ Tcl_PackageObjCmd(
prevPtr->nextPtr = availPtr;
}
}
argv4 = Tcl_GetStringFromObj(objv[4], &length);
argv4 = TclGetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, (unsigned) length + 1);
break;
}
@@ -1034,7 +1034,7 @@ Tcl_PackageObjCmd(
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
argv2 = Tcl_GetStringFromObj(objv[2], &length);
argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
@@ -1682,7 +1682,7 @@ AddRequirementsToResult(
int i, length;
for (i = 0; i < reqc; i++) {
const char *v = Tcl_GetStringFromObj(reqv[i], &length);
const char *v = TclGetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+4 -4
View File
@@ -22,7 +22,7 @@
typedef struct {
ClientData clientData; /* Address of preserved block. */
int refCount; /* Number of Tcl_Preserve calls in effect for
size_t refCount; /* Number of Tcl_Preserve calls in effect for
* block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
@@ -63,7 +63,7 @@ typedef struct HandleStruct {
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
int refCount; /* Number of TclHandlePreserve() calls in
size_t refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
@@ -195,7 +195,7 @@ Tcl_Release(
continue;
}
if (--refPtr->refCount != 0) {
if (refPtr->refCount-- > 1) {
Tcl_MutexUnlock(&preserveMutex);
return;
}
@@ -459,7 +459,7 @@ TclHandleRelease(
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
ckfree(handlePtr);
}
}
+8 -34
View File
@@ -343,7 +343,7 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
procBody = TclGetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
@@ -1087,12 +1087,10 @@ ProcWrongNumArgs(
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1;
#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
#else
desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1);
#endif /* AVOID_HACKS_FOR_ITCL */
}
Tcl_IncrRefCount(desiredObjs[0]);
@@ -1527,6 +1525,10 @@ InitArgsAndLocals(
*/
incorrectArgs:
if ((skip != 1) &&
TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
memset(varPtr, 0,
((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
return ProcWrongNumArgs(interp, skip);
@@ -2081,7 +2083,7 @@ MakeProcError(
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
@@ -2652,30 +2654,6 @@ TclNRApplyObjCmd(
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
#define JOE_EXTENSION 0
/*
* Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
* ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
* the code. (MS)
*/
#if JOE_EXTENSION
else {
/*
* Joe English's suggestion to allow cmdNames to function as lambdas.
*/
Tcl_Obj *elemPtr;
int numElem;
if ((lambdaPtr->typePtr == &tclCmdNameType) ||
(TclListObjGetElements(interp, lambdaPtr, &numElem,
&elemPtr) == TCL_OK && numElem == 1)) {
return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
}
}
#endif
if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
result = SetLambdaFromAny(interp, lambdaPtr);
if (result != TCL_OK) {
@@ -2716,10 +2694,6 @@ TclNRApplyObjCmd(
extraPtr->efi.fields[0].clientData = lambdaPtr;
extraPtr->cmd.clientData = &extraPtr->efi;
if (TclInitRewriteEnsemble(interp, 1, 0, objv)) {
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
@@ -2766,7 +2740,7 @@ MakeLambdaError(
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+10 -3
View File
@@ -502,9 +502,16 @@ Tcl_RegExpMatchObj(
{
Tcl_RegExp re;
re = Tcl_GetRegExpFromObj(interp, patternObj,
TCL_REG_ADVANCED | TCL_REG_NOSUB);
if (re == NULL) {
/*
* For performance reasons, first try compiling the RE without support for
* subexpressions. On failure, try again without TCL_REG_NOSUB in case the
* RE has backreferences in it. Closely related to [Bug 1366683]. If this
* still fails, an error message will be left in the interpreter.
*/
if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
TCL_REG_ADVANCED | TCL_REG_NOSUB))
&& !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
return -1;
}
return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
+1 -1
View File
@@ -37,7 +37,7 @@ typedef struct TclRegexp {
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
int refCount; /* Count of number of references to this
unsigned int refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
+9
View File
@@ -396,6 +396,9 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w);
* - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are
* not part of the [scan] command's vocabulary. Use only in
* combination with TCL_PARSE_INTEGER_ONLY.
* - TCL_PARSE_BINARY_ONLY: parse only in the binary format, whether
* or not a prefix is present that would lead to binary parsing.
* Use only in combination with TCL_PARSE_INTEGER_ONLY.
* - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether
* or not a prefix is present that would lead to octal parsing.
* Use only in combination with TCL_PARSE_INTEGER_ONLY.
@@ -627,6 +630,9 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY)) {
goto endgame;
}
state = ZERO_X;
break;
}
@@ -637,6 +643,9 @@ TclParseNumber(
goto zeroo;
}
if (c == 'b' || c == 'B') {
if (flags & TCL_PARSE_OCTAL_ONLY) {
goto endgame;
}
state = ZERO_B;
break;
}
+657 -3
View File
@@ -408,6 +408,15 @@ Tcl_GetCharLength(
String *stringPtr;
int numChars;
/*
* Quick, no-shimmer return for short string reps.
*/
if ((objPtr->bytes) && (objPtr->length < 2)) {
/* 0 bytes -> 0 chars; 1 byte -> 1 char */
return objPtr->length;
}
/*
* Optimize the case where we're really dealing with a bytearray object
* without string representation; we don't need to convert to a string to
@@ -1173,6 +1182,8 @@ Tcl_AppendUnicodeToObj(
* Side effects:
* The string rep of appendObjPtr is appended to the string
* representation of objPtr.
* IMPORTANT: This routine does not and MUST NOT shimmer appendObjPtr.
* Callers are counting on that.
*
*----------------------------------------------------------------------
*/
@@ -1854,6 +1865,14 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
} else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) {
format += (step + 2);
step = Tcl_UtfToUniChar(format, &ch);
useBig = 1;
} else if (ch == 'L') {
format += step;
step = Tcl_UtfToUniChar(format, &ch);
useBig = 1;
}
format += step;
@@ -2285,7 +2304,7 @@ Tcl_AppendFormatToObj(
}
}
Tcl_GetStringFromObj(segment, &segmentNumBytes);
TclGetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
@@ -2461,6 +2480,10 @@ AppendPrintfToObjVA(
Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
va_arg(argList, long)));
break;
case 2:
Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
va_arg(argList, Tcl_WideInt)));
break;
}
break;
case 'e':
@@ -2489,9 +2512,20 @@ AppendPrintfToObjVA(
gotPrecision = 1;
p++;
break;
/* TODO: support for wide (and bignum?) arguments */
/* TODO: support for bignum arguments */
case 'l':
size = 1;
++size;
p++;
break;
case 'L':
size = 2;
p++;
break;
case 'I':
if (p[1]=='6' && p[2]=='4') {
p += 2;
size = 2;
}
p++;
break;
case 'h':
@@ -2598,6 +2632,616 @@ TclGetStringStorage(
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
/*
*---------------------------------------------------------------------------
*
* TclStringRepeat --
*
* Performs the [string repeat] function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
* of count copies of the value in objPtr.
*
*---------------------------------------------------------------------------
*/
int
TclStringRepeat(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int count,
Tcl_Obj **objPtrPtr)
{
Tcl_Obj *objResultPtr;
int length = 0, unichar = 0, done = 1;
int binary = TclIsPureByteArray(objPtr);
/* assert (count >= 2) */
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
* Produce pure bytearray when possible.
* Error on overflow.
*/
if (!binary) {
if (objPtr->typePtr == &tclStringType) {
String *stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode) {
unichar = 1;
}
}
}
if (binary) {
/* Result will be pure byte array. Pre-size it */
Tcl_GetByteArrayFromObj(objPtr, &length);
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
Tcl_GetUnicodeFromObj(objPtr, &length);
} else {
/* Result will be concat of string reps. Pre-size it. */
Tcl_GetStringFromObj(objPtr, &length);
}
if (length == 0) {
/* Any repeats of empty is empty. */
*objPtrPtr = objPtr;
return TCL_OK;
}
if (count > INT_MAX/length) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
if (binary) {
/* Efficiently produce a pure byte array result */
objResultPtr = Tcl_IsShared(objPtr) ? Tcl_DuplicateObj(objPtr)
: objPtr;
Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
Tcl_SetByteArrayLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
TclAppendBytesToByteArray(objResultPtr,
Tcl_GetByteArrayFromObj(objResultPtr, NULL),
(count - done) * length);
} else if (unichar) {
/* Efficiently produce a pure Tcl_UniChar array result */
if (Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
} else {
TclInvalidateStringRep(objPtr);
objResultPtr = objPtr;
}
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %"
TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(count*length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr),
(count - done) * length);
} else {
/* Efficiently concatenate string reps */
if (Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
} else {
TclFreeIntRep(objPtr);
objResultPtr = objPtr;
}
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %u bytes",
count*length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
(count - done) * length);
}
*objPtrPtr = objResultPtr;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TclStringCatObjv --
*
* Performs the [string cat] function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
* of all objc values in objv.
*
*---------------------------------------------------------------------------
*/
int
TclStringCatObjv(
Tcl_Interp *interp,
int inPlace,
int objc,
Tcl_Obj * const objv[],
Tcl_Obj **objPtrPtr)
{
Tcl_Obj *objPtr, *objResultPtr, * const *ov;
int oc, length = 0, binary = 1, first = 0;
int allowUniChar = 1, requestUniChar = 0;
/* assert (objc >= 2) */
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
* Produce pure bytearray when possible.
* Error on overflow.
*/
ov = objv, oc = objc;
while (oc-- && (binary || allowUniChar)) {
objPtr = *ov++;
if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
/*
* Non-empty string rep. Not a pure bytearray, so we
* won't create a pure bytearray
*/
binary = 0;
if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
}
} else {
/* assert (objPtr->typePtr != NULL) -- stork! */
if (TclIsPureByteArray(objPtr)) {
allowUniChar = 0;
} else {
binary = 0;
if (objPtr->typePtr == &tclStringType) {
/* Have a pure Unicode value; ask to preserve it */
requestUniChar = 1;
} else {
/* Have another type; prevent shimmer */
allowUniChar = 0;
}
}
}
}
if (binary) {
/* Result will be pure byte array. Pre-size it */
ov = objv; oc = objc;
while (oc-- && (length >= 0)) {
objPtr = *ov++;
if (objPtr->bytes == NULL) {
int numBytes;
Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
if (length == 0) {
first = objc - oc - 1;
}
length += numBytes;
}
}
} else if (allowUniChar && requestUniChar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
ov = objv; oc = objc;
while (oc-- && (length >= 0)) {
objPtr = *ov++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int numChars;
Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
if (length == 0) {
first = objc - oc - 1;
}
length += numChars;
}
}
} else {
/* Result will be concat of string reps. Pre-size it. */
ov = objv; oc = objc;
while (oc-- && (length >= 0)) {
int numBytes;
objPtr = *ov++;
Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
if ((length == 0) && numBytes) {
first = objc - oc - 1;
}
length += numBytes;
}
}
if (length < 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
if (length == 0) {
/* Total length of zero means every value has length zero */
*objPtrPtr = objv[0];
return TCL_OK;
}
objv += first; objc -= first;
if (binary) {
/* Efficiently produce a pure byte array result */
unsigned char *dst;
/*
* Broken interface! Byte array value routines offer no way
* to handle failure to allocate enough space. Following
* stanza may panic.
*/
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
Tcl_GetByteArrayFromObj(objResultPtr, &start);
dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
} else {
objResultPtr = Tcl_NewByteArrayObj(NULL, length);
dst = Tcl_SetByteArrayLength(objResultPtr, length);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if (objPtr->bytes == NULL) {
int more;
unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
memcpy(dst, src, (size_t) more);
dst += more;
}
}
} else if (allowUniChar && requestUniChar) {
/* Efficiently produce a pure Tcl_UniChar array result */
Tcl_UniChar *dst;
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
/* Ugly interface! Force resize of the unicode array. */
Tcl_GetUnicodeFromObj(objResultPtr, &start);
Tcl_InvalidateStringRep(objResultPtr);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
dst = Tcl_GetUnicode(objResultPtr) + start;
} else {
Tcl_UniChar ch = 0;
/* Ugly interface! No scheme to init array size. */
objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
dst = Tcl_GetUnicode(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int more;
Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
memcpy(dst, src, more * sizeof(Tcl_UniChar));
dst += more;
}
}
} else {
/* Efficiently concatenate string reps */
char *dst;
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
Tcl_GetStringFromObj(objResultPtr, &start);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %u bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
dst = Tcl_GetString(objResultPtr) + start;
if (length > start) {
TclFreeIntRep(objResultPtr);
}
} else {
objResultPtr = Tcl_NewObj(); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %u bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
dst = Tcl_GetString(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int more;
char *src = Tcl_GetStringFromObj(objPtr, &more);
memcpy(dst, src, (size_t) more);
dst += more;
}
}
}
*objPtrPtr = objResultPtr;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TclStringFind --
*
* Implements the [string first] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* first instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
int
TclStringFind(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int start)
{
int lh, ln = Tcl_GetCharLength(needle);
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
* finder, change this to "return 0"
*/
return -1;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *end, *try, *bh;
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
bh = Tcl_GetByteArrayFromObj(haystack, &lh);
end = bh + lh;
try = bh + start;
while (try + ln <= end) {
try = memchr(try, bn[0], end - try);
if (try == NULL) {
return -1;
}
if (0 == memcmp(try+1, bn+1, ln-1)) {
return (try - bh);
}
try++;
}
return -1;
}
lh = Tcl_GetCharLength(haystack);
if (haystack->bytes && (lh == haystack->length)) {
/* haystack is all single-byte chars */
if (needle->bytes && (ln == needle->length)) {
/* needle is also all single-byte chars */
char *found = strstr(haystack->bytes + start, needle->bytes);
if (found) {
return (found - haystack->bytes);
} else {
return -1;
}
} else {
/*
* Cannot find substring with a multi-byte char inside
* a string with no multi-byte chars.
*/
return -1;
}
} else {
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
end = uh + lh;
try = uh + start;
while (try + ln <= end) {
if ((*try == *un)
&& (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
return (try - uh);
}
try++;
}
return -1;
}
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* last instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
int
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int last)
{
int lh, ln = Tcl_GetCharLength(needle);
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
* finder, change this to "return 0"
*/
return -1;
}
if (ln > last + 1) {
return -1;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *try, *bh;
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
bh = Tcl_GetByteArrayFromObj(haystack, &lh);
if (last + 1 > lh) {
last = lh - 1;
}
try = bh + last + 1 - ln;
while (try >= bh) {
if ((*try == bn[0])
&& (0 == memcmp(try+1, bn+1, ln-1))) {
return (try - bh);
}
try--;
}
return -1;
}
lh = Tcl_GetCharLength(haystack);
if (last + 1 > lh) {
last = lh - 1;
}
if (haystack->bytes && (lh == haystack->length)) {
/* haystack is all single-byte chars */
if (needle->bytes && (ln == needle->length)) {
/* needle is also all single-byte chars */
char *try = haystack->bytes + last + 1 - ln;
while (try >= haystack->bytes) {
if ((*try == needle->bytes[0])
&& (0 == memcmp(try+1, needle->bytes + 1, ln - 1))) {
return (try - haystack->bytes);
}
try--;
}
return -1;
} else {
/*
* Cannot find substring with a multi-byte char inside
* a string with no multi-byte chars.
*/
return -1;
}
} else {
Tcl_UniChar *try, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
try = uh + last + 1 - ln;
while (try >= uh) {
if ((*try == un[0])
&& (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
return (try - uh);
}
try--;
}
return -1;
}
}
/*
*---------------------------------------------------------------------------
*
@@ -2948,6 +3592,16 @@ UpdateStringOfString(
{
String *stringPtr = GET_STRING(objPtr);
/*
* This routine is only called when we need to generate the
* string rep objPtr->bytes because it does not exist -- it is NULL.
* In that circumstance, any lingering claim about the size of
* memory pointed to by that NULL pointer is clearly bogus, and
* needs a reset.
*/
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
TclInitStringRep(objPtr, tclEmptyStringRep, 0);
} else {
+6 -6
View File
@@ -46,7 +46,7 @@
* tcl.h, but do not do that unless you are sure what you're doing!
*/
typedef struct String {
typedef struct {
int numChars; /* The number of chars in the string. -1 means
* this value has not been calculated. >= 0
* means that there is a valid Unicode rep, or
@@ -72,17 +72,17 @@ typedef struct String {
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
STRING_MAXCHARS); \
(int)STRING_MAXCHARS); \
} \
} while (0)
#define stringAttemptAlloc(numChars) \
(String *) attemptckalloc((unsigned) STRING_SIZE(numChars))
(String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
(String *) ckalloc((unsigned) STRING_SIZE(numChars))
(String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
(String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
(String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
(String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
+12
View File
@@ -749,6 +749,7 @@ const TclTomMathStubs tclTomMathStubs = {
TclBNInitBignumFromLong, /* 64 */
TclBNInitBignumFromWideInt, /* 65 */
TclBNInitBignumFromWideUInt, /* 66 */
TclBN_mp_expt_d_ex, /* 67 */
};
static const TclStubHooks tclStubHooks = {
@@ -1415,6 +1416,17 @@ const TclStubs tclStubs = {
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
Tcl_ArraySet, /* 631 */
Tcl_ArrayUnset, /* 632 */
Tcl_ArrayGet, /* 633 */
Tcl_ArrayNames, /* 634 */
Tcl_ArraySize, /* 635 */
Tcl_ArrayExists, /* 636 */
Tcl_ArraySearchStart, /* 637 */
Tcl_ArraySearchPeek, /* 638 */
Tcl_ArraySearchNext, /* 639 */
Tcl_ArraySearchDone, /* 640 */
Tcl_ArrayStatistics, /* 641 */
};
/* !END!: Do not edit above this line. */
+9 -5
View File
@@ -101,12 +101,16 @@ Tcl_InitStubs(
}
}
}
tclStubsPtr = (TclStubs *)pkgData;
if (((exact&0xff00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
tclStubsPtr = stubsPtr;
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
if (stubsPtr->hooks) {
tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
+146 -47
View File
@@ -42,16 +42,8 @@
* Declare external functions used in Windows tests.
*/
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Tcltest_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
EXTERN int Tcltest_Init(Tcl_Interp *interp);
EXTERN int Tcltest_SafeInit(Tcl_Interp *interp);
DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
@@ -326,6 +318,9 @@ static int TestparsevarnameObjCmd(ClientData dummy,
static int TestpreferstableObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestprintObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -416,8 +411,7 @@ static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp,
int result);
static Tcl_NRPostProc NREUnwind_callback;
static int TestNREUnwind(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -550,10 +544,10 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
@@ -658,6 +652,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
@@ -790,7 +786,7 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
@@ -1294,7 +1290,7 @@ TestcmdtraceCmd(
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
(ClientData) &deleteCalled, ObjTraceDeleteProc);
result = Tcl_Eval(interp, argv[2]);
result = Tcl_EvalEx(interp, argv[2], -1, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
@@ -1308,7 +1304,7 @@ TestcmdtraceCmd(
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
result = Tcl_Eval(interp, argv[2]);
result = Tcl_EvalEx(interp, argv[2], -1, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1637,7 +1633,7 @@ DelDeleteProc(
{
DelCmd *dPtr = clientData;
Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
@@ -3826,6 +3822,43 @@ TestpreferstableObjCmd(
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestprintObjCmd --
*
* This procedure implements the "testprint" command. It is
* used for being able to test the Tcl_ObjPrintf() function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_WideInt argv1 = 0;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
}
if (objc > 1) {
Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -3972,7 +4005,7 @@ TestregexpObjCmd(
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
value = Tcl_SetVar(interp, varName, resinfo, 0);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -3986,7 +4019,7 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
value = Tcl_SetVar(interp, varName, resinfo, 0);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -4329,7 +4362,7 @@ StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
* being loaded. */
{
Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -4413,7 +4446,7 @@ TestupvarCmd(
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
@@ -4606,7 +4639,7 @@ TestpanicCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
const char *argString;
char *argString;
/*
* Put the arguments into a var args structure
@@ -4907,10 +4940,10 @@ GetTimesObjCmd(
timePer/100000);
/* Tcl_SetVar 100000 times */
fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -4924,7 +4957,7 @@ GetTimesObjCmd(
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -5194,7 +5227,7 @@ TestsaveresultCmd(
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0);
}
if (discard) {
@@ -6297,7 +6330,7 @@ TestReport(
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_Eval(interp, Tcl_DStringValue(&ds));
Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
@@ -6760,7 +6793,7 @@ TestcpuidCmd(
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
unsigned int regs[4];
int regs[4];
Tcl_Obj *regsObjs[4];
if (objc != 2) {
@@ -6770,14 +6803,14 @@ TestcpuidCmd(
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
status = TclWinCPUID((unsigned) index, regs);
status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", -1));
return status;
}
for (i=0 ; i<4 ; ++i) {
regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
regsObjs[i] = Tcl_NewIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -7335,23 +7368,82 @@ InterpCmdResolver(
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
Namespace *ns2NsPtr = (Namespace *)
Tcl_FindNamespace(interp, "::ns2", NULL, 0);
Namespace *callerNsPtr = varFramePtr->nsPtr;
Tcl_Command resolvedCmdPtr = NULL;
if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
|| (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
const char *callingCmdName =
/*
* Just do something special on a cmd literal "z" in two cases:
* A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
* B) the caller's namespace is "ctx1" or "ctx2"
*/
if ( (name[0] == 'z') && (name[1] == '\0') ) {
Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
if (procPtr != NULL
&& ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
|| (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
)
) {
/*
* Case A)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the caller proc, which has to be
* named "x".
*
* - To determine the name of the caller proc, the proc is taken
* from the topmost stack frame.
*
* - Note that the context is NOT provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y", which is taken from the
* the global namespace (for simplicity).
*/
const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
&& (name[0] == 'z') && (name[1] == '\0')) {
Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
TCL_GLOBAL_ONLY);
if (sourceCmdPtr != NULL) {
*rPtr = sourceCmdPtr;
return TCL_OK;
if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
}
} else if (callerNsPtr != NULL) {
/*
* Case B)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the parent namespace, which has
* to be named "ctx1" or "ctx2".
*
* - To determine the name of the parent namesace, it is taken
* from the 2nd highest stack frame.
*
* - Note that the context can be provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y" or "Y" depending on the
* context. The resolved procs are taken from the the global
* namespace (for simplicity).
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
/* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
} else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
/*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
if (resolvedCmdPtr != NULL) {
*rPtr = resolvedCmdPtr;
return TCL_OK;
}
}
return TCL_CONTINUE;
@@ -7485,9 +7577,16 @@ TestInterpResolverCmd(
int idx;
#define RESOLVER_KEY "testInterpResolver"
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down");
return TCL_ERROR;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
}
if (objc == 3) {
interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
Tcl_AppendResult(interp, "provided interpreter not found", NULL);
return TCL_ERROR;
}
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
+52 -27
View File
@@ -19,6 +19,7 @@
#endif
#include "tclInt.h"
#include "tommath.h"
#include "tclStringRep.h"
/*
@@ -46,13 +47,6 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
typedef struct TestString {
int numChars;
int allocated;
int maxChars;
Tcl_UniChar unicode[2];
} TestString;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
@@ -158,10 +152,11 @@ TestbignumobjCmd(
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", NULL
"set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
enum options {
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
BIGNUM_RADIXSIZE
};
int index, varIndex;
const char *string;
@@ -280,6 +275,50 @@ TestbignumobjCmd(
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue));
}
break;
case BIGNUM_ISEVEN:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], mp_iseven(&bignumValue));
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iseven(&bignumValue)));
}
mp_clear(&bignumValue);
break;
case BIGNUM_RADIXSIZE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_radix_size(&bignumValue, 10, &index) != MP_OKAY) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], index);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index));
}
mp_clear(&bignumValue);
break;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -583,23 +622,9 @@ TestindexobjCmd(
}
argv[objc-4] = NULL;
/*
* Tcl_GetIndexFromObj assumes that the table is statically-allocated so
* that its address is different for each index object. If we accidently
* allocate a table at the same address as that cached in the index
* object, clear out the object's cached state.
*/
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr == (void *) argv) {
TclFreeIntRep(objv[3]);
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
&index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
@@ -1076,7 +1101,7 @@ TestobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -1141,7 +1166,7 @@ TeststringobjCmd(
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
+3 -3
View File
@@ -1106,9 +1106,9 @@ TclFinalizeThreadAlloc(void)
*
* TclFinalizeThreadAllocThread --
*
* This procedure is used to destroy single thread private resources used
* in this file.
* Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread).
* This procedure is used to destroy single thread private resources
* defined in this file. Called either during Tcl_FinalizeThread() or
* Tcl_Finalize().
*
* Results:
* None.
+3 -3
View File
@@ -657,7 +657,7 @@ ThreadErrorProc(
sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
@@ -1032,8 +1032,8 @@ ThreadEventProc(
code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}

Some files were not shown because too many files have changed in this diff Show More