#! /bin/env tclsh
package require {ycl chan}
package require {ycl coro call}
namespace import [yclprefix]::coro::call::bye
namespace import [yclprefix]::coro::call::hi
namespace import [yclprefix]::coro::call::autocall_notrace
namespace import [yclprefix]::coro::call::last
namespace import [yclprefix]::coro::call::reply
#package require {ycl dev time}
#namespace import [yclprefix]::dev::time::timed
package require {ycl iter async}
namespace import [yclprefix]::iter::async
namespace import [yclprefix]::iter::async::items
namespace import [yclprefix]::iter::async::prepend
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace eval doc {}
proc accept {} {
upvar #1 cmd cmd splitliteral splitliteral
while 1 {
set args [lassign $cmd name]
switch $name {
char {
break
}
next {
break
}
nested {
nested {*}$args
set cmd [reply {}]
}
splitliteral {
if {[llength $args]} {
set splitliteral [expr {!![lindex $args 0]}]
}
set cmd [reply $splitliteral]
}
default {
error [list {unknown command name} $name]
}
}
}
}
proc arrayidx {} {
upvar #1 read read value value wordmode wordmode
readchan 1
switch $read {
) {
emit literal
set value $read
emit arrayidxend
set wordmode [lrange $wordmode[set wordmode {}] 0 end-1]
tailcall [lindex $wordmode end]
}
\f - \n - \r - \t - \v - { } - ; {
append value $read
tailcall arrayidx
}
default {
pushback $read
tailcall word
}
}
}
proc brace {} {
upvar #1 cmd cmd read read splitliteral splitliteral value value
set braceleft 1
set braceright 0
while 1 {
readchan 1
switch $read {
\\ {
set part $read
readchan 1
switch $read {
\n {
emit literal
set value $part
emit escape
set value $read
emit escapenewline
whacknewline
}
default {
append value $part
if {$cmd eq {char} || $splitliteral} {
emit literal
}
append value $read
if {$cmd eq {char} || $splitliteral} {
emit literal
}
}
}
}
\{ {
incr braceleft
if {$cmd eq {char} || $splitliteral} {
emit literal
}
append value $read
}
\} {
if {[incr braceright] == $braceleft} {
emit literal
set value $read
emit braceend
break
} else {
if {$cmd eq {char} || $splitliteral} {
emit literal
}
append value $read
}
}
{} {
error [list {incomplete braced word} $value]
}
default {
if {$cmd eq {char}} {
append value $read
emit literal
} elseif {$splitliteral} {
if {
(
! [string is wordchar -strict $read]
&&
! [string is space -strict $read]
)
||
(
[string is space -strict $value]
&&
![ string is space -strict $read]
)
||
(
![string is space -strict $value]
&&
[ string is space -strict $read]
)
||
(
[string is wordchar -strict $value]
&&
![ string is wordchar -strict $read]
)
||
(
![string is wordchar -strict $value]
&&
[ string is wordchar -strict $read]
)
} {
emit literal
}
append value $read
} else {
append value $read
}
}
}
}
tailcall wordstart
}
proc comment {} {
upvar #1 cmd cmd cmdstart cmdstart read read value value
while 1 {
readchan 1
switch $read {
\n {
if {$whack % 2} {
append value $read
if {$cmd eq {char}} {
emit literal
}
} else {
emit literal
set value $read
emit cmd
set cmdstart 1
tailcall wordstart
}
}
\\ {
incr whack
append value $read
}
default {
set whack [expr 0]
append value $read
}
}
}
}
proc script {} {
upvar #1 chan chan cmd cmd endembedded endembedded iter iter \
nestedleft nestedleft nestedright nestedright
set current [info coroutine]
set saved [info coroutine]_[info cmdcount]_saved
rename $current $saved
set delete [list apply {{saved args} {
rename $saved {}
}} $saved]
try {
if {[info exists chan]} {
lappend newargs chan $chan
} elseif {[info exists iter]} {
lappend newargs iter $iter
} else {
error [list {need one of} {iter chan}]
}
lappend newargs previous $saved nested [
list $nestedleft $nestedright] delete $delete
set coro [new [namespace qualifiers $current] {*}$newargs]
} on error {eres eopts} {
rename $saved $current
return -options $eopts $eres
}
trace add command $current delete $delete
emit script
}
proc bracevar {} {
namespace upvar [namespace qualifiers [info coroutine]] bracevar_table {}
upvar #1 read read value value wordmode wordmode
while 1 {
readchan 1
switch -glob $read {
\} {
set varname $value
set idx [string first $(array_start) $varname]
if {$idx >= 0 && [string index $varname end] == $(array_end)} {
set value [string range $varname 0 $idx-1]
emit literal
set value $(array_start)
emit arrayidxstart
set value [string range $varname $idx+1 end-1]
emit arrayidx
emit literal
set value $(array_end)
emit arrayidxend
} else {
emit literal
}
set value $read
emit varbraceend
tailcall [lindex $wordmode end]
}
{} {
error [list {incomplete braced varname}]
}
default {
append value $read
}
}
}
}
proc nested {left right} {
upvar #1 nestedleft nestedleft nestedright nestedright
set nestedleft $left
set nestedright $right
return
}
variable doc::new {
description {
create a new script parser
}
args {
chan {
description {
A channel from which to to read the script to be parsed.
}
validate {![info exists iter] && ![info exists parsed]}
}
delete {
description {
Used internally to pass the deletion trace to the subordinate
coroutine .
}
default {}
}
nested {
description {
A pair of strings that enclose a nested script
}
default {list \[ ]}
process {nested {*}$nested}
}
previous {
description {
The name of the coroutine that is passing the script that the
script to be parsed is embedded in.
}
default {}
}
replace {
description {
Used internally when the parser creates a sub-parser to tell
the sub-parser its name.
}
default {lindex [namespace current]::[info cmdcount]_stream}
}
endembedded {
description {
A character that ends the current embedded script
}
default {}
}
splitliteral {
description {
break up literals along characters that are special to Tcl
}
default {lindex 0}
}
parsed {
description {
A previous parser from which to draw lexed substrings
}
default {}
validate {![info exists chan] && ![info exists iter]}
constrain {[info exists interp]}
}
}
}
proc new {name args} {
set coroname [uplevel 1 [list ::namespace eval $name [list ::coroutine coro ::apply [list args {
checkargs $doc::new {*}$args
if {![info exists previous]} {
apply [list streamns {
variable buffer {}
variable bracevar_table
array set bracevar_table [array get [uplevel 1 {namespace current}]::bracevar_table]
} [namespace qualifiers [info coroutine]]] [namespace current]
}
set charmode 0
set cmdstart 1
set end 0
if {![info exists endembedded]} {
# $endembedded is set just once when the script begins, and is
# never changed.
set endembedded $nestedright
}
set tokens {}
set value {}
if {![info exists previous]} {
trace add command [info coroutine] delete [list apply {{ns args} {
namespace delete $ns
}} [namespace qualifiers [info coroutine]]]
}
set cmd [hi]
accept
wordstart
} [namespace current]] {*}$args]]]
set cmdname [namespace qualifiers $coroname]
if {![info exists previous]} {
autocall_notrace $cmdname $coroname
}
return $cmdname
}
proc pushback_iter data {
upvar #1 iter iter
if {$data ne {}} {
set res [$iter prepend $data]
}
}
proc pushback data {
namespace upvar [namespace qualifiers [info coroutine]]
upvar #1 chan chan
{*}$chan prepend $data
}
proc quote {} {
upvar #1 read read value value
readchan 1
switch $read {
\f - \v - \t - { } - \n - \; {
append value $read
tailcall quote
}
\" {
emit literal
set value $read
emit quoteend
tailcall wordstart
}
default {
pushback $read
tailcall word
}
}
}
proc readchan count {
upvar #1 chan chan read read
set read [{*}$chan read $count]
return $read
}
proc emit args {
upvar #1 cmd cmd delete delete end end previous previous \
value value
if {$end && [info exists previous]} {
set current [info coroutine]
trace remove command $current delete $delete
rename $current {}
rename $previous $current
}
if {[llength $args] > 1 || $value ne {}} {
if {$value ne {}} {
lappend args $value[set value {}]
}
set cmd [reply $args]
accept
}
if {$end} {
bye
}
return
}
variable doc::tokens {
description {
yield tokens from the channel
}
}
proc tokens {} {
upvar #1 char char reader readers source source token token \
type type
while 1 {
set res [{*}[lindex $readers end]]
switch $res {
feed {
set char [read $source 1]
}
punt {
}
default {
error [list {don't know how to respond to} $res]
}
}
}
}
proc var {part} {
upvar #1 read read value value wordmode wordmode
readchan 2
pushback $read
switch -regexp -matchvar matched $read {
{^(\()} - ^(::) - ^[0-9A-Za-z_] {
emit literal
set value $part
emit var
}
default {
append value $part
tailcall [lindex $wordmode end]
}
}
while 1 {
readchan 1
switch -glob $read {
( {
emit literal
set value $read
emit arrayidxstart
lappend wordmode arrayidx
tailcall [lindex $wordmode end]
}
: {
set colons $read
while 1 {
readchan 1
switch $read {
: {
append colons $read
}
default {
pushback $read
break
}
}
}
if {[string length $colons] < 2} {
pushback $colons
break
} else {
append value $colons
}
}
[0-9A-Za-z_] {
append value $read
}
default {
emit literal
pushback $read
break
}
}
}
tailcall [lindex $wordmode end]
}
variable varreadertable {
\{ varbracesreader
( arrayelemreader
}
proc varreader {} {
variable varreadertable
set res {}
set current {}
for {} {$cursor < [llength $word]} {incr cursor} {
set char [lindex $word $cursor]
switch -glob $char {
( {
lappend current $char
set new [dict get $varreadertable $char]
incr cursor
lappend current [$new $word $cursorname]
if {$char eq {(}} {
lappend current )
} else {
lappend current \}
}
#adjust for upcoming loop incr
incr cursor -1
}
[0-9A-Za-z_:] {
append res $char
}
default {
break
}
}
}
if {$current ne {}} {
lappend res $current
}
return $res
}
proc whacknewline {} {
upvar #1 read read value value
while 1 {
readchan 1
switch $read {
\f - \v - \t - { } {
append value $read
}
default {
# Don't worry about catching eof here . The
# larger part of this function deals with it .
emit term
pushback $read
break
}
}
}
}
proc word {} {
upvar #1 cmd cmd end end endembedded endembedded \
previous previous nestedleft nestedleft nestedright nestedright \
read read tokens tokens value value wordmode wordmode
readchan 1
# $nesetedleft and $nestedright should come first so
# that they override any hard-coded tokens.
if {[info exists previous] && $read eq $endembedded} {
emit literal
set value $read
if {[info exists previous]} {
set end 1
emit scriptend
} else {
append value $read
tailcall [lindex $wordmode end]
}
}
switch $read [list \
$nestedleft {
emit literal
set value $read
script
tailcall [lindex $wordmode end]
} $ {
# Don't issue the token here because the following character (or
# lack thereof) must be inspected to determine whether it's a variable
# substitution .
append part $read
set varname {}
readchan 1
if {$read eq "\{"} {
emit literal
set value $part
emit var
set value $read
emit varbrace
bracevar
} else {
pushback $read
var $part
}
} \\ {
emit literal
set value $read
emit escape
readchan 1
switch -glob $read {
\n {
set value $read
emit escapenewline
whacknewline
}
a - b - f - r - t - v - \\ {
set value $read
emit term
}
[0-7] {
set value $read
readchan 2
switch -regexp -matchvar matched $read {
{([0-7]{1,2})(.*)} {
append value [lindex $matched 1]
# This line is written with the idea that escape
# may be programmable
pushback [lindex $matched 2]
emit octal
}
}
pushback [lindex $matched 2]
emit octal
}
x {
set value $read
emit hex
readchan 2
switch -regexp -matchvar matched $read {
{([0-9A-Fa-f]{1,2})(.*)} {
append value [lindex $matched 1]
# This line is written with the idea that escape
# may be programmable
pushback [lindex $matched 2]
emit term
}
}
}
u {
set value $read
emit unicode4
readchan 4
switch -regexp -matchvar matched $read {
{([0-9A-Fa-f]{1,4})(.*)} {
set value [lindex $matched 1]
# This line is written with the idea that escape
# may be programmable
pushback [lindex $matched 2]
emit term
}
}
}
U {
set value $read
emit unicode8
readchan 4
switch -regexp -matchvar matched $read {
{([0-9A-Fa-f]{1,4})(.*)} {
append value [lindex $matched 1]
# This line is written with the idea that escape
# may be programmable
pushback [lindex $matched 2]
emit term
}
}
}
default {
set value $read
emit term
}
}
tailcall [lindex $wordmode end]
} {} {
emit literal
tailcall wordstart
} \n - \f - \r - \t - \v - { } - \; {
if {$value ne {}} {
emit literal
}
pushback $read
tailcall wordstart
} default {
append value $read
if {$cmd eq {char}} {
emit literal
}
#emit literal
tailcall [lindex $wordmode end]
}
]
}
proc wordstart {} {
upvar #1 cmdstart cmdstart end end \
nestedleft nestedleft nestedright nestedright \
previous previous read read readers readers \
token token type type value value wordmode wordmode
readchan 1
set wordmode word
switch $read [list \
$nestedleft {
#This must come first in order to override other hard-coded tokens
#in the remainder of the switch
emit space
pushback $read
} \" {
emit space
set value $read
emit quote
lappend wordmode quote
} # {
if {$cmdstart} {
set value $read
emit comment
tailcall comment
}
} \{ {
emit space
set value $read
emit brace
lappend wordmode brace
} \f - \r - \t - \v - { } {
append value $read
tailcall wordstart
} \n - \; {
emit space
set value $read
emit cmd
set cmdstart 1
tailcall wordstart
} {} {
set end 1
emit space
return
} default {
emit space
pushback $read
}
]
emit space
tailcall [lindex $wordmode end]
}
variable bracevar_table
array set bracevar_table {
array_start (
array_end )
}
package require {ycl parse tcl stream critcl}