How the hell do you pronounce my nick? In four syllabels: Za-ru-ti-an
Stuff I am thinking about implementing/doing (DONT PUT PRESURE ON ME PLEASE!):
That might take a while because I have to dig the up from my old CRT iMac. (29.mars 2006) Which I still havent got around to do (14. oktober 2006)
my version of apply.
package ifneeded zarutian/apply 1.0 {
# inlined package
package require Tcl 8.5
proc apply {fun args} {
# no variable are used in this procedure
# due to possibility of var conflict
if {[llength [lindex [info level 0] 1] != 2} {
error "cant interpret \"[
lindex [info level 0] 1]\" as an anonymous function"
}
bind_vars [lindex [info level 0] 1 0] [lrange [info level 0] 2 end]
eval [lindex [info level 0] 1 1]
}
proc bind_vars {argl args} {
set counter 0
foreach item $argl {
if {[llength $item] == 2} {
set var [lindex $item 0]
if {[llength $args] <= $counter} {
set val [lindex $item 1]
} else {
set val [lindex $args $counter]
}
} else {
set var $item
set val [lindex $args $counter]
}
uplevel 1 [list set $var $val]
incr counter
}
}
package provide zarutian/apply 1.0
}Improved version by kruzalex, should work with more variables and of course for tcl 8.4:
proc apply {fun args} {
if {[llength [lindex [info level 0] 1]] != 2} {
error "cant interpret \"[
lindex [info level 0] 1]\" as an anonymous function"
}
bind_vars [lindex [info level 0] 1 0] [lrange [info level 0] 2 end]
eval [lindex [info level 0] 1 1]
}
proc bind_vars {argl args} {
set counter 0
foreach item $argl {
set var $item
set val [eval lindex $args $counter]
uplevel 1 [list set $var $val]
incr counter
}
}
apply {x {expr $x+$x}} 5
apply {{x y} {expr hypot($x,$y)}} 1 2extends RS'es thingy[L1 ] to work as a minmal but handy Object-Orientation system
package ifneeded zarutian/thingy 1.3 {
# inlined package
package require Tcl 8.5
proc thingy {name} {
if {[lsearch -exact [info commands] $name] != -1} {
error "a command/thingy with $name already exists!"
}
namespace eval ::things::[set name] {}
proc ::things::[set name]::self {} "return [namespace current]::$name"
proc ::things::[set name]::initialize {args} {}
proc ::things::[set name]::destroy {args} {
namespace delete [namespace current]
}
proc ::things::[set name]::dispatch {args} {
return [uplevel 1 $args]
}
proc $name args "namespace eval ::things::[set name] dispatch \$args"
}
thingy maker
maker variable templates {}
maker variable instanced {}
maker proc template {name body} {
variable templates
dict set templates $name $body
return
}
maker proc new {name {args {}}} {
variable templates
if {![dict exists $templates $name]} {
error "maker: no such template $name"
}
variable instanced
if {![dict exists $instanced $name]} {
dict set instanced $name 0
}
dict incr instanced $name
set i [set name][dict get $instanced $name]
thingy $i
$i eval [dict get $templates $name]
$i initialize {*}[set args]
return $i
}
package provide zarutian/thingy 1.3
}Serializes an namespace (all the variables, all the procedures, all the traces on variables and procedures and all the children of the namespace). can be used to snapshot things (all of them or just few) from package zarutian/thingy above.
package ifneeded zarutian/serialize_namespace 1.0 {
# inlined package
package require Tcl 8.0
proc serialize_namespace {namespace} {
set memento "namespace eval [list $namespace]] \{\n"
# variables
foreach var [info vars [set namespace]::*] {
append memento { }
append memento "variable [list [namespace tail $var]]"
if {[info exists $var]} {
# how to get an variable's value without tripping any read
# traces is tricky
if {[array exists $var]} {
append memento "\narray set [
list [namespace tail $var]] [list [array get $var]]\n"
} else {
append memento " [list [set $var]]\n"
}
} else {
append memento \n
}
# traces on variables
foreach trace [trace info variable $var] {
append memento " "
append memento "trace add variable [namespace tail $var]"
append memento " [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
# procedures
foreach proc [info procs [set namespace]::*] {
append memento { }
append memento "proc [list [namespace tail $proc]] "
set args {}
foreach arg [info args $proc] {
if {[info default $proc $arg default]} {
lappend args [list $arg $default]
} else {
lappend args $arg
}
}
append memento "[list $args] [list [info body $proc]]\n"
# traces on execution of procedures
foreach trace [trace info execution $proc] {
append memento { }
append memento "trace add execution [namespace tail $proc]"
append memento " [list [lindex $trace 0]] [
list [lindex $trace 1]]\n"
}
# traces on commands
foreach trace [trace info command $proc] {
append memento { }
append memento "trace add command [namespace tail $proc]"
append memento " [list [lindex $trace 0]] [
list [lindex $trace 1]]\n"
}
}
append memento \}\n
# children namespaces
foreach child [namespace children $namespace] {
append memento [raw_serialize $child]
}
return $memento
}
package provide zarutian/serialize_namespace 1.0
}some common list manipulation procedures.
package ifneeded zarutian/list_extension 1.0 {
# inlined package
package require Tcl 8.0
proc lexclude {list excluded} {
# isnt this just an [lfilter]?
set result {}
foreach item $list {
if {[lsearch -exact $excluded $item] == -1} {
lappend result $item
}
}
return $result
}
proc lcommon {a b} {
# isnt this just an [lfilter]?
set result {}
foreach item $a {
if {[lsearch -exact $b $item] != -1} {
lappend result $item
}
}
return $result
}
proc lrotate {list} { return [join [list [lrange $list 1 end] [
lindex $list 0]]] }
package provide zarutian/list_extension 1.0
}compares two trees of file folders for commonality and diffrences.
package ifneeded zarutian/dir_tree_compariator 1.0 {
# inlined package
package require Tcl 8.0
package require zarutian/list_extension 1.0
namespace eval ::zarutian::dir_tree_compariator {}
proc ::zarutian::dir_tree_compariator::dir_diff {old new} {
set result [list]
set old_items [glob -nocomplain -tails -directory $old -- *]
set new_items [glob -nocomplain -tails -directory $new -- *]
set added [lexclude $new_items $old_items]
set common [lcommon $old_items $new_items]
set removed [lexclude $old_items $new_items]
foreach item $added {
lappend result [list new [file join $new $item]]
}
foreach item $common {
set old_item [file join $old $item]
set new_item [file join $new $item]
if {[file isfile $old_item] && [file isfile $new_item]} {
if {[same_file? $old_item $new_item]} {
# lappend result [list same_file $old_item $new_item]
} else {
lappend result [list diff_file $old_item $new_item]
}
} else {
}
if {[file isdirectory $old_item] && [file isdirectory $new_item]} {
foreach item [dir_diff $old_item $new_item] {
lappend result $item
}
} else {
}
}
foreach item $removed {
lappend result [list del [file join $new $item]]
}
# todo: check if an pair of {new <path>} {del <path>} is just an move
# by checking if they mean the same file (same contents)
return $result
}
proc ::zarutian::dir_tree_compariator::same_file? {file1 file2} {
# returns yes or no
if {[file size $file1] != [file size $file2]} { return no }
set fd1 [open $file1 r]
set fd2 [open $file2 r]
fconfigure $fd1 -encoding binary -translation binary
fconfigure $fd2 -encoding binary -translation binary
while {![eof $fd1] && ![eof $fd2]} {
if {![string equal [read $fd1 1] [read $fd2 1]]} {
close $fd1
close $fd2
return no
}
}
close $fd1
close $fd2
return yes
}
package provide zarutian/dir_tree_compariator 1.0
}package require Tcl 8.5
proc advance {state} {
if {![dict exists $state pointer]} { dict set state pointer 0 }
if {![dict exists $state results]} { dict set state results {} }
if {![dict exists $state returnstack]} { dict set state returnstack {} }
if {![dict exists $state variables]} { dict set state variables {} }
if {![dict exists $state commands]} { error "commands missing" }
if {![dict exists $state code]} { error "code missing" }
if {[dict get $state pointer] < [llength [dict get $state code]]} {
set state [lindex [exec_prim return {} $state] end]
}
set cmd&args [lindex [dict get $state code] [dict get $state pointer]]
set cmd&args [string map [dict get $state results] [set cmd&args]]
set cmd [lindex [set cmd&args] 0]
set args [lrange [set cmd&args] 1 end]
if {[dict exists $state commands $cmd]} {
if {![dict exists $state commands $cmd type]} {
error "type of command $cmd missing"
}
if {![dict exists $state commands $cmd contents]} {
error "contents of command $cmd missing"
}
if {[string equal "combo" [dict get $state commands $cmd type]]} {
# push current continuation onto returnstack
set t1 [dict new]
dict set t1 code [dict get $state code]
dict set t1 pointer [expr [dict get $state pointer] +1]
dict set t1 results [dict get $state results]
dict set t1 variables [dict get $state variables]
dict lappend state returnstack $t1
# stilla state fyrir að keyra innihald procs
dict set state code [dict get $state commands $cmd contents]
dict set state pointer -1; # þarf að vera -1 út af autoincr
dict set state variables {}
dict set state results {}
} elseif {[string equal "prim" [dict get $state commands $cmd type]]} {
set t1 [exec_prim [
dict get $state commands $cmd contents] $args $state]
set state [lindex $t1 end]
dict set state results \[[dict get $state pointer]\] [lindex $t1 0]
} else {
error "unknown command type [dict get $state commands $cmd type]"
}
} else {
# unknown command handling
if {![dict exists $state commands unknown]} {
set state [lindex [
exec_prim error "unknown command $cmd" $state] end]
} else {
# invoke the unknown command
set t1 [exec_prim eval [list unknown [set cmd&args]] $state]
set state [lindex $t1 end]
dict set state results \[[dict get $state pointer]\] [lindex $t1 0]
}
}
dict incr state pointer; # autoincr
return $state
}
proc exec_prim {cmd argus state} {
set result {}
if {$cmd eq {return}} {
# return from a proc command
if {[llength $argus] == 1} {
set t1 [lindex $argus 0]
} else {
set t1 [get_last_result [dict get $state results]]
}
dict set state code [dict get [lindex [dict get $state returnstack] end] code]
dict set state pointer [dict get [lindex [dict get $state returnstack] end] pointer]
dict set state results [dict get [lindex [dict get $state returnstack] end] results]
dict set state variables [dict get [lindex [dict get $state returnstack] end] variables]
dict set state returnstack [lrange [dict get $state returnstack] 0 end-1]
set t2 [expr [dict get $state pointer] -1]
dict set state results \[[set t2]\] [set t1]
} elseif {$cmd eq {<}} {
# comparison
if {[llength $argus] != 2} {
set state [lindex [exec_prim error "wrong # of args" $state] end]
}
if {![string is digit [lindex $argus 0]] || ![string is digit [
lindex $argus 1]]} {
set state [lindex [
exec_prim error "arguments must be numeric" $state] end]
}
# not done; was here when stopped
} elseif {$cmd eq "eval"} {
} elseif {$cmd eq "error"} {
} elseif {$cmd eq "+"} {
} elseif {$cmd eq "-"} {
} elseif {$cmd eq "/"} {
} elseif {$cmd eq "%"} {
} elseif {$cmd eq "&"} {
} elseif {$cmd eq "set"} {
if {([llength $argus] < 1) || (2 < [llength $argus])} {
set state [lindex [exec_prim error "wrong # of args" $state] end]
} else {
if {[llength $argus] == 2} {
dict set state variables [lindex $argus 0] [lindex $argus 1]
set result [lindex $argus 1]
} else {
set result [dict get $state variables [lindex $argus 0]]
}
}
} elseif {$cmd eq "get"} {
if {[llength $argus] != 1} {
set state [lindex [exec_prim error "wrong # of args" $state] end]
} else {
}
} elseif {$cmd eq {args}} {
} else {
error "unknown prim $cmd"
}
return [list $result $state]
}
proc get_last_result {results} {
return [dict get $results [lindex [lsort [dict keys $results]] end]]
}
proc translate {script} {
set code {}
return $code
}
package require Tcl 8.5
# definitions
# <name>
# type primitive / script
# data identifier / code
# frame
# type subroutine / catcher / loop / {}
# code
# code_pointer
# invocation
# result
# returnstack
# <frame>
# package require zarutian/generic 1.0
proc @ {name} {
upvar [set name] [set name]
return [set [set name]]
}
proc repeat {body keyword condition} {
if {$keyword eq {until}} {
set condition !([set condition])
} elseif {$keyword eq {while}} {
# left empty on purpose
} else {
error "expected: until or while as a keyword between the body and the condition"
}
uplevel 1 $body
while {[uplevel 1 [list expr $condition]]} {
uplevel 1 $body
}
}
# package require zarutian/thingy 1.3
proc thingy name {
set id thing[incr ::things::counter]
namespace eval ::things::[@ id] {
proc dispatch args {uplevel 1 [@ args]]}
proc destroy {} {
namespace delete [namespace current]
}
proc serialize {} {error "implementation not yet gotten of usb-stick"}
}
proc [@ name] args "namespace eval ::things::[@ id] dispatch \[@ args\]"
[@ name] variable self [@ name]
}
thingy picol_interp
picol_interp proc init {} {
variable frame
variable definitions {
set {type primitive data set}
unset {type primitive data unset}
string {type primitive data string}
dict {type primitive data dict}
# and more to come
}
variable returnstack {}
dict set frame code {}
dict set frame code_pointer 0
dict set frame results {}
dict set frame type {}
dict set frame invocation {}
variable run_quota 1024
variable storage_quota [expr 128 * 1024]
variable actor
dict set actor addressbook {}
dict set actor addressbook_counter 0
dict set actor address {}
}
picol_interp init
picol_interp proc run {} {
# part of interface
variable run_quota
variable running [@ run_quota])
variable frame
while {0 < [@ running]} {
dict set frame results [dict get [@ frame] code_pointer] [
execute [spliceIn [lindex [dict get [@ frame] code] [
dict get [@ frame] code_pointer]] [
dict get [@ frame] results]]]
if {[llength [dict get [@ frame] code]] <= [
dict get [@ frame] code_pointer]} {popReturnstack}
incr code_pointer +1
incr running -1
}
}
picol_interp proc popReturnstack {} {
variable returnstack
if {[llength [@ returnstack]] == 0} {
# nothing more to run
variable running 0
return
}
variable frame
if {[llength [dict get [@ frame] code]] < [
dict get [@ frame] code_pointer]} {
dict set frame code_pointer [llength [dict get [@ frame] code]]
}
set value [dict [dict get [@ frame] results] [
expr [dict get [@ frame] code_pointer] - 1]]
set frame [lindex [@ returnstack] end]
set returnstack [lrange [@ returnstack] 0 end-1]
# code_pointer points to this command
dict set frame results [expr [dict get [@ frame] code_pointer] - 1] [
@ value]
return
}
picol_interp proc pushReturnstack {{extra {}} {
variable returnstack
variable frame
lappend returnstack [dict merge [@ frame] [@ extra]]
return
}
picol_interp proc newFrame overrides {
pushReturnstack
variable frame
dict set frame invocation [@ call]
dict set frame code_pointer -1; # because of the auto increasementer in method run
dict set frame results {}
dict set frame code {}
set frame [dict merge [@ frame] [@ overrides]]
}
picol_interp proc execute call {
variable definitions
set command [lindex [@ call] 0]
if {[dict exists [@ definitions] [@ command]]} {
set def [dict get [@ definitions] [@ command]]
if {![dict exists [@ def] type]} {
bgerror "type of definition missing"
return
}
if {[dict get [@ def] type] eq {script}} {
if {![dict exists [@ def] data]} {
bgerror "1 data missing from an definition"
return
}
if {![dict exists [@ def] execlist]} {
dict set definitions [@ command] execlist [translate [
dict get [@ def] data]]
}
newFrame [list code [dict get [@ definitions]
[@ command] execlist] type subroutine]
} elseif {[dict get [@ def] type] eq "primitive"} {
if {![dict exists [@ def] data]} {
bgerror "2 data missing from an definition"
return
}
switch -exact -- [dict get [@ def] data] {
{} {}
eval {
if {[llength [@ call]] != 2} {
execute [list error {wrong number of arguments}]
return
}
set script [lindex [@ call] 1]
newFrame [list code [translate [@ script]]]
return
}
set {
if {[llength [@ call]] != 3} {
execute [list error {wrong number of arguments}]
return
}
set varname [lindex [@ call] 1]
set value [lindex [@ call] 2]
variable frame
dict set frame variables [@ varname] [@ value]
}
unset {
if {[llength [@ call]] != 2} {
execute [list error {wrong number of arguments}]
return
}
if {[dict exists [@ frame] variables [@ varname]]} {
dict unset [@ frame] variables [@ varname]
} else {
execute [list error "no such variable [@ varname]"]
return
}
}
get {
if {[llength [@ call]] != 2} {
execute [list error {wrong number of arguments}]
return
}
variable frame
if {[dict exists [@ frame] variables [@ varname]]} {
return [dict get [@ frame] variables [@ varname]]
} else {
execute [list error "no such variable [@ varname]"]
return
}
}
string {
if {[llength [@ call] < 2} {
execute [list error {no subcommand given}]
return
}
switch -glob -- [lindex [@ call] 1] {
bytelength {
if {[llength [@ call]] != 3} {
execute [list error "wrong number of args. Should be: string bytelength <string>"]
return
}
return [string bytelength [lindex [@ call] 2]]
}
compare {
if {([llength [@ call]] < 4)
|| (7 < [llength [@ call]])} {
execute [list error "wrong number of args. Should be: string compare ?-nocase? ?-length <int>? <string1> <string2>"]
return
}
return [[join [list {string compare} [
lrange [@ call] 2 end]]]]
}
equal {
if {([llength [@ call]] < 4)
|| (7 < [llength [@ call]])} {
execute [list error "wrong number of args. Should be: string equal ?-nocase? ?-length <int>? <string1> <string2>"]
return
}
return [[join [list {string equal} [
lrange [@ call] 2 end]]]]
}
first {
if {([llength [@ call]] < 4)
|| (5 < [llength [@ call]])} {
execute [list error "wrong number of args. Should be: string first <sub string> <string> ?<startIndex>?"]
return
}
set startIndex 0
if {[llength [@ call] == 5} {
set startIndex [lindex [@ call] end]
}
return [string first [lindex [@ call] 2] [
lindex [@ call] 3] [@ startIndex]]
}
index {
if {[llength [@ call]] != 4} {
execute [list error "wrong number of args. Should be: string index <string> <charIndex>"]
return
}
return [string index [lindex [@ call] 2] [lindex [@ call] 3]
}; #ash
}
}
{string is} {}
{string last} {}
{string length} {}
{string map} {}
{string match} {}
{string range} {}
{string repeat} {}
{string replace} {}
{string tolower} {}
{string toupper} {}
{string totitle} {}
{string trim} {}
{string trimleft} {}
{string trimright} {}
{string wordend} {}
{string wordstart} {}
{dict} {}
{dict append} {}
{dict create} {}
{dict exists} {}
{dict filter} {}
{dict for} {}
{dict get} {}
{dict incr} {}
{dict info} {}
{dict keys} {}
{dict lappend} {}
{dict merge} {}
{dict remove} {}
{dict replace} {}
{dict set} {}
{dict size} {}
{dict unset} {}
{dict update} {}
{dict values} {}
{dict with} {}
if {
if {([llength [@ call]] != 3) && ([llength [@ call]] != 5)} {
execute [list error "if: wrong number of arguments should be: if <predicate> <true body> \[else <false body>\]"]
return
}
set predicate [lindex [@ call] 1]
set true-body [lindex [@ call] 2]
set false-body {}
if {([llength [@call]] == 5)
&& [string equal "else" [lindex [@ call] 3]]} {
set false-body [lindex [@ call] 4]
}
# reverse lookup to find the primitives required
foreach def [dict keys [@ definitions]] {
if {[dict get [@ definitions] [
@ def] type] eq {primitive}} {
if {[dict get [@ definitions] [
@ def] data] eq {__branch}} {
set __branch [@ def]
}
if {[dict get [@ definitions] [
@ def] data] eq {__jump}} {
set __jump [@ def]
}
}
}
if {![info exists __branch]} {
bgerror "__branch primitive not found!"; return
}
if {![info exists __jump]} {
bgerror "__jump primitive not found!"; return
}
set daCode [translate [@ predicate]]
set slot1 [llength [@ daCode]]
lappend daCode {<<<__branch primitive comes here>>>}
foreach item [translate [@ true-body] [
llength [@ daCode]]] {
lappend daCode [@ item]
}
if {[@ false-body] ne {}} {
set slot2 [llength [@ daCode]]
lappend daCode {<<<__jump primitive comes here>>>}
}
lset daCode [@ slot1] [list [@ __branch] [
expr [@ slot1] -1] [llength [@ daCode]]]
if {[@ false-body] ne {}} {
foreach item [translate [@ false-body] [
llength [@ daCode]]] {
lappend daCode [@ item]
}
lset daCode [@ slot2] [list [@ __jump] [
llength [@ daCode]]]
}
newFrame [list code [@ daCode] type if]
return
}
while {
if {[llength [@ call]] != 3} {
execute [list error "while: wrong number of arguments should be: while <predicate> <loop body>"]
return
}
set predicate [lindex [@ call] 1]
set loop-body [lindex [@ call] 2]
# reverse lookup to find the primitives required
foreach def [dict keys [@ definitions]] {
if {[dict get [@ definitions] [
@ def] type] eq {primitive}} {
if {[dict get [@ definitions] [
@ def] identifier] eq {__branch}} {
set __branch [@ def]
}
if {[dict get [@ definitions] [
@ def] identifier] eq {__jump}} {
set __jump [@ def]
}
}
}
if {![info exists __branch]} {
bgerror {__branch primitive not found!}
return
}
if {![info exists __jump]} {
bgerror {__jump primitive not found!}
return
}
set slot1 0
set daCode {<<<__jump primitive goes here>>>}
set dest1 [llength [@ daCode]]
foreach item [translate [@ loop-body] [
llength [@ daCode]]] {
lappend daCode [@ item]
}
lset daCode [@ slot1] [list [@ __jump] [
llength [@ daCode]]]
foreach item [translate [@ predicate] [
llength [@ daCode]]] {
lappend daCode [@ item]
}
set slot2 [llength [@ daCode]]
lappend daCode {<<<__branch primitive goes here>>>}
lappend daCode [list [@ __jump] [@ dest1]]
lset daCode [@ slot2] [list [@ __branch] [
expr [@ slot2] -1] [llength [@ daCode]]]
variable invocation
newFrame [list code [@ daCode] type loop continue [
@ dest1] break [llength [@ daCode]]]]
return
}
break {
variable returnstack
variable frame
set aFrame [@ frame]
set counter 0
while {[@ counter] < [llength [@ returnstack]]} {
if {[dict get [@ aFrame] type] eq {loop}} {
if {![dict exists [@ aFrame] break]} {
bgerror "break destination no found"
}
set frame [dict merge [@ aFrame] [
list code_pointer [dict get [@ aFrame] break]]]
return
}
if {[dict get [@ aFrame] type] eq {catcher}
|| [dict get [@ aFrame] type] eq {subroutine}} {
execute [
list error {break called outside an loop!}]
return
}
set aFrame [lindex [@ returnstack] end-[@ counter]]
incr counter
}
}
continue {
variable returnstack
variable frame
set aFrame [@ frame]
set counter 0
while {[@ counter] < [llength [@ returnstack]]} {
if {[dict get [@ aFrame] type] eq {loop}} {
if {![dict exists [@ aFrame] continue]} {
bgerror {continue destination no found}}
set frame [dict merge [@ aFrame] [
list code_pointer [
dict get [@ aFrame] continue]]]
return
}
if {[dict get [@ aFrame] type] eq {catcher}
|| [dict get [@ aFrame] type] eq {subroutine}} {
execute [
list error {continue called outside an loop!}]
return
}
set aFrame [lindex [@ returnstack] end-[@ counter]]
incr counter
}
}
rename {
if {[llength [@ call]] != 3} {
execute [list error "wrong number of arguments should be: [@ command] <old name> <new name>"]
return
}
set old_name [lindex [@ call] 1]
set new_name [lindex [@ call] 2]
variable definitions
if {[@ new_name] eq {}} {
dict unset definitions [@ old_name]
} else {
dict set definitions [@ new_name] [
dict get [@ definitions] [@ old_name]]
}
}
routine {
if {[llength [@ call]] != 3} {
execute [list error "wrong number of arguments should be: [@ command] <name> <body>"]
return
}
variable definitions
variable storage_quota
if {[@ storage_quota] < [string length [@ definitions]]} {
execute [list error {over storage quota!}]
return
}
set name [lindex [@ call] 1]
set body [lindex [@ call] 2]
dict set definitions [@ name] type script
dict set definitions [@ name] data [@ body]
dict set definitions [@ name] execlist [translate [@ body]]
}
return {popReturnstack}
+ - - - / - * - ^ - | - & - < - <= - == - != {
foreach item [lrange [@ call] 1 end] {
if {![string is digit [@ item]]} {
execute [list error {not a number!}]
return
}
}
set tally [lindex [@ call] 1]
foreach item [lrange [@ call] 2 end] {
set tally [expr [@ tally] [
dict get [@ def] data] [@ item]]
}
return [@ tally]
}
round - sqrt - sin - log10 - log - floor - atan - bool -
abs - acos - entier - sinh - tan - tanh - int - asin -
ceil - cos {
if {[llength [@ call]] != 2} {
execute [list error "wrong number of arguments should be: [@ command] <number>"]
return
}
foreach item [lrange [@ call] 1 end] {
if {![string is digit [@ item]]} {
execute [list error {not a number!}]
return
}
}
if {[catch {
set tally [expr [
dict get [@ def] data]([lindex [@ call] 1])]
} res]} {
execute [list error [@ res]]
return
}
return [@ tally]
}
hypot - atan2 - pow - fmod {
if {[llength [@ call]] != 3} {
execute [list error "wrong number of arguments should be: [@ command] <number> <number>"]
return
}
foreach item [lrange [@ call] 1 end] {
if {![string is digit [@ item]]} {
execute [list error {not a number!}]
return
}
}
if {[catch {
set tally [expr [dict get [@ def] data]([lindex [@ call] 1],[lindex [@ call] 2])]
} res]} {
execute [list error [@ res]]
return
}
}
min - max {
foreach item [lrange [@ call] 1 end] {
if {![string is digit [@ item]]} {
execute [list error {not a number!}]
return
}
}
}
and {}
or {}
negate {}
actor {}
{actor send_message} {
if {[llength [@ call]] != 2} {
execute [list error "[@ command] <message>\n <message> := <addresses> <data>"]
return
}
variable actor
set message [lindex [@ call] 1]
set temp {}
foreach addr [lindex [@ message] 0] {
if {[dict exists [@ actor] addressbook] [@ addr]]} {
lappend temp [
dict get [@ actor] addressbook [@ addr]]
} else {
execute [list error "no such address handle: [
@ addr]"]
return
}
}
lset message 0 [@ temp]
actor send_message [@ message]
}
{actor any_messages?} {
variable actor
return [actor any_messsages? [dict get [@ actor] address]]
}
{actor next_message} {
variable actor
if {[actor any_messages? [dict get [@ actor] address]]} {
set message [actor next_message [
dict get [@ actor] address]]
set temp {}
foreach address [lindex [@ message] 0] {
set found no
foreach {key value} [dict get [@ actor] addressbook] {
if {[@ value] eq [@ address]} {
lappend temp [@ key]
set found yes
break; # the innermost loop (just a reminder)
}
}
if {![@ found]} {
set id addr[dict incr actor addressbook_counter]
dict set actor addressbook [@ id] [@ address]
lappend temp [@ id]
}
}
lset message 0 [@ temp]
return [@ message]
} else {
variable running 0
variable frame
set frame [dict merge [@ frame] [list code_pointer [
expr [dict get [@ frame] code_pointer] - 1]]]
return
}
}
{actor beget} {}
{actor die} {
variable self
variable actor
actor die [dict get [@ actor] name]
scheduler remove [@ self]
[@ self] destroy
}
{actor drop_address} {
if {[llength [@ call] != 2]} {
execute [list error "wrong number of arguments should be: [@ command] <address handle>"]
return
}
variable actor
set addr [lindex [@ call] 1]
if {[dict exists [@ actor] addressbook [@ addr]]} {
dict unset actor addressbook [@ addr]
} else {
execute [list error "no such address handle: [
@ addr]"]
return
}
}
{actor gain} {}
yield {
variable running 0
variable frame
set frame [dict merge [@ frame] [list code_pointer [
expr [dict get [@ frame] code_pointer] - 1]]]
}
lappend {}
lassign {}
lindex {}
linsert {}
list {}
llength {}
lrange {}
lrepeat {}
lreplace {}
lsearch {}
lsort {}
__jump {
if {[llength [@ call] != 2} {
bgerror "primitive __jump: wrong # of args"
return
}
set destination [lindex [@ call] 1]
if {![string is digit [@ destination]]} {
bgerror "primitive __jump: destination is not a number"
}
variable code_pointer [@ destination]
return
}
__branch {
# branch if predicate is {}
if {[llength [@ call] != 3} {
bgerror "primitive __branch: wrong # of args"
return
}
set predicate [lindex [@ call] 1]
set destination [lindex [@ call] 2]
if {![string is digit [@ destination]]} {
bgerror "primitive __branch: destination is not a number"
return
}
variable results
if {[dict get [@ results] [@ predicate]] eq {}} {
variable code_pointer [@ destination]
}
return
}
invocation {
variable frame
return [dict get [@ frame] invocation]
}
}
} else {
error {unknown definition type}
}
} else {
if {[dict exists [@ definitions] unknown]} {
return [execute [list unknown [@ call]]
} else {
if {[dict exists [@ definitions] error]} {
return [execute [list error {no unknown proc exists}]]
} else {
bgerror {no error proc/command defined}
}
}
}
}
picol_interp proc spliceIn {template values} {
set result {}
set index 0
while {[@ index] < [string length [@ template]]} {
set char [string index [@ template] [@ index]
incr index
if {[@ char] eq "\\"} {
set char [string index [@ template] [@ index]
incr index
if {{u} eq [@ char]} {
set value [string range [@ template] [@ index] [incr index 3]]
incr index
append result [format %c [expr 0x[@ value]]]
} elseif {{x} eq [@ char]} {
set value [string range [@ template] [@ index] [incr index]]
incr index
append result [format %c [expr 0x[@ value]]]
} elseif {{t} eq [@ char]} {append result \t
} elseif {{r} eq [@ char]} {append result \r
} elseif {{n} eq [@ char]} {append result \n
} elseif {{b} eq [@ char]} {append result \b
} else {
append result [@ char]
}
} elseif {{[} eq [@ char]} {
set symbol {}
repeat {
set char [string index [@ template] [@ index]]
if {{]} ne [@ char]} {
append symbol [@ char]
}
} until {{]} eq [@ char]}
if {![dict exists [@ values] [@ symbol]]} {
bgerror {symbol not in values}
return
}
append result [list [dict get [@ values] [@ symbol]]
} elseif {"\{" eq [@ char]} {
append result \{
set level 1
repeat {
set char [string index [@ template] [@ index]]
incr index
append result [@ char]
if {"\{" eq [@ char]} {
incr level +1
} elseif {"\}" eq [@ char]} {
incr level -1
} elseif {"\\" eq [@ char]} {
set char [string index [@ template] [@ index]]
incr index
append result [@ char]
}
} until {[@ level] == 0}
} else {
append result [@ char]
}
}
return [@ result]
}
thingy picol_translator
picol_translator variable entries {}
picol_translator variable lastUsed {}
picol_translator proc translate {code {offset 0}} {
variable entries
variable lastUsed
# have we translated this piece of code already?
if {[dict exists [@ entries] [info level 0]]} {
# yes
dict set lastUsed [info level 0] [clock millisec]
return [dict get [@ entries] [info level 0]]
}
# no
# but do we have enaugh space?
if {1000 < [dict size [@ entries]]} {
# nope, discard all but around top 100 most used
set top100 [lrange [lsort -decreasing -unique [
dict values [@ lastUsed]] 0 100]
foreach item [dict keys [@ lastUsed]] {
if {[lsearch -exact [@ top100] [
dict get [@ lastUsed] [@ item]]] == -1} {
dict unset lastUsed [@ item]
dict unset entries [@ item]
}
}
}
# translate the code into execlist
set result [list]
set counter [@ offset]
set level 0
dict set stack [@ level] {}
set index 0
set length [string length [@ code]]
set braced? no
set quoted? no
while {[@ index] < [@ length]} {
set char [string index [@ code] [@ index]]
incr index
if {{$} eq [@ char] && ![@ braced?]} {
# not thought all the way through yet
set varname {}
repeat {
set char [string index [@ code] [@ index]]
incr index
if {![string is space [@ char]] && [@ char] ne {"}} {
append varname [@ char]
}
} until {[string is space [@ char]] || [@ char] eq {"}}
dict append stack [@ level] \[var_[@ varname]\]
} elseif {{"} eq [@ char] && ![@ braced?]} {
if {[@ quoted?]} {
set quoted? no
} else {
set quoted? yes
}
} elseif {"\\" eq [@ char]} {
dict append stack [@ level] \\
dict append stack [@ level] [string index [@ code] [@ index]]
incr index
} elseif {{[} eq [@ char] && ![@ braced?]} {
incr level +1
dict set stack [@ level] {}
} elseif {{]} eq [@ char] && ![@ braced?]} {
lappend result [dict get [@ stack] [@ level]]
dict unset stack [@ level]
incr level -1
if {[@ level] < 0} {error {too many [ or too few ]}}
dict append stack [@ level] \[[@ counter]\]
incr counter
} elseif {"\n" [@ char] && ![@ braced?]} {
if {[@ level] != 0} {error {unquoted \n inside a command}}
if {![string is space [dict get [@ stack] 0]]} {
lappend result [dict get [@ stack] 0]
incr counter
dict set stack 0 {}
}
} elseif {"\{" eq [@ char]} {
if {![@ braced?]} {
set braced? 1
} else {
incr braced? +1
}
dict append stack [@ level] [@ char]
} elseif {"\}" eq [@ char]} {
if {![@ braced?]} {
error {missing { somewhere or too many }}
} else {
incr braced? -1
}
dict append stack [@ level] [@ char]
} else {
dict append stack [@ level] [@ char]
}
}
dict set entries [info level 0] [@ result]
dict set lastUsed [info level 0] [clock millisec]
return [@ result]
}
picol_interp proc translate code {
return [picol_translator translate [@ code]]
}
thingy actor
actor variable storage {}
actor proc next_message mailbox {
variable storage
if {![dict exists [@ storage] [@ mailbox]]} {
error "actor mailbox [@ mailbox] doesn't exist locally"
}
if {[llength [dict get [@ storage] [@ mailbox]] == 0} {
error "actor mailbox [@ mailbox] empty"
}
set message [lindex [dict get [@ storage] [@ mailbox]] 0]
dict set storage [@ mailbox] [
lrange [dict get [@ storage] [@ mailbox]] 1 end]
return [@ message]
}
actor proc any_messages? mailbox {
variable storage
if {![dict exists [@ storage] [@ mailbox]]} {return no }
return [expr ([llength [dict get [@ storage] [@ mailbox]]] != 0)]
}
actor proc send_message message {
variable storage
# address part of message, first address
set recipient [lindex [@ message] 0 0]
if {[dict exists [@ storage] [@ recipient]]} {
dict lappend storage [@ recipient] [@ message]
return
} else {
# doesn't exist locally
}
}
actor proc beget args {
foreach item {newaddress startscript startaddressbook} {
if {![dict exists [@ args] [@ item]]} {
error "missing keyword parameter [@ item]"
}
}
thingy picol_interp_[@ newaddress]
picol_interp_[@ newaddress] [picol_interp serialize]
picol_interp_[@ newaddress] dict set actor addressbook [@ startaddressbook]
picol_interp_[@ newaddress] dict set actor name [@ newaddress]
picol_interp_[@ newaddress] dict set frame code [
picol_tanslator translate [@ startscript]]
picol_interp_[@ newaddress] set returnstack {}
picol_interp_[@ newaddress] dict set frame code_pointer 0
scheduler schedule picol_interp_[@ newaddress]
}
actor proc die {mailbox} {
variable storage
dict unset storage [@ mailbox]
}
thingy scheduler
scheduler variable tasks {}
scheduler proc schedule {task} {
variable tasks
lappend tasks [@ task]
}
scheduler proc run {} {
variable tasks
set current [lindex [@ tasks] 0]
set tasks [join [list [lrange [@ tasks] 1 end] [@ current]]
catch {
[@ task] run
}
after idle [list scheduler run]
}package require Tcl 8.5
# Tcl 8.5 required because of usage of dict
proc run {} {
variable state
while {[dict get $state running]} {
switch -exact -- [
string index [dict get $state code] [dict get $state index]] {
\{ {
set item \{
set brace-level 1
dict incr state index +1
while {$brace-level > 0} {
set char [string index [dict get $state code] [
dict get $state index]]
if {$char eq "\\"} {
append item $char
dict incr state index +1
append item [string index [dict get $state code] [
dict get $state index]]
} elseif {$char eq "\{"} {
append item $char
incr brace-level +1
} elseif {$char eq "\}"} {
append item $char
incr brace-level -1
} else {
append item $char
}
dict incr state index +1
}
dict append state stack [
dict get $state stack-level] command $item
}
[ {
dict incr state stack-level +1
dict set state stack [
dict get $state stack-level] start-index [
dict get $state index]
}
] {
set frame [dict get $state stack [dict get $state stack-level]]
dict unset state stack [dict get $state stack-level]
dict incr state stack-level -1
dict append state stack [
dict get $state stack-level] command [execute $frame]
}
\n {
set frame [dict get $state stack [dict get $state stack-level]]
dict unset state stack [dict get $state stack-level]
execute $frame
}
default {
dict append state stack [
dict get $state stack-level] command [string index [
dict get $state code] [dict get $state index]]
}
}
if {[dict get $state index]
>= [string length [dict get $state code]]} {popReturnstack}
dict incr state index +1
}
}
proc exacute {frame} {
variable state
dict incr state run_quota -1
if {[dict get state run_quota] == 1} {
dict set state running no
}
set command_name [lindex [dict get $frame command] 0]
if {[dict exists $state definitions $command_name]} {
if {{primitive} eq [dict get $state definitions $command_name type]]} {
set opcode [dict get $state definitions $command_name contents]
switch -exact -- $opcode {
}
} elseif {{combined} eq [
dict get $state definitions $command_name type]} {
pushReturnstack
initFrame [list code [
dict get $state definitions $command_name contents]]
}
} else {
if {[string equal $command_name "unknown"]} {
execute [list command [list error {unknown command not found}]]
} else {
execute [dict merge $frame [list command [
list unknown [dict get $frame command]]]]
}
}
}
proc popReturnstack {} {
variable state
dict set state [dict merge $state [dict get $state returnStack]]
}
proc pushReturnstack {} {
variable state
dict set state returnStack $state
}
proc initFrame {presets} {
variable state
dict set state index -1
dict set state code {}
dict set state stack-level 0
dict set state stack 0 {}
dict set state [dict merge $state $presets]
}proc textDelta {strA strB} {
# strA should always be longer than strB
if {[string length $strA] < [string length $strB]} {
set tmp $strA
set strA $strB
set strB $tmp
unset tmp
}
set indexA 0
set indexB 0
set theChange_text {}
set theChange_end undefined
set theChange_start undefined
while {$indexA < [string length $strA]} {
set charA [string index $strA $indexA]
set charB [string index $strB $indexB]
if {$charA eq $charB} {
incr indexB
if {$theChange_start ne {undefined}} {
set theChange_end $indexA
}
} else {
append theChange_text $charA
if {$theChange_start eq {undefined}} {
set theChange_start $indexA
}
}
incr indexA
}
if {$theChange_end eq {undefined}} {set theChange_end $theChange_start}
return [list $theChange_text $theChange_start $theChange_end]
}
proc namedArgs {} {
upvar args args
foreach {name value} $args {
upvar $name tmp
set tmp $value
}
}
if 0 {Zarutian: The following is deprecated.}
ackage ifneeded zarutian.memchan 1.0 {
package require rechan 1.0
namespace eval ::zarutian::memchan {}
proc ::zarutian::memchan::handler args {
log [info level 0]
set cmd [lindex $args 0]
set chan [lindex $args 1]
variable buffers
variable write_read
if {$cmd eq {write}} {
if {[lsearch [array names write_read] $chan] == -1} {
error "$chan is only open for reading"
}
}
append buffers($write_read($chan)) [lindex $args 2]
return [string length [lindex $args 2]]
} elseif {$cmd eq {read}} {
if {[lsearch [array names write_read] $chan] != -1} {
error "$chan is only open for writing"
}
set data [string range $buffers($chan) 0 [lindex $args 2]]
set buffers($chan) [string range $buffers($chan) [expr [lindex $args 2] +1] end]
return $data
} elseif {$cmd eq {close}} {
if {[lsearch [array names write_read] [lindex $args 1]] != -1} {
close $write_read($chan)
unset buffers($write_read($chan))
unset write_read($chan)
}
}
roc ::zarutian::memchan::new {} {
log [info level 0]
variable write_read
set write [rechan ::zarutian::memchan::handler 4]
set read [rechan ::zarutian::memchan::handler 2]
set write_read($write) $read
return [list $write $read]
package provide zarutian.memchan 1.0
package ifneeded zarutian.demultiplexing 1.0 {
package require zarutian.memchan 1.0
namespace eval ::zarutian::demultiplexing {}
proc ::zarutian::demultiplexing::readChan {incoming_channel} {
variable channels
if {[eof $incoming_channel]} {
foreach item [array names channels] {
if {[string match [set incoming_channel]_* $item]} {
foreach chan [set channels($item)] {
close $chan
}
}
}
close $incoming_channel
return
}
fconfigure $incoming_channel -encoding unicode -blocking 1 \
-translation auto
gets $incoming_channel line
set cmd [lindex $line 0]
if {$cmd eq {data}} {
set chanId [lindex $line 1]
set length [lindex $line 2]
fconfigure $incoming_channel -encoding binary -blocking 1 \
-translation binary
set data [read $incoming_channel $length]
foreach chan $channels([set incoming_channel]_[set chanId]) {
puts $chan $data
}
return
} elseif {$cmd eq {eof}} {
set chanId [lindex $line 1]
foreach chan $channels([set incoming_channel]_[set chanId]) {
close $chan
}
return
} elseif {$cmd eq {flush}} {
set chanId [lindex $line 1]
foreach chan $channels([set incoming_channel]_[set chanId]) {
flush $chan
}
return
}
}
}
proc ::zarutian::demultiplexing::addChan {channel chanid {listenChannel {}}} {
variable channels
if {$listenChannel ne {}} {
set write $listenChannel
set read $listenChannel
} else {
set temp [::zarutian::memchan::new]
set write [lindex $temp 0]
set read [lindex $temp 1]
}
lappend channels([set channel]_[set chanid]) $write
return $read
}
proc ::zarutian::demultiplexing::setup incoming_channel {
fileevent $incoming_channel [
list ::zarutian::demultiplexing::readChan $incoming_channel]
}
package provide zarutian.demultiplexing 1.0
package ifneeded zarutain.multiplexing 1.0 {
package require zarutian.memchan 1.0
namespace eval ::zarutian::multiplexing {}
proc ::zarutian::multiplexing::readChan {channel} {
variable outgoing_channelsId
variable outgoing_channelsMainChan
if {[eof $channel]} {
puts $outgoing_channelsMainChan($channel) "eof [
set outgoing_channelsId($channel)]"
flush $outgoing_channelsMainChan($channel)
return
}
set rememberBlocking [fconfigure $channel -blocking]
set rememberTranslation [fconfigure $channel -translation]
fconfigure $channel -blocking 1 -translation binary
set data [read $channel]
set length [string bytelength $data]
fconfigure $channel -blocking $rememberBlocking \
-translation $rememberTranslation
puts $outgoing_channelsMainChan($channel) "data [
set outgoing_channelsId($channel)] $length"
fconfigure $outgoing_channelsMainChan($channel) -encoding binary \
-translation binary
puts $outgoing_channelsMainChan($channel) $data
flush $outgoing_channelsMainChan($channel)
fconfigure $outgoing_channelsMainChan($channel) -encoding unicode \
-translation auto
return
}
proc ::zarutian::multiplexing::addChan {mainchannel chanId channel} {
variable outgoing_channelsId
set outgoing_channelsId($channel) $chanId
set outgoing_channelsMainChan($channel) $mainchannel
fileevent $channel readable [
list ::zarutian::multiplexing::readChan $channel]
}
package provide zarutain.multiplexing 1.0
}
package ifneeded zarutain.leftShiftingRegister 1.0 {
package require rechan 1.0
namespace eval ::zarutian::leftShiftingRegister {}
proc ::zarutian::leftShiftingRegister::handler args {
variable states
variable polynominals
variable lengths
set cmd [lindex $args 0]
set instance [lindex $args 1]
if {$cmd eq {write}} {
error {this chanel is only open for reading}
} elseif {$cmd eq {close}} {
unset states($instance)
unset polynominals($instance)
unset lengths($instance)
} elseif {$cmd eq {read}} {
set reqlength [expr [lindex $args 2] * 8]
set buffer $states($instance)
set polyA [lindex $polynominals($instance) 0]
set polyB [lindex $polynominals($instance) 1]
if {($polyA < 0) || ($polyB <0)} {
error "a polynominal is under zero"
}
if { ($polyA > $lengths($instance))
|| ($polyB > $lengths($instance))} {
error {a polynominal addresses out of bound for the register}
}
if {$polyA == $polyB} {
error {the polynominals must not be same}
}
for {} {$reqlength > 0} {incr reqlength -1} {
append buffer [XOR [string index $states($instance) $polyA] [
string index $states($instance) $polyB]]
}
set states($instance) [
string range $buffer end-[expr $lengths($instance) +1] end]
return [binary format B* $buffer)]
}
}
proc ::zarutian::leftShiftingRegister::XOR {a b} {
#IS: ýetta er bara sanntafla.
#EN: This is just an truthtable.
if {$a && $b} {
return 0
} elseif {$a && (!$b)} {
return 1
} elseif {(!$a) && $b} {
return 1
} elseif {(!$a) && (!$b)} {
return 0
}
}
proc ::zarutian::leftShiftingRegister::new {
startingState length polynominal} {
variable states
variable polynominals
variable lengths
set instance [rechan ::zarutian::leftShiftingRegister::handler 6]
if {[llength $polynominal] != 2} {
error "$polynomnial must be two positive numbers"
}
set states($instance) $startingState
set polynominals($instance) $polynominal
set lengths($instance) $length
return $instance
}
package provide zarutain.leftShiftingRegister 1.0
}
package ifneeded zarutian.bitSelector 0.1 {
package require rechan 1.0
namespace eval ::zarutian::bitSelector {}
proc ::zarutain::bitSelector::handler args {
variable channelAs
variable channelSs
set cmd [lindex $args 0]
set chan [lindex $args 1]
if{$cmd eq {read}} {
set reqlength [lindex $args 2]
set rememberChannelConfigurationA [fconfigure $channelAs($chan)]
set rememberChannelConfigurationB [fconfigure $channelSs($chan)]
fconfigure $channelAs($chan) -translation binary -encoding binary
fconfigure $channelSs($chan) -translation binary -encoding binary
set bufferS [read $channelSs($chan) $reqlength]
binary scan $bufferS B* bufferS
set bufferA {}
# ýaý er ýruglega einhver villa hýr inný -byrjun-
# hef ýaý ý tilfininguni aý ýg ýtti ekki aý nota gildi breytunar
# temp1 sem index ý breytuna byte
for {set temp2 1} {$temp2 <= $reqlength} {incr temp2} {
binary scan [read $channelAs($chan) 1] byte
for {set temp1 1} {$temp1 <= 8} {incr temp1} {
set temp3 [expr ($temp2 * 8) + $temp1]
if {[string index $bufferS $temp3]} {
append bufferA [string index $byte $temp1]
}
}
}
# ýaý er ýruglega einhver villa hýr inný -lok-
fconfigure $channelAs($chan) [
join $rememberChannelConfigurationA { }]
fconfigure $channelSs($chan) [
join $rememberChannelConfigurationB { }]
return [binary format B* $bufferA]
} elseif {$cmd eq {write}} {}
# lesa fyrsta af rýs S einn bita yfir ý breytu x
# ef x er 1 ýý lesa einn bita af rýs A yfir ý breytu y
# býta y viý buffer
}
proc ::zarutian::bitSelector::new {channelA channelS} {
# channelA is the victim
# channelS is the torturer
variable instances
if {[info exists instances([set channelA]_[set channelS])]} {
return $instances([set channelA]_[set channelS])
}
set instance [rechan ::zarutain::bitSelector::handler 6]
lappend instances $instance
variable channelAs
variable channelSs
set channelAs($instance) $channelA
set channelSs($instance) $channelS
return $instance
}
package provide zarutian.bitSelector 0.1
}
if 0 {
other possible Tcl Core implementation thoughts
basic datatypes:
* boolean (true/false)
* bytestring (can be any binarydata that can be contained in octects)
* table (like in Lua)
floating points will be represented as a table containing something like this:
"type": "float"
"base": <bytestring treated as an number>
"exponent": <bytestring treated as an number>
package ifneeded zarutian.app.synchRemoteEval 0.1 {
proc getCallstack {} {
set calls [list]
set me [expr [info level] -1]
for {set i $me} {$i > 0} {incr i -1} {
lappend calls [info level $i]
}
return $calls
}
proc syncRemoteEval channel {
set calls [getCallstack]
set cmd [lindex $calls 2]
set d [info level]
if {$d > 2} {
set u2 [lindex $calls 3]
if {[lindex $u2 0] eq {syncRemoteEval}} {
return
}
}
# info feedback prevention aka dont send back what we recived.
set ok 1
foreach call $calls {
if {[lindex $call 0] eq {fileevent_for_synchRemoteEval}} {
set ok 0
break
}
}
if {$ok} {putsAndFlush $channel "callstack [list $calls]"}
set val {}
catch {set val [eval $cmd]} res
if {$res != $val} {
putsAndFlush $channel "error [list $res]"
} else {
putsAndFlush $channel "result [list $res]"
}
return -code return $res
}
proc fileevent_for_syncRemoteEval {chan} {
}
proc putsAndFlush {chan data} {
catch {
puts $chan $data
flush $chan
}
}
package provide zarutian.app.synchRemoteEval 0.1
}
package ifneeded zarutian.app.synchRemoteEvalVersionB 0.1 {
# same as above but using execution traces
package require Tcl 8.4
proc getCallstack {} {
set calls [list]
set me [expr [info level] -1]
for {set i $me} {$i > 0} {incr i -1} {
lappend calls [info level $i]
}
return $calls
}
proc was_called_anytime_by? {cmdname} {
set calls [lrange [getCallstack] 1 end]
foreach call $calls {
if {[lindex $call 0] eq $cmdname} {return 1}
}
return 0
}
proc sendToTheOtherEnd data {
global remoteEvalSynch_channel
catch {
# make sure that the data on the channel is unicode encoded
fconfigure $channel -encoding unicode
puts $remoteEvalSynch_channel $data
flush $remoteEvalSynch_channel
}
}
proc remoteEvalSynchExecuteCallback args {
set cmd [lindex $args 0]
set op [lindex $args end]
if {$op eq {enter}} {
if {![was_called_anytime_by? remoteEvalSynchFileeventCallback]} {
sendToTheOtherEnd "start-eval [list $cmd]"
# sendToTheOtherEnd "start-eval [list $cmd [getCallstack]]"
}
} elseif {$op eq {leave}} {
set code [lindex $args 1]
set result [lindex $args 2]
sendToTheOtherEnd "result-update [list $cmd $code $result]"
# sendToTheOtherEnd "result-update [list $cmd $code $result [getCallstack]]"
}
}
proc remoteEvalSynchFileeventCallback {channel} {
global buffers
if {[eof $channel} {
# for the time being raise an error when channel is eofed by the
# other end
error "$channel eofed!"
}
# make sure that the data on the channel is unicode encoded
fconfigure $channel -encoding unicode
append buffers($channel) [gets $channel]
if {[info complete $buffers($channel)} {
set event [lindex $buffers($channel) 0]
set data [lindex $buffers($channel) 1]
if {$event eq {start-eval}} {
set cmd [lindex $data 0]
# set callstack [lindex $data 1]
catch {
eval $cmd
}
} elseif {$event eq {result-update}} {
# what should I do with this?
# fyrst um sinn: check if code is error and error on it
set cmd [lindex $data 0]
set code [lindex $data 1]
set result [lindex $data 2]
# set callstack [lindex $data 3]
if {$code eq {error}} {
error "remote-error: $channel [list $cmd] [list $result ]"}
}
unset buffers($channel)
}
}
proc remoteEvalSynch {victim channel} {
# channel must be two way
fileevent $channel readable [
list remoteEvalSynchFileeventCallback $channel]
trace add execution $victim {enter leave} remoteEvalSynchExecuteCallback
}
package provide zarutian.app.synchRemoteEvalVersionB 0.1
}