Differences From Artifact [2bbb17752d]:

• File tests/info.test — part of check-in [fe5f8b0525] at 2008-07-28 20:00:57 on branch core-8-4-branch — * generic/tclBasic.c: Added missing release of extended command word index when deleting an interpreter (DeleteInterpProc). Added missing ref count when creating an empty string as path (EvalEx). * generic/tclCompile.c (TclInitCompileEnv): Made same change to control flow as in TclEvalObjEx. Not needed while uplevel and siblings go through the eval-direct code path, however if that changes (like it did in 8.5+) better to have this in place instead of re-searching why certain places are without absolute locations. * tests/info.test: Added tests 38.*, exactly testing the tracking of location for uplevel scripts, and made the testsuite fully usable with and without -singleproc 1. (user: andreas_kupries size: 40497)

To Artifact [9d8d040587]:

• File tests/info.test — part of check-in [fabfd40ca1] at 2009-07-14 16:31:48 on branch core-8-4-branch — * generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter, TclArgumentBCRelease, TclArgumentGet): * generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode, TclInitCompileEnv, TclCompileScript): * generic/tclCompile.h (ExtCmdLoc): * generic/tclExecute.c (TclExecuteByteCode): * generic/tclInt.h (ExtIndex, CFWordBC): * tests/info.test (info-39.0): Backport of some changes made to the Tcl head, to handle literal sharing better. The code here is much simpler (trimmed down) compared to the head as the 8.4 branch is not bytecode compiling whole files, and doesn't compile eval'd code either. Reworked the handling of literal command arguments in bytecode to be saved (compiler) and used (execution) per command (See the TCL_INVOKE_STK* instructions), and not per the whole bytecode. This removes the problems with location data caused by literal sharing in proc bodies. Simplified the associated datastructures (ExtIndex is gone, as is the function EnterCmdWordIndex). (user: andreas_kupries size: 41109)

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006      ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.24.2.11 2008/07/28 20:01:12 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",

|

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006      ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.24.2.12 2009/07/14 16:31:49 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",

1200
1201
1202
1203
1204
1205
1206


















1207
1208
1209
1210
1211
1212

    join [lrange [datal] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1139 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1137 file info.test cmd control proc ::datal level 1}
* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}}



















# -------------------------------------------------------------------------

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230

    join [lrange [datal] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1139 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1137 file info.test cmd control proc ::datal level 1}
* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}}

# -------------------------------------------------------------------------
# literal sharing

test info-39.0 {location information not confused by literal sharing} -constraints tip280 -body {
    namespace eval ::foo {}
    proc ::foo::bar {} {
	lappend res {}
	lappend res [reduce [eval {info frame 0}]]
	lappend res [reduce [eval {info frame 0}]]
	return $res
    }
    set res [::foo::bar]
    namespace delete ::foo
    join $res \n
} -result {
type source line 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line 1215 file info.test cmd {info frame 0} proc ::foo::bar level 0}

# -------------------------------------------------------------------------

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return