jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

G-070 increment 2: punk::tclparser pure-Tcl engine, parity clean both gens 

New module punk::tclparser 0.1.0 (zero-dependency): parse
command/getstring/countnewline over byte-view scanning (modified utf-8),
same result shapes and error messages as the tclparser C library.
Deliberately does not provide package 'parser' (capability probe).

Parity vs fork oracle dlls: edge corpus 234 comparisons clean per gen;
recursive organic sweep over lib/args/ansi/textblock/tclparser sources =
50005 (Tcl 8.7a6) and 49928 (Tcl 9.0.3) command-parses, 0 fails, all
~330 error-parses per gen message-identical. Generation differences
modelled version-conditionally: \xHH 2-hex cap (8.7+), Tcl 9 bare '('
rejection in array indexes, Tcl 9 nested-brace ${name} scanning.

Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
Julian Noble 1 week ago
parent
b440a08e59
commit
a492db59a6
3 changed files with 988 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 50
      goals/G-070-pure-tcl-tclparser.md
  2. 934
      src/modules/punk/tclparser-999999.0a1.0.tm
  3. 4
      src/modules/punk/tclparser-buildversion.txt

50
goals/G-070-pure-tcl-tclparser.md
Unescape View File

@ -126,6 +126,56 @@ Design notes recorded for the implementation increments:
modified utf-8 where NUL is 0xC0 0x80 - offsets may differ from strict
utf-8), high-plane chars.
### Increment 2 (2026-08-02): pure-Tcl engine + parity harness, both generations clean
New module src/modules/punk/tclparser-999999.0a1.0.tm (punk::tclparser 0.1.0):
`punk::tclparser::parse` implementing the covered set (command, getstring,
countnewline) with the C library's calling convention and result shapes. Zero
package dependencies by design (loads on plain tclsh; PUNKARGS is inert
documentation via the register mechanism). Engine scans a byte view of the
string (modified utf-8: NUL as 0xC0 0x80) so all emitted ranges are byte
offsets by construction; getstring/countnewline resolve ranges over the same
view. Uncovered subcommands error advising the C library. The module does NOT
provide package 'parser' (capability-probe hazard per increment 1).
Parity evidence (dev harnesses in the session scratchpad - parity_check.tcl
edge corpus 117 cases x2 range forms + result-tree-walk getstring/countnewline
comparisons; parity_sweep.tcl recursive organic sweep: module sources parsed
command-by-command, recursing into command substitutions and braced bodies):
- Tcl 8.7a6 + tcl86-gen oracle dll: corpus 234 comparisons clean, ~990
getstring/countnewline clean; organic sweep punk::lib + punk::args +
punk::ansi + textblock + punk::tclparser = 50005 command-parses, 0 fails,
332 error-parses ALL with byte-identical error messages.
- Tcl 9.0.3 + tcl9-gen oracle dll: corpus 234 comparisons clean; organic
sweep same five files = 49928 command-parses, 0 fails, 330 error-parses
message-identical.
Generation differences discovered via the oracle and modelled version-
conditionally in the engine (verify on real 8.6 at the kit-verification
increment - 8.7 was the Tcl 8 lane here):
- \xHH consumes at most 2 hex digits on 8.7+/9, unlimited on 8.6 (TIP 388).
- Tcl 9 rejects a bare '(' at array-index token level ("invalid character in
array index"); 8.x treats it as index text ending at the first ')'.
- ${name}: Tcl 9 balances nested braces with backslash-escaped braces not
counted; 8.x cuts at the FIRST '}' with no backslash handling.
Oracle-pinned shape facts baked into the engine (beyond increment 1's list):
leading newlines are whitespace before a command starts; a bare '$' or a
trailing backslash becomes its own text token (word, not simple); an empty
array index still carries one empty text token; literal {*} expansion is
abandoned (expand node) when any bare/quoted list element contains a
backslash (braced elements only for backslash-newline); {*} followed by
backslash-newline is a plain braced word; empty braced/quoted words carry one
empty text token.
Remaining for the goal: dispatch wiring (punk::lib namespace-local parse
shim + tclparser_tcl replacement), capability-gated tcltest parity suite +
pure-Tcl fallback suite (port of the harness corpus), plain-tclsh
tclword_to_scriptlist demonstration, real-8.6 verification, reference
identity recording.
## Notes
- Related: G-019 (dependency-scan module trimming - the main analysis consumer),

934
src/modules/punk/tclparser-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,934 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2026
#
# @@ Meta Begin
# Application punk::tclparser 999999.0a1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
package require Tcl 8.6-
#No other package requirements by design (G-070): this module is the pure-Tcl
#fallback for the tclparser C library and must load on a plain tclsh.
#punk::args is used for documentation only via the inert PUNKARGS/register
#mechanism - it is not required at runtime.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# punk::tclparser
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Pure-Tcl implementation of (a subset of) the 'parse' command API provided by
# the tclparser C library (TclPro lineage - punkshell fork/reference at
# c:/repo/jn/tclparser_punk, pin recorded in goals/G-070-pure-tcl-tclparser.md).
#
# Covered subcommands (the set punkshell consumers actually use - G-070):
# parse command <string> <range>
# parse getstring <string> <range>
# parse countnewline <string> ?range?
# Uncovered (error advising the C library): expr varname list charindex charlength
#
# IMPORTANT: this module deliberately does NOT provide the package name
# 'parser'. Consumers use `package require parser` as the capability probe
# meaning "the fast C library is present" (textblock::height fast path,
# punk::lib dispatch). The pure-Tcl engine is always the explicit fallback.
#
# All ranges ({start length} pairs) are BYTE offsets over the string's
# (modified) utf-8 representation, matching what the C library reports
# against Tcl's internal string bytes. Parsing is performed over a byte view
# so emitted offsets are byte offsets by construction: every Tcl
# syntax-significant character is ASCII and utf-8 continuation bytes cannot
# alias them.
tcl::namespace::eval punk::tclparser {
variable PUNKARGS
tcl::namespace::export parse
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::tclparser::parse
@cmd -name punk::tclparser::parse\
-summary\
"Pure-Tcl subset of the tclparser C library's 'parse' command."\
-help\
"Pure-Tcl implementation of the tclparser C library's 'parse'
command API, covering the subcommands punkshell consumers use:
command, getstring, countnewline.
Subcommand results and the ranges within them use BYTE offsets
({start length} pairs) over the string's utf-8 bytes, exactly as
the C library reports them - use 'parse getstring' (not string
range) to extract substrings by range.
parse command string range
Parse one command from string. Returns a 4 element list:
commentRange commandRange restRange tree.
The tree is a list of word nodes {type {start len} subnodes}
with word types simple/word/expand and subnode types
text/backslash/command/variable. Literal {*} expansions are
expanded at parse time into per-element simple nodes.
parse getstring string range
Return the substring of string covered by the byte range.
parse countnewline string ?range?
Return the number of newline characters in the range
(default: the whole string).
The uncovered C library subcommands (expr, varname, list,
charindex, charlength) raise an error advising installation of
the C library (package require parser).
This module intentionally does not provide the package name
'parser' - that name is the capability probe for the C library."
@values -min 2 -max 3
subcommand -type string -choices {command getstring countnewline} -choicerestricted 0 -help\
"Operation to perform (covered set: command, getstring, countnewline)"
string -type string -help\
"The string to operate on"
range -type list -optional 1 -help\
"Byte range {start length} within string. {} or omitted means the
whole string. length may be the literal 'end' to mean through to
the end of the string."
}]
}
proc parse {args} {
#parity-oriented manual parsing - documentation via PUNKARGS above (see src/modules/AGENTS.md)
if {[llength $args] < 2} {
error "wrong # args: should be \"punk::tclparser::parse subcommand string ?range?\""
}
set subcommand [lindex $args 0]
set str [lindex $args 1]
if {[llength $args] >= 3} {
set range [lindex $args 2]
} else {
set range {}
}
switch -exact -- $subcommand {
command {
if {[llength $args] != 3} {
error "wrong # args: should be \"punk::tclparser::parse command string range\""
}
return [engine::parse_command $str $range]
}
getstring {
if {[llength $args] != 3} {
error "wrong # args: should be \"punk::tclparser::parse getstring string range\""
}
return [engine::parse_getstring $str $range]
}
countnewline {
return [engine::parse_countnewline $str $range]
}
expr - varname - list - charindex - charlength {
error "punk::tclparser::parse: subcommand '$subcommand' is not implemented in the pure-Tcl engine (covered set: command, getstring, countnewline). Install the tclparser C library (package require parser) for the full API."
}
default {
error "punk::tclparser::parse: bad subcommand \"$subcommand\": must be command, getstring or countnewline"
}
}
}
}
tcl::namespace::eval punk::tclparser::engine {
#Internal parsing engine. All procs here operate on a 'byte view' string in
#which each character is one byte of the original string's (modified) utf-8
#encoding - so tcl string indices into the byte view ARE byte offsets.
#Tcl syntax characters are all ASCII; utf-8 continuation bytes (0x80-0xBF)
#and lead bytes (0xC0+) can never alias them, so scanning the byte view
#gives byte-correct ranges with no separate bookkeeping.
variable TCL9 [package vsatisfies [package provide Tcl] 9-]
#\xHH escape consumption differs by runtime: Tcl 8.7+ consumes at most 2
#hex digits (TIP 388); Tcl 8.6 consumes an unlimited run (value = low
#byte). The engine matches the RUNTIME it executes on, which is also what
#the C library linked to that runtime does (verified against the oracle
#dll under 8.7a6).
variable XHEXMAX
if {[package vsatisfies [package provide Tcl] 8.7-]} {
set XHEXMAX 2
} else {
set XHEXMAX 999999
}
# -- byte view conversion ------------------------------------------------
proc to_bytes {s} {
#NUL must round-trip as modified utf-8 (0xC0 0x80) because that is the
#internal representation the C parser indexes over.
if {[string is ascii $s] && [string first \x00 $s] < 0} {
return $s
}
variable TCL9
if {$TCL9} {
set b [encoding convertto -profile tcl8 utf-8 $s]
} else {
set b [encoding convertto utf-8 $s]
}
return [string map [list \x00 \xC0\x80] $b]
}
proc from_bytes {b} {
if {[string is ascii $b]} {
return $b
}
variable TCL9
set b [string map [list \xC0\x80 \x00] $b]
if {$TCL9} {
return [encoding convertfrom -profile tcl8 utf-8 $b]
}
return [encoding convertfrom utf-8 $b]
}
proc resolve_range {range total} {
#returns {first len} in bytes. {} means whole string.
if {[llength $range] == 0} {
return [list 0 $total]
}
if {[llength $range] != 2} {
error "invalid range \"$range\": should be \"\" or a list of two items: start length"
}
lassign $range first len
if {![string is integer -strict $first] || $first < 0} {
error "invalid range start \"$first\""
}
if {$len eq "end"} {
set len [expr {$total - $first}]
} elseif {![string is integer -strict $len]} {
error "invalid range length \"$len\""
}
if {$first > $total} {
set first $total
}
if {$first + $len > $total} {
set len [expr {$total - $first}]
}
if {$len < 0} {
set len 0
}
return [list $first $len]
}
# -- public-facing operations (called by punk::tclparser::parse) --------
proc parse_command {str range} {
set bytes [to_bytes $str]
set total [string length $bytes]
lassign [resolve_range $range $total] first len
set endpos [expr {$first + $len}]
lassign [parse_command_bytes $bytes $first $endpos 0] cs cl ks kl rest term tree
if {$cs < 0} {
set cs 0
set cl 0
}
return [list [list $cs $cl] [list $ks $kl] [list $rest [expr {$endpos - $rest}]] $tree]
}
proc parse_getstring {str range} {
set bytes [to_bytes $str]
set total [string length $bytes]
lassign [resolve_range $range $total] first len
return [from_bytes [string range $bytes $first [expr {$first + $len - 1}]]]
}
proc parse_countnewline {str range} {
set bytes [to_bytes $str]
set total [string length $bytes]
lassign [resolve_range $range $total] first len
set seg [string range $bytes $first [expr {$first + $len - 1}]]
return [expr {[string length $seg] - [string length [string map [list \n {}] $seg]]}]
}
# -- core scanner --------------------------------------------------------
proc skip_white {bytes pos endpos} {
#inter-word whitespace: space tab vtab ff cr, plus backslash-newline
#(with its trailing space/tab run) which acts as a word separator.
#Never consumes bare newline or semicolon (command terminators).
while {$pos < $endpos} {
set c [string index $bytes $pos]
switch -exact -- $c {
" " - \t - \v - \f - \r {
incr pos
}
"\\" {
if {$pos + 1 < $endpos && [string index $bytes $pos+1] eq "\n"} {
incr pos 2
while {$pos < $endpos} {
set c2 [string index $bytes $pos]
if {$c2 eq " " || $c2 eq "\t"} {
incr pos
} else {
break
}
}
} else {
return $pos
}
}
default {
return $pos
}
}
}
return $pos
}
proc bs_advance {bytes pos endpos} {
#pos is at a backslash: return the position just after the full escape
#sequence, per Tcl_ParseBackslash rules.
variable XHEXMAX
set p [expr {$pos + 1}]
if {$p >= $endpos} {
return $p
}
set c [string index $bytes $p]
switch -exact -- $c {
"\n" {
incr p
while {$p < $endpos} {
set c2 [string index $bytes $p]
if {$c2 eq " " || $c2 eq "\t"} {
incr p
} else {
break
}
}
return $p
}
x {
incr p
set hex 0
while {$p < $endpos && $hex < $XHEXMAX && [string match {[0-9a-fA-F]} [string index $bytes $p]]} {
incr p
incr hex
}
return $p
}
u {
incr p
set hex 0
while {$p < $endpos && $hex < 4 && [string match {[0-9a-fA-F]} [string index $bytes $p]]} {
incr p
incr hex
}
return $p
}
U {
incr p
set hex 0
while {$p < $endpos && $hex < 8 && [string match {[0-9a-fA-F]} [string index $bytes $p]]} {
incr p
incr hex
}
return $p
}
default {
if {[string match {[0-7]} $c]} {
set oct 0
while {$p < $endpos && $oct < 3 && [string match {[0-7]} [string index $bytes $p]]} {
incr p
incr oct
}
return $p
}
#single (possibly multibyte) character: consume the full utf-8
#sequence so the escape range never splits a character.
set b [scan $c %c]
incr p
if {$b >= 0xC0} {
while {$p < $endpos} {
set nb [scan [string index $bytes $p] %c]
if {$nb >= 0x80 && $nb < 0xC0} {
incr p
} else {
break
}
}
}
return $p
}
}
}
proc parse_command_bytes {bytes pos endpos nested} {
#Parse a single command starting at pos.
#Returns: commentStart commentLen cmdStart cmdLen restPos term tree
#term is one of: eof, nl, semi, bracket (bracket: ']' seen but NOT
#consumed - the command-substitution scanner consumes it).
set commentStart -1
set commentLen 0
while {1} {
set pos [skip_white $bytes $pos $endpos]
if {$pos < $endpos && [string index $bytes $pos] eq "\n"} {
#before the command starts, newlines are ordinary whitespace
#(they only terminate once a command is in progress)
incr pos
continue
}
if {$pos < $endpos && [string index $bytes $pos] eq "#"} {
if {$commentStart < 0} {
set commentStart $pos
}
while {$pos < $endpos} {
set c [string index $bytes $pos]
if {$c eq "\\"} {
set pos [bs_advance $bytes $pos $endpos]
} elseif {$c eq "\n"} {
incr pos
break
} else {
incr pos
}
}
set commentLen [expr {$pos - $commentStart}]
} else {
break
}
}
set cmdStart $pos
set tree [list]
set term eof
while {1} {
set pos [skip_white $bytes $pos $endpos]
if {$pos >= $endpos} {
set term eof
break
}
set c [string index $bytes $pos]
if {$c eq "\n"} {
set term nl
incr pos
break
}
if {$c eq ";"} {
set term semi
incr pos
break
}
if {$nested && $c eq "\]"} {
set term bracket
break
}
lassign [parse_word $bytes $pos $endpos $nested] nodes pos
lappend tree {*}$nodes
}
set cmdLen [expr {$pos - $cmdStart}]
return [list $commentStart $commentLen $cmdStart $cmdLen $pos $term $tree]
}
proc parse_word {bytes pos endpos nested} {
#Parse one word. Returns {nodes nextpos} - nodes is a list of word
#nodes (usually one; a literal {*} expansion may produce zero or more).
set wordStart $pos
set expand 0
if {[string range $bytes $pos [expr {$pos + 2}]] eq "\{*\}" && $pos + 3 < $endpos} {
set c3 [string index $bytes $pos+3]
set sep 0
switch -exact -- $c3 {
" " - \t - \v - \f - \r - "\n" - ";" {
set sep 1
}
"\\" {
#backslash-newline is a word separator, so a {*} followed
#by a line continuation is a plain braced word
if {$pos + 4 < $endpos && [string index $bytes $pos+4] eq "\n"} {
set sep 1
}
}
"\]" {
if {$nested} {
set sep 1
}
}
}
if {!$sep} {
set expand 1
incr pos 3
}
}
set c [string index $bytes $pos]
set bodykind bare
if {$c eq "\{"} {
set bodykind brace
lassign [parse_braces $bytes $pos $endpos] tokens pos
} elseif {$c eq "\""} {
set bodykind quote
lassign [parse_quoted $bytes $pos $endpos] tokens pos
} else {
lassign [parse_tokens $bytes $pos $endpos bare $nested] tokens pos
if {[llength $tokens] == 0} {
#can only happen for a lone backslash-newline handled by
#skip_white, or at a stop char - defensive: emit empty text
set tokens [list [list text [list $pos 0] {}]]
}
}
if {$bodykind ne "bare" && $pos < $endpos} {
#closing brace/quote must be followed by whitespace or a terminator
set c2 [string index $bytes $pos]
set ok 0
switch -exact -- $c2 {
" " - \t - \v - \f - \r - "\n" - ";" {
set ok 1
}
"\]" {
if {$nested} {
set ok 1
}
}
"\\" {
if {$pos + 1 < $endpos && [string index $bytes $pos+1] eq "\n"} {
set ok 1
}
}
}
if {!$ok} {
if {$bodykind eq "brace"} {
error "extra characters after close-brace"
} else {
error "extra characters after close-quote"
}
}
}
set wordLen [expr {$pos - $wordStart}]
if {$expand} {
if {[llength $tokens] == 1 && [lindex $tokens 0 0] eq "text"} {
#literal expansion: parse the literal as a list; each element
#becomes its own simple word node with ranges into the
#original string. If it is not a valid list, fall back to an
#expand node (the runtime raises the expansion error).
lassign [lindex $tokens 0 1] tstart tlen
if {![catch {list_elements $bytes $tstart [expr {$tstart + $tlen}]} elements]} {
set nodes [list]
foreach e $elements {
lassign $e estart elen etstart etlen
lappend nodes [list simple [list $estart $elen] [list [list text [list $etstart $etlen] {}]]]
}
return [list $nodes $pos]
}
}
return [list [list [list expand [list $wordStart $wordLen] $tokens]] $pos]
}
if {[llength $tokens] == 1 && [lindex $tokens 0 0] eq "text"} {
return [list [list [list simple [list $wordStart $wordLen] $tokens]] $pos]
}
return [list [list [list word [list $wordStart $wordLen] $tokens]] $pos]
}
proc parse_braces {bytes pos endpos} {
#pos at the open brace. Returns {tokens nextpos} with nextpos just
#after the close brace. Tokens: text runs and backslash tokens for
#backslash-newline (the only substitution inside braces).
set level 1
set p [expr {$pos + 1}]
set textStart $p
set tokens [list]
while {1} {
if {$p >= $endpos} {
error "missing close-brace"
}
set c [string index $bytes $p]
switch -exact -- $c {
"\{" {
incr level
incr p
}
"\}" {
incr level -1
if {$level == 0} {
if {$p > $textStart || [llength $tokens] == 0} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
incr p
return [list $tokens $p]
}
incr p
}
"\\" {
if {$p + 1 < $endpos && [string index $bytes $p+1] eq "\n"} {
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
set bsend [expr {$p + 2}]
while {$bsend < $endpos} {
set c2 [string index $bytes $bsend]
if {$c2 eq " " || $c2 eq "\t"} {
incr bsend
} else {
break
}
}
lappend tokens [list backslash [list $p [expr {$bsend - $p}]] {}]
set p $bsend
set textStart $p
} else {
#backslash quotes the next byte for brace counting
#purposes; both stay part of the text run
incr p 2
if {$p > $endpos} {
set p $endpos
}
}
}
default {
incr p
}
}
}
}
proc parse_quoted {bytes pos endpos} {
#pos at the open quote. Returns {tokens nextpos} with nextpos just
#after the close quote.
set p [expr {$pos + 1}]
lassign [parse_tokens $bytes $p $endpos quote 0] tokens p
if {$p >= $endpos || [string index $bytes $p] ne "\""} {
error "missing \""
}
if {[llength $tokens] == 0} {
set tokens [list [list text [list [expr {$pos + 1}] 0] {}]]
}
incr p
return [list $tokens $p]
}
proc parse_tokens {bytes pos endpos mode nested} {
#Scan substitution tokens. mode: quote (stop at unescaped double
#quote), index (stop at close paren - array subscript), bare (stop at
#whitespace/terminators; backslash-newline acts as a word separator).
#Returns {tokens stoppos} - stoppos is AT the stopping character.
variable TCL9
set tokens [list]
set textStart $pos
set p $pos
while {$p < $endpos} {
set c [string index $bytes $p]
if {$mode eq "quote"} {
if {$c eq "\""} {
break
}
} elseif {$mode eq "index"} {
if {$c eq ")"} {
break
}
if {$c eq "(" && $TCL9} {
#Tcl 9 rejects a bare open paren in an array index at
#index-token level (inside nested [ ] or $v( ) is fine);
#Tcl 8.x treats it as ordinary index text.
error "invalid character in array index"
}
} else {
set stop 0
switch -exact -- $c {
" " - \t - \v - \f - \r - "\n" - ";" {
set stop 1
}
"\]" {
if {$nested} {
set stop 1
}
}
}
if {$stop} {
break
}
}
switch -exact -- $c {
"\\" {
if {$mode eq "bare" && $p + 1 < $endpos && [string index $bytes $p+1] eq "\n"} {
#backslash-newline separates words in bare context
break
}
if {$p + 1 >= $endpos} {
#trailing backslash with nothing following becomes its
#own text token (like a bare $)
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
lappend tokens [list text [list $p 1] {}]
incr p
set textStart $p
continue
}
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
set next [bs_advance $bytes $p $endpos]
lappend tokens [list backslash [list $p [expr {$next - $p}]] {}]
set p $next
set textStart $p
}
"$" {
lassign [parse_varname $bytes $p $endpos] vtok next
if {$vtok eq ""} {
#a $ with no variable name following becomes its own
#text token (it does not merge with adjacent text)
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
lappend tokens [list text [list $p 1] {}]
incr p
set textStart $p
} else {
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
lappend tokens $vtok
set p $next
set textStart $p
}
}
"\[" {
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
set q [expr {$p + 1}]
while {1} {
lassign [parse_command_bytes $bytes $q $endpos 1] cs cl ks kl q2 term tr
set q $q2
if {$term eq "bracket"} {
incr q
break
}
if {$term eq "eof"} {
error "missing close-bracket"
}
#nl or semi: further commands inside the brackets
}
lappend tokens [list command [list $p [expr {$q - $p}]] {}]
set p $q
set textStart $p
}
default {
incr p
}
}
}
if {$p > $textStart} {
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}]
}
return [list $tokens $p]
}
proc parse_varname {bytes pos endpos} {
#pos at '$'. Returns {token nextpos}, or {"" pos} when the $ does not
#introduce a variable (plain text).
set p [expr {$pos + 1}]
if {$p >= $endpos} {
return [list "" $pos]
}
set c [string index $bytes $p]
if {$c eq "\{"} {
#${name}: Tcl 8.x scans to the FIRST close brace (no escapes);
#Tcl 9 balances nested braces with backslash-escaped braces not
#counted (the backslash stays part of the name text).
variable TCL9
if {$TCL9} {
set level 1
set q [expr {$p + 1}]
while {1} {
if {$q >= $endpos} {
error "missing close-brace for variable name"
}
set c2 [string index $bytes $q]
switch -exact -- $c2 {
"\\" {
incr q 2
}
"\{" {
incr level
incr q
}
"\}" {
incr level -1
if {$level == 0} {
break
}
incr q
}
default {
incr q
}
}
}
set close $q
} else {
set close [string first "\}" $bytes $p]
if {$close < 0 || $close >= $endpos} {
error "missing close-brace for variable name"
}
}
set nametok [list text [list [expr {$p + 1}] [expr {$close - $p - 1}]] {}]
set next [expr {$close + 1}]
return [list [list variable [list $pos [expr {$next - $pos}]] [list $nametok]] $next]
}
set nameStart $p
while {$p < $endpos} {
set c [string index $bytes $p]
if {[string match {[a-zA-Z0-9_]} $c]} {
incr p
continue
}
if {$c eq ":" && $p + 1 < $endpos && [string index $bytes $p+1] eq ":"} {
incr p 2
while {$p < $endpos && [string index $bytes $p] eq ":"} {
incr p
}
continue
}
break
}
set nameLen [expr {$p - $nameStart}]
if {$p < $endpos && [string index $bytes $p] eq "("} {
#array element - name may be empty. Index parsed for
#substitutions, terminated by the first top-level close paren.
incr p
set idxstart $p
lassign [parse_tokens $bytes $p $endpos index 0] idxtokens p
if {$p >= $endpos || [string index $bytes $p] ne ")"} {
error "missing )"
}
if {[llength $idxtokens] == 0} {
#an empty index still carries one empty text token
set idxtokens [list [list text [list $idxstart 0] {}]]
}
incr p
set nametok [list text [list $nameStart $nameLen] {}]
set subnodes [list $nametok]
lappend subnodes {*}$idxtokens
return [list [list variable [list $pos [expr {$p - $pos}]] $subnodes] $p]
}
if {$nameLen == 0} {
return [list "" $pos]
}
set nametok [list text [list $nameStart $nameLen] {}]
return [list [list variable [list $pos [expr {$p - $pos}]] [list $nametok]] $p]
}
proc list_elements {bytes start end} {
#Scan the byte range as a Tcl list (TclFindElement semantics) for
#parse-time {*} literal expansion. Returns a list of
#{elemstart elemlen textstart textlen} with text excluding one level
#of brace/quote enclosure. Errors if the range is not a valid list.
set p $start
set out [list]
while {1} {
while {$p < $end && [string index $bytes $p] in [list " " \t \n \r \f \v]} {
incr p
}
if {$p >= $end} {
break
}
set c [string index $bytes $p]
set estart $p
set kind bare
if {$c eq "\{"} {
set kind brace
set level 1
incr p
set tstart $p
while {1} {
if {$p >= $end} {
error "unmatched open brace in list"
}
set c2 [string index $bytes $p]
if {$c2 eq "\\"} {
incr p 2
continue
}
if {$c2 eq "\{"} {
incr level
} elseif {$c2 eq "\}"} {
incr level -1
if {$level == 0} {
break
}
}
incr p
}
set tlen [expr {$p - $tstart}]
incr p
if {$p < $end && [string index $bytes $p] ni [list " " \t \n \r \f \v]} {
error "list element in braces followed by \"[string index $bytes $p]\" instead of space"
}
} elseif {$c eq "\""} {
set kind quote
incr p
set tstart $p
while {1} {
if {$p >= $end} {
error "unmatched open quote in list"
}
set c2 [string index $bytes $p]
if {$c2 eq "\\"} {
incr p 2
continue
}
if {$c2 eq "\""} {
break
}
incr p
}
set tlen [expr {$p - $tstart}]
incr p
if {$p < $end && [string index $bytes $p] ni [list " " \t \n \r \f \v]} {
error "list element in quotes followed by \"[string index $bytes $p]\" instead of space"
}
} else {
set tstart $p
while {$p < $end} {
set c2 [string index $bytes $p]
if {$c2 in [list " " \t \n \r \f \v]} {
break
}
if {$c2 eq "\\"} {
incr p 2
continue
}
incr p
}
if {$p > $end} {
set p $end
}
set tlen [expr {$p - $tstart}]
}
#Parse-time literal expansion only applies when every element's
#value equals its source bytes. A backslash in a bare or quoted
#element (or backslash-newline in a braced one) needs collapsing,
#so the whole expansion stays a runtime matter (expand node).
set seg [string range $bytes $tstart [expr {$tstart + $tlen - 1}]]
if {$kind eq "brace"} {
if {[string first "\\\n" $seg] >= 0} {
error "list element needs backslash collapsing"
}
} else {
if {[string first "\\" $seg] >= 0} {
error "list element needs backslash collapsing"
}
}
lappend out [list $estart [expr {$p - $estart}] $tstart $tlen]
}
return $out
}
}
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::tclparser
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
package provide punk::tclparser [tcl::namespace::eval punk::tclparser {
variable pkg punk::tclparser
variable version
set version 999999.0a1.0
}]
## Ready
return

4
src/modules/punk/tclparser-buildversion.txt
Unescape View File

@ -0,0 +1,4 @@
0.1.0
#First line must be a tcl package version number
#all other lines are ignored.
#0.1.0 - initial pure-Tcl engine (G-070): parse command/getstring/countnewline over byte-view scanning
Write Preview
Loading…
Cancel
Save