#! /bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
[yclprefix] proc alias aliases [yclprefix] proc aliases
package require {ycl ns join}
alias join [yclprefix] ns join
aliases {
{ycl eval} {
upcall
}
}
package require {ycl flow depends}
interp alias {} [namespace current]::dlet {} [yclprefix] flow let
interp alias {} [namespace current]::depends {} [yclprefix] flow depends
variable [join doc $] {
description {
In a future version of Tcl where is a list
an empty string at the beginning of the list will indicate
resolution from the global namespace
if the first item is itself list it is auto-expanded and the name
is resolved relative to the caller's namespace
for example, a variable named the empty string would look like this
{{}}
}
}
proc $ args {
lassign $args first
if {[string is list $first] && [llength $first]} {
set args [lreplace $args 0 0 {*}$first]
set args [join {*}$args[set args {}]]
uplevel 1 [list ::set $args]
} else {
set args [join {*}$args[set args {}]]
set $args
}
}
proc constant varname {
upvar $varname var
# read now so as not to set off the trace later
set value $var
uplevel 1 [list ::trace add variable $varname write [list ::apply [list {value var1 var2 ops} {
error [list {read-only variable} $var1]
} [namespace current]] $value]]
}
namespace ensemble create -command is -map {
upvar {{is upvar}}
}
proc {is upvar} name {
expr {![catch {
upcall 1 upvar 0 $name $name
}]}
}
variable doc::let {
description {
updates the value of a variable when the variable is read and the value
of one of the variables it depends on has changed
arguments
varname
description
the name of the variable to manage
last argument
the body of a routine that returns a new value for the variable
second through second-to-last arguments
each argument is a list of
the name of a variable that the tracked variable depends on
optional
a name to give the value of variable in the routine
that updates the managed variable
the empty string indicates that the variable value
should not be passed to the routine
if the named variable is a local variable
the managed variable is unset when the named
variable is unset
}
}
proc let {varname args} {
variable let
variable namespace
set id [list [info cmdcount]]
lassign [uplevel 1 [list [namespace which dlet] [
list $namespace tail] $args]] spec body info
set letget [namespace which let_get]
foreach {alias target} $spec[set spec {}] {
lassign [uplevel 1 [list $letget $target]] fulltarget getcmd
lappend spec $alias $getcmd
dict set info $alias target $fulltarget
dict set info $alias get $getcmd
}
dict set let $id $info
foreach {key val} $info {
uplevel 1 [list trace add variable $target unset [
list [namespace which apply] [list {varname name1 name2 op} {
uplevel 1 [list [namespace which unset] $varname]
}] $varname]]
}
set ns [uplevel 1 $namespace current]
set routine [list [namespace which let_make] $id $ns $spec $body]
uplevel 1 [list [namespace which trace] add variable $varname read $routine]
uplevel 1 [list [namespace which trace] add variable $varname unset [list [
namespace which letdelete] $id]]
return $id
}
proc let_arrayget {name1 name2} {
set array [uplevel 1 [
list [namespace which array] get $name1]]
if {[dict size $array] == 0} {
if {[uplevel 1 [list [
namespace which namespace ] which -variable $name1]] eq {}} {
# [array get] doesn't return an error of the variabel
# doesn't exist
# so do it here
error [list {no such variable} $name1]
}
}
dict get $array $name2
}
proc let_get target {
variable namespace_current
set arrayvar 0
switch [llength $target] {
1 {
if {[regexp {^([^(]+)\((.*)\)$} $target -> tname1 tname2]} {
set arrayvar 1
} else {
set tname1 [lindex $target 0]
}
}
2 {
lassign $target tname1 tname2
set arrayvar 1
}
default {
error [list {target should be a list containing 1 or 2 items}]
}
}
if {$tname1 in [uplevel 1 [namespace which info] locals]} {
set level #[expr {[info level] - 1}]
if {$arrayvar} {
set getcmd [list [namespace which uplevel] $level [list [
namespace which let_arrayget] $tname1 $tname2]]
} else {
set xvar [list [namespace which set] $tname1]
set getcmd [list [namespace which uplevel] $level $xvar]
}
set fulltarget $target
} else {
if {[string match ::* $target]} {
set fulltarget $target
} else {
set ns [uplevel 1 $namespace_current]
set relns [namespace qualifiers $target]
if {$ns eq {::}} {
set fulltarget ::$target
} else {
set fulltarget ${ns}::$target
}
if {$relns eq {}} {
set targetns $ns
} else {
set target [namespace tail $target[set target {}]]
set targetns $ns::$relns
}
}
if {$arrayvar} {
set getcmd [list [namespace which let_arrayget] $tname1 $tname2]
} else {
set getcmd [list [namespace which set] $fulltarget]
}
}
list $fulltarget $getcmd
}
proc let_make {id ns args cmd name1 name2 op} {
lassign [depends $args [namespace current]::let $id] changed xargs xvals
if {$changed} {
upvar $name1 var
set var [uplevel 1 [list [namespace which ::apply] [
::list $xargs $cmd $ns] {*}$xvals]]
}
}
proc let_target target {
}
proc letinfo unique {
variable let
set res {}
if {[dict exists $let $unique]} {
set res [dict get $let $unique]
} else {
}
return $res
}
proc setmap {text script} {
package require {ycl parse tcl}
[yclprefix] proc alias [yclprefix]::parse::tcl::commands::commands
proc setmap {text script} {
set res {}
foreach command [commands $script] {
set command [lassign $command[set command {}] varname]
upvar $varname var
set var [string map $command $text]
}
return
}
tailcall setmap $text $script
}
variable namespace [namespace which namespace]
variable namespace_current [list [namespace which namespace] current]
variable let {}