* generic/tclBasic.c: TIP #280 implementation.

	* generic/tclCmdAH.c:
	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclCompCmds.c:
	* generic/tclCompExpr.c:
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclIOUtil.c:
	* generic/tclInt.h:
	* generic/tclInterp.c:
	* generic/tclNamesp.c:
	* generic/tclObj.c:
	* generic/tclProc.c:
	* tests/compile.test:
	* tests/info.test:
	* tests/platform.test:
	* tests/safe.test:

1 files changed, 630 insertions, 5 deletions

diff --git a/tests/info.test b/tests/info.test
index d330ada..7b7b867 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1,3 +1,4 @@
+# -*- tcl -*-
 # Commands covered:  info
 #
 # This file contains a collection of tests for one or more of the Tcl
@@ -7,11 +8,12 @@
 # Copyright (c) 1991-1994 The Regents of the University of California.
 # 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.39 2006/10/31 13:46:33 dkf Exp $
+# RCS: @(#) $Id: info.test,v 1.40 2006/11/28 22:20:29 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -664,16 +666,639 @@ test info-21.1 {miscellaneous error conditions} {
 } {1 {wrong # args: should be "info option ?arg arg ...?"}}
 test info-21.2 {miscellaneous error conditions} {
     list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 test info-21.3 {miscellaneous error conditions} {
     list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 test info-21.4 {miscellaneous error conditions} {
     list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 test info-21.5 {miscellaneous error conditions} {
     list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+
+##
+# ### ### ### ######### ######### #########
+## info frame
+
+## Helper
+# For the more complex results we cut the file name down to remove
+# path dependencies, and we use only part of the first line of the
+# reported command. The latter is required because otherwise the whole
+# test case may appear in some results, but the result is part of the
+# testcase. An infinite string would be required to describe that. The
+# cutting-down breaks this.
+
+proc reduce {frame} {
+    set  pos [lsearch -exact $frame cmd]
+    incr pos
+    set  cmd [lindex $frame $pos]
+    if {[regexp \n $cmd]} {
+	set first [string range [lindex [split $cmd \n] 0] 0 end-4]
+	set frame [lreplace $frame $pos $pos $first]
+    }
+    set pos [lsearch -exact $frame file]
+    if {$pos >=0} {
+	incr pos
+	set tail  [file tail [lindex $frame $pos]]
+	set frame [lreplace $frame $pos $pos $tail]
+    }
+    set frame
+}
+
+## Helper
+# Generate a stacktrace from the current location to top.  This code
+# not only depends on the exact location of things, but also on the
+# implementation of tcltest. Any changes and these tests will have to
+# be updated.
+
+proc etrace {} {
+    set res {}
+    set level [info frame]
+    while {$level} {
+	lappend res [list $level [reduce [info frame $level]]]
+	incr level -1
+    }
+    return $res
+}
+
+##
+
+test info-22.0 {info frame, levels} {
+    info frame
+} 7
+
+test info-22.1 {info frame, bad level relative} {
+    # catch is another level!, i.e. we have 8, not 7
+    catch {info frame -8} msg
+    set msg
+} {bad level "-8"}
+
+test info-22.2 {info frame, bad level absolute} {
+    # catch is another level!, i.e. we have 8, not 7
+    catch {info frame 9} msg
+    set msg
+} {bad level "9"}
+
+test info-22.3 {info frame, current, relative} {
+    info frame 0
+} {type eval line 2 cmd {info frame 0}}
+
+test info-22.4 {info frame, current, relative, nested} {
+    set res [info frame 0]
+} {type eval line 2 cmd {info frame 0}}
+
+test info-22.5 {info frame, current, absolute} {
+    reduce [info frame 7]
+} {type eval line 2 cmd {info frame 7}}
+
+test info-22.6 {info frame, global, relative} {
+    reduce [info frame -6]
+} {type source line 755 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ level 0}
+
+test info-22.7 {info frame, global, absolute} {
+    reduce [info frame 1]
+} {type source line 759 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut level 0}
+
+test info-22.8 {info frame, basic trace} {
+    join [etrace] \n
+} {8 {type source line 719 file info.test cmd {info frame $level} proc ::etrace level 0}
+7 {type eval line 2 cmd etrace}
+6 {type source line 2290 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
+5 {type eval line 1 cmd {::tcltest::RunTest info-22}}
+4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
+3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-22}
+2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
+1 {type source line 763 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac level 1}}
+## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
+test info-23.0 {eval'd info frame} {
+    eval {info frame}
+} 8
+
+test info-23.1 {eval'd info frame, semi-dynamic} {
+    eval info frame
+} 8
+
+test info-23.2 {eval'd info frame, dynamic} {
+    set script {info frame}
+    eval $script
+} 8
+
+test info-23.3 {eval'd info frame, literal} {
+    eval {
+	info frame 0
+    }
+} {type eval line 2 cmd {info frame 0}}
+
+test info-23.4 {eval'd info frame, semi-dynamic} {
+    eval info frame 0
+} {type eval line 1 cmd {info frame 0}}
+
+test info-23.5 {eval'd info frame, dynamic} {
+    set script {info frame 0}
+    eval $script
+} {type eval line 1 cmd {info frame 0}}
+
+test info-23.6 {eval'd info frame, trace} {
+    set script {etrace}
+    join [eval $script] \n
+} {9 {type source line 719 file info.test cmd {info frame $level} proc ::etrace level 0}
+8 {type eval line 1 cmd etrace}
+7 {type eval line 3 cmd {eval $script}}
+6 {type source line 2290 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
+5 {type eval line 1 cmd {::tcltest::RunTest info-23}}
+4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
+3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-23}
+2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
+1 {type source line 802 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac level 1}}
+## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
+# -------------------------------------------------------------------------
+
+# Procedures defined in scripts which are arguments to control
+# structures (like 'namespace eval', 'interp eval', 'if', 'while',
+# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
+# location. The command implementations execute such scripts through
+# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
+# causes the connection to the context to be lost. Currently only
+# procedure bodies are able to remember their context.
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {
+    proc bar {} {info frame 0}
+}
+
+test info-24.0 {info frame, interaction, namespace eval} {
+    reduce [foo::bar]
+} {type source line 828 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+set flag 1
+if {$flag} {
+    namespace eval foo {}
+    proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.1 {info frame, interaction, if} {
+    reduce [foo::bar]
+} {type source line 842 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+set flag 1
+while {$flag} {
+    namespace eval foo {}
+    proc ::foo::bar {} {info frame 0}
+    set flag 0
+}
+
+test info-24.2 {info frame, interaction, while} {
+    reduce [foo::bar]
+} {type source line 856 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+catch {
+    namespace eval foo {}
+    proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.3 {info frame, interaction, catch} {
+    reduce [foo::bar]
+} {type source line 870 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+foreach var val {
+    namespace eval foo {}
+    proc ::foo::bar {} {info frame 0}
+    break
+}
+
+test info-24.4 {info frame, interaction, foreach} {
+    reduce [foo::bar]
+} {type source line 883 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+for {} {1} {} {
+    namespace eval foo {}
+    proc ::foo::bar {} {info frame 0}
+    break
+}
+
+test info-24.5 {info frame, interaction, for} {
+    reduce [foo::bar]
+} {type source line 897 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+eval {
+    proc bar {} {info frame 0}
+}
+
+test info-25.0 {info frame, proc in eval} {
+    reduce [bar]
+} {type source line 910 file info.test cmd {info frame 0} proc ::bar level 0}
+
+proc bar {} {info frame 0}
+test info-25.1 {info frame, regular proc} {
+    reduce [bar]
+} {type source line 917 file info.test cmd {info frame 0} proc ::bar level 0}
+rename bar {}
+
+# -------------------------------------------------------------------------
+
+test info-30.0 {bs+nl in literal words} knownBug {
+    if {1} {
+	set res \
+	    [reduce [info frame 0]]
+    }
+    set res
+    # This is reporting line 3 instead of the correct 4 because the
+    # bs+nl combination is subst by the parser before the 'if'
+    # command, and the the bcc sees the word. To fix record the
+    # offsets of all bs+nl sequences in literal words, then use the
+    # information in the bcc to bump line numbers when parsing over
+    # the location. Also affected: testcases 22.8 and 23.6.
+} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
+
+# -------------------------------------------------------------------------
+# See 24.0 - 24.5 for similar situations, using literal scripts.
+
+set body {set flag 0
+    set a c
+    set res [info frame 0]} ;# line 3!
+
+test info-31.0 {ns eval, script in variable} {
+    namespace eval foo $body
+    set res
+} {type eval line 3 cmd {info frame 0} level 0}
+catch {namespace delete foo}
+
+test info-31.1 {if, script in variable} {
+    if 1 $body
+    set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.1a {if, script in variable} {
+    if 1 then $body
+    set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.2 {while, script in variable} {
+    set flag 1
+    while {$flag} $body
+    set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+# .3 - proc - scoping prevent return of result ...
+
+test info-31.4 {foreach, script in variable} {
+    foreach var val $body
+    set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.5 {for, script in variable} {
+    set flag 1
+    for {} {$flag} {} $body
+    set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.6 {eval, script in variable} {
+    eval $body
+    set res
+} {type eval line 3 cmd {info frame 0}}
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x {
+    foo {
+	proc ::foo::bar {} {info frame 0}
+    }
+}
+
+test info-24.6.0 {info frame, interaction, switch, list body} {
+    reduce [foo::bar]
+} {type source line 992 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x foo {
+    proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.6.1 {info frame, interaction, switch, multi-body} {
+    reduce [foo::bar]
+} {type source line 1008 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x [list foo {
+    proc ::foo::bar {} {info frame 0}
+}]
+
+test info-24.6.2 {info frame, interaction, switch, list body, dynamic} {
+    reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+set body {
+    foo {
+	proc ::foo::bar {} {info frame 0}
+    }
+}
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x $body
+
+test info-31.7 {info frame, interaction, switch, dynamic} {
+    reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+set body {
+    proc ::foo::bar {} {info frame 0}
+}
+
+namespace eval foo {}
+eval $body
+
+test info-32.0 {info frame, dynamic procedure} {
+    reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace {expand}{
+    eval
+    foo
+    {proc bar {} {info frame 0}}
+}
+test info-33.0 {expand, literal, direct} {
+    reduce [foo::bar]
+} {type source line 1072 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    set flag 1
+    if {expand}{
+	{$flag}
+	{info frame 0}
+    }
+}
+test info-33.1 {expand, literal, simple, bytecompiled} {
+    reduce [foo::bar]
+} {type source line 1087 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+set body {
+    eval
+    foo
+    {proc bar {} {
+	info frame 0
+    }}
+}
+namespace {expand}$body
+test info-34.0 {expand, dynamic, direct} {
+    reduce [foo::bar]
+} {type proc line 2 cmd {info frame 0} proc ::foo::bar level 0}
+
+unset body
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set body {
+    {$flag}
+    {info frame 0}
+}
+proc foo::bar {} {
+    global body ; set flag 1
+    if {expand}$body
+}
+test info-34.1 {expand, literal, bytecompiled} {
+    reduce [foo::bar]
+} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+unset body
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+proc foo {} {
+    apply {
+	{x y}
+	{info frame 0}
+    } 0 0
+}
+test info-35.0 {apply, literal} {
+    reduce [foo]
+} {type source line 1136 file info.test cmd {info frame 0} lambda {
+	{x y}
+	{info frame 0}
+    } level 0}
+rename foo {}
+
+set lambda {
+    {x y}
+    {info frame 0}
+}
+test info-35.1 {apply, dynamic} {
+    reduce [apply $lambda 0 0]
+} {type proc line 1 cmd {info frame 0} lambda {
+    {x y}
+    {info frame 0}
+} level 0}
+unset lambda
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+dict for {k v} {foo bar} {
+    proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.7 {info frame, interaction, dict for} {
+    reduce [foo::bar]
+} {type source line 1163 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set thedict {foo bar}
+dict with thedict {
+    proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.8 {info frame, interaction, dict with} {
+    reduce [foo::bar]
+} {type source line 1177 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset thedict
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+dict filter {foo bar} script {k v} {
+    proc ::foo::bar {} {info frame 0}
+    set x 1
+}
+
+test info-24.9 {info frame, interaction, dict filter} {
+    reduce [foo::bar]
+} {type source line 1191 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    dict for {k v} {foo bar} {
+	set x [info frame 0]
+    }
+    set x
+}
+test info-36.0 {info frame, dict for, bcc} {
+    reduce [foo::bar]
+} {type source line 1207 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    set x foo
+    switch -exact -- $x {
+	foo {set y [info frame 0]}
+    }
+    set y
+}
+
+test info-36.1.0 {switch, list literal, bcc} {
+    reduce [foo::bar]
+} {type source line 1223 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    set x foo
+    switch -exact -- $x foo {set y [info frame 0]}
+    set y
+}
+
+test info-36.1.1 {switch, multi-body literals, bcc} {
+    reduce [foo::bar]
+} {type source line 1239 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace {expand}"
+    eval
+    foo
+    {proc bar {} {info frame 0}}
+"
+test info-33.2 {expand, literal, direct} {
+    reduce [foo::bar]
+} {type source line 1254 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace {expand}"eval\nfoo\n{proc bar {} {info frame 0}}\n"
+
+test info-33.2a {expand, literal, not simple, direct} {
+    reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    set flag 1
+    if {expand}"
+	{1}
+	{info frame 0}
+    "
+}
+test info-33.3 {expand, literal, simple, bytecompiled} {
+    reduce [foo::bar]
+} {type source line 1279 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+proc foo::bar {} {
+    set flag 1
+    if {expand}"\n{1}\n{info frame 0}"
+}
+test info-33.3a {expand, literal, not simple, bytecompiled} {
+    reduce [foo::bar]
+} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
 
 # cleanup
 catch {namespace delete test_ns_info1 test_ns_info2}