You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
98 lines
4.2 KiB
98 lines
4.2 KiB
# tcl_switch_traceline_repro.tcl |
|
# 2026-07-14 Agent-Generated (supporting material for upstream Tcl ticket |
|
# https://core.tcl-lang.org/tcl/tktview/5d5b1052280c976ea3d4 - execution trace on |
|
# nested switch: inconsistent line depending on options) |
|
# |
|
# Pure-Tcl minimal repro - no punkshell code. Run under any tclsh: |
|
# tclsh tcl_switch_traceline_repro.tcl |
|
# Verified byte-identical output pattern on Tcl 8.6.17, 8.7a6 and 9.0.3. |
|
# |
|
# Setup: proc bodies are passed via a variable so they have no source-file line |
|
# correlation (as for interactively defined procs) - enterstep 'info frame' line |
|
# values are then script-relative. Each switch arm body is "{\n <marker>\n }", so |
|
# a correctly attributed arm-body command always reports line 2 (arm-relative). |
|
# |
|
# Observed (WRONG marked *): the number of mis-attributed leading arms varies |
|
# with the words of the inner switch command: |
|
# switch $c <block> (3 words): arms 1-5,def -> 2 2 2 2 2 2 |
|
# switch -- $c <block> (4 words): arms -> 3* 3* 2 2 2 2 |
|
# switch -exact -- $c <block> (5 words): arms -> 3* 2 2 2 2 2 |
|
# switch -exact -nocase -- $c <block> (6 words): arms -> 3* 3* 3* 2 2 2 |
|
# |
|
# Empirical law (fits all shapes above plus deeper nestings): an arm body at |
|
# index j of the split pattern/body list is mis-attributed exactly when j lands |
|
# on a LITERAL word of the switch command itself (an option word, --, or the |
|
# block word) - i.e. j < (command word count) and that word is not dynamic. |
|
# The wrong value = arm-relative line + (line of the switch command within its |
|
# containing script - 1): the arm body is treated as if it began at the switch |
|
# command's own line. Dynamic words ($c) and out-of-range j fall back to correct |
|
# arm-relative attribution. Deeper nesting increases the shift accordingly (a |
|
# switch at line 5 of its containing arm script mis-attributes by +4). |
|
# |
|
# The mis-attribution is stable and position-based - NOT call-order based |
|
# (calling arm 3 first still reports arm 3 correctly and arm 1 wrongly later). |
|
# |
|
# Suspected machinery (from reading core-9-1-b1 sources): Tcl_SwitchObjCmd |
|
# (tclCmdMZ.c) passes the split-list index j as the 'word' argument to |
|
# TclNREvalObjEx for the matched body; TclInitCompileEnv (tclCompile.c) then |
|
# gates on (ctxPtr->nline <= word) || (ctxPtr->line[word] < 0) and otherwise |
|
# adopts ctxPtr->line[word] as the compile base line - consistent with j being |
|
# tested against a per-word line array describing the switch COMMAND's words |
|
# rather than the split list elements (the TIP280 munging in Tcl_SwitchObjCmd's |
|
# splitObjs block appears intended to prevent exactly this, so either it is not |
|
# reached on this path or the un-munged frame leaks through another route). |
|
|
|
foreach m {m1 m2 m3 m4 m5 m6} { |
|
proc $m {} [list return $m] |
|
} |
|
set armblock { |
|
1 { |
|
m1 |
|
} |
|
2 { |
|
m2 |
|
} |
|
3 { |
|
m3 |
|
} |
|
4 { |
|
m4 |
|
} |
|
5 { |
|
m5 |
|
} |
|
default { |
|
m6 |
|
} |
|
} |
|
foreach {pname header} { |
|
t_w3 {switch $c } |
|
t_w4 {switch -- $c } |
|
t_w5 {switch -exact -- $c } |
|
t_w6 {switch -exact -nocase -- $c } |
|
} { |
|
set body "\n set c \[string index \$s 1\]\n switch -- \[string index \$s 0\] {\n a {\n $header {$armblock}\n }\n default {\n m6\n }\n }\n" |
|
proc ::$pname {s} $body |
|
} |
|
|
|
proc stepper {target args} { |
|
set f [info frame -2] |
|
if {[dict exists $f proc] && [dict get $f proc] eq $target} { |
|
set line NA |
|
catch {set line [dict get $f line]} |
|
lappend ::steps [list [dict get $f type] $line] |
|
} |
|
} |
|
foreach pname {t_w3 t_w4 t_w5 t_w6} { |
|
trace add execution ::$pname enterstep [list stepper ::$pname] |
|
set report {} |
|
foreach input {a1 a2 a3 a4 a5 a9} { |
|
set ::steps {} |
|
::$pname $input |
|
#last step is the marker command inside the matched innermost arm body |
|
lappend report "arm[string index $input 1]=[lindex $::steps end 1]" |
|
} |
|
trace remove execution ::$pname enterstep [list stepper ::$pname] |
|
puts "$pname (expected arm-relative line 2 for every arm): $report" |
|
} |
|
puts "tcl: [info patchlevel]"
|
|
|