* http://zarutian.cjb.net/ is my web page (seriusly out of date) * [Flow Based Programming] * [SEXP] * [Zarutian's Thingy Package] * [Zarutian's SEXP Package] * [serializable Safe Slave Interp] * http://www.cacr.math.uwaterloo.ca/hac/index.html * http://erights.org/ everything about object-capabilities * http://www.erights.org/elib/distrib/pipeline.html Promise Pipelining * http://www.fpx.de/Combat/ CORBA implemented in Tcl * http://www.strille.net/tutorials/part1_scrolling.php * http://www.tonypa.pri.ee/tbw/tut15.html * http://www.hhhh.org/perseant/lfs.html * http://www.informit.com/articles/article.asp?p=437097&rl=1 * http://video.google.com/videoplay?docid=7278544055668715642&q=bigtable * http://www.sfsu.edu/~doit/helpdesk/mdevapp.htm * [http://www.ece.cmu.edu/~koopman/stack_computers/sec7_1.html] <- var hýr aý lesa * http://wotug.org/parallel/transputer/documentation/st020-450/datasheets/ * [Transputer] * http://www.ibm.com/developerworks/linux/library/l-clear-code/?ca=dgr-FClnxw01linuxcodetips * http://www.chronocompendium.com/Term/Fan_Projects.html * http://www.msnbc.msn.com/id/18882828/site/newsweek/ * [Capicol] * http://www.waterken.com/dev/IOU * http://www.eros-os.org/pipermail/e-lang/2004-January/009421.html How the hell do you pronounce my nick? In four syllabels: Za-ru-ti-an I am also active on wikipedia under the same nick. (Both the English one and the Icelandic one) Stuff I am thinking about implementing/doing (DONT PUT PRESURE ON ME PLEASE!): * write a simple Tcl interpreter purely in Lua. * publishing my bindiff procedures and binpatch procedure. (that would be awesome! Please do) 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) * write multiplexing and demultiplexing stuff to learn some tricks with [rechan] * - One is to have dual sided memchan (aka one handle to write to and another one to read from) * investigate what whould be the best way to write a bytecode compiler for Tcl ''in'' pure-Tcl (related to [Scripted Compiler]) * - Arent Syntax Dictionary Encoded code better cross platform than bytecodes? * change the unknown procedure to lookup a procedure in the parent namespaces up to the global namespace instead in just current and global. * wikit additions: * - post to the Tcler's chatroom when a page has been edited. (Some sort of flood preventation would be a good idea) * - add reversion deltas. (Current version and back-deltas to earlier versions are saved in two files) * ? autosave like in Gmail compose * get the packages I write in some sort of order (hint for no nameconflict: prepend zarutian/ before the packages name) === scrachpad 3 === 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 {[string equal $cmd "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 {[string equal $cmd "<"]} { # 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 {[string equal $cmd "eval"]} { } elseif {[string equal $cmd "error"]} { } elseif {[string equal $cmd "+"]} { } elseif {[string equal $cmd "-"]} { } elseif {[string equal $cmd "/"]} { } elseif {[string equal $cmd "%"]} { } elseif {[string equal $cmd "&"]} { } elseif {[string equal $cmd "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 {[string equal $cmd "get"]} { if {[llength $argus] != 1} { set state [lindex [exec_prim error "wrong # of args" $state] end] } else { } } elseif {[string equal $cmd "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 } === scrachpad 2 === package require Tcl 8.5 # definitions # # type primitive / script # data identifier / code # frame # type subroutine / catcher / loop / {} # code # code_pointer # invocation # result # returnstack # # package require zarutian/generic 1.0 proc @ {name} { upvar [set name] [set name] return [set [set name]] } proc repeat {body keyword condition} { if {[string equal $keyword "until"]} { set condition "!([set condition])" } elseif {[string equal $keyword "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 {[string equal "script" [dict get [@ def] type]]} { 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 {[string equal "primitive" [dict get [@ def] type]]} { 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 "] 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 ? "] 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 ? "] 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 ??"] 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 "] 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 \[else \]"] 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 {[string equal [dict get [@ definitions] [@ def] type] "primitive"]} { if {[string equal [dict get [@ definitions] [@ def] data] "__branch"]} { set __branch [@ def] } if {[string equal [dict get [@ definitions] [@ def] data] "__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 {![string equal [@ false-body] {}]} { set slot2 [llength [@ daCode]] lappend daCode "<<<__jump primitive comes here>>>" } lset daCode [@ slot1] [list [@ __branch] [expr [@ slot1] -1] [llength [@ daCode]]] if {![string equal [@ false-body] {}]} { 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 "] 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 {[string equal [dict get [@ definitions] [@ def] type] "primitive"]} { if {[string equal [dict get [@ definitions] [@ def] identifier] "__branch"]} { set __branch [@ def] } if {[string equal [dict get [@ definitions] [@ def] identifier] "__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 {[string equal [dict get [@ aFrame] type] "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 {[string equal [dict get [@ aFrame] type] "catcher"] || \ [string equal [dict get [@ aFrame] type] "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 {[string equal [dict get [@ aFrame] type] "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 {[string equal [dict get [@ aFrame] type] "catcher"] || \ [string equal [dict get [@ aFrame] type] "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] "] return } set old_name [lindex [@ call] 1] set new_name [lindex [@ call] 2] variable definitions if {[string equal [@ new_name] ""]} { 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] "] 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] "] 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] "] 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] \n := "] 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 {[string equal [@ value] [@ 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]
"] 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 {[string equal [dict get [@ results] [@ predicate]] {}]} { 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 {[string equal "\\" [@ char]]} { set char [string index [@ template] [@ index] incr index if {[string equal "u" [@ char]]} { set value [string range [@ template] [@ index] [incr index 3]] incr index append result [format "%c" [expr 0x[@ value]]] } elseif {[string equal "x" [@ char]]} { set value [string range [@ template] [@ index] [incr index]] incr index append result [format "%c" [expr 0x[@ value]]] } elseif {[string equal "t" [@ char]]} { append result "\t" } elseif {[string equal "r" [@ char]]} { append result "\r" } elseif {[string equal "n" [@ char]]} { append result "\n" } elseif {[string equal "b" [@ char]]} { append result "\b" } else { append result [@ char] } } elseif {[string equal "\[" [@ char]]} { set symbol "" repeat { set char [string index [@ template] [@ index]] if {![string equal "\]" [@ char]]} { append symbol [@ char] } } until {[string equal "\]" [@ char]]} if {![dict exists [@ values] [@ symbol]]} { bgerror "symbol not in values" ; return } append result [list [dict get [@ values] [@ symbol]] } elseif {[string equal "\{" [@ char]]} { append reuslt "\{" set level 1 repeat { set char [string index [@ template] [@ index]] incr index append result [@ char] if {[string equal "\{" [@ char]]} { incr level +1 } elseif {[string equal "\}" [@ char]]} { incr level -1 } elseif {[string equal "\\" [@ 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 {[string equal "\$" [@ char]] && ![@ braced?]} { # not thpught all the way through yet set varname "" repeat { set char [string index [@ code] [@ index]] incr index if {![string is space [@ char]] && ![string equal [@ char] "\""]} { append varname [@ char] } } until {[string is space [@ char]] || [string equal [@ char] "\""]} dict append stack [@ level] "\[var_[@ varname]\]" } elseif {[string equal "\"" [@ char]] && ![@ braced?]} { if {[@ quoted?]} { set quoted? no } else { set quoted? yes } } elseif {[string equal "\\" [@ char]]} { dict append stack [@ level] "\\" dict append stack [@ level] [string index [@ code] [@ index]] incr index } elseif {[string equal "\[" [@ char]] && ![@ braced?]]} { incr level +1 dict set stack [@ level] {} } elseif {[string equal "\]" [@ 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 {[string equal "\n" [@ char]] && ![@ braced?]]} { if {[@ level] != 0} { error "unquoted \\n inside an command" } if {![string is space [dict get [@ stack] 0]]} { lappend result [dict get [@ stack] 0] incr counter dict set stack 0 {} } } elseif {[string equal "\{" [@ char]]} { if {![@ braced?]} { set braced? 1 } else { incr braced? +1 } dict append stack [@ level] [@ char] } elseif {[string equal "\}" [@ 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] doesnt exists localy" } 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 set recipiant [lindex [@ message] 0 0]; # address part of message, first address if {[dict exists [@ storage] [@ recipiant]]} { dict lappend storage [@ recipiant] [@ message] return } else { # doesnt exists 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] } === scratchpad === 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 == "\\"} { append item $char dict incr state index +1 append item [string index [dict get $state code] [dict get $state index]] } elseif {$char == "\{"} { append item $char incr brace-level +1 } elseif {$char == "\}"} { 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 {[string equal "primitive" [dict get $state definitions $command_name type]]} { set opcode [dict get $state definitions $command_name contents] switch -exact -- $opcode { } } elseif {[string equal "combined" [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] } === codeStart === 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 == $charB} { incr indexB if {$theChange_start != "undefined"} { set theChange_end $indexA } } else { append theChange_text $charA if {$theChange_start == "undefined"} { set theChange_start $indexA } } incr indexA } if {$theChange_end == "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. } package 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 == "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 == "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 == "close"} { if {[lsearch [array names write_read] [lindex $args 1]] != -1} { close $write_read($chan) unset buffers($write_read($chan)) unset write_read($chan) } } } proc ::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 == "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 == "eof"} { set chanId [lindex $line 1] foreach chan $channels("[set incoming_channel]_[set chanId]") { close $chan } return } elseif {$cmd == "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 != {}} { 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 == "write"} { error "this chanel is only open for reading" } elseif {$cmd == "close"} { unset states($instance) unset polynominals($instance) unset lengths($instance) } elseif {$cmd == "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 == "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 == "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 } comment { 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": "exponent": } 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] == "syncRemoteEval"} { return } } # info feedback prevention aka dont send back what we recived. set ok 1 foreach call $calls { if {[lindex $call 0] == "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 ifneed 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] == $cmdname} { return 1 } } return 0 } proc sendToTheOtherEnd {data} { global remoteEvalSynch_channel catch { fconfigure $channel -encoding unicode ; # make sure that the data on the channel is unicode encoded puts $remoteEvalSynch_channel $data flush $remoteEvalSynch_channel } } proc remoteEvalSynchExecuteCallback args { set cmd [lindex $args 0] set op [lindex $args end] if {$op == "enter"} { if {![was_called_anytime_by? "remoteEvalSynchFileeventCallback"]} { sendToTheOtherEnd "start-eval [list $cmd]" # sendToTheOtherEnd "start-eval [list $cmd [getCallstack]]" } } elseif {$op == "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!" } fconfigure $channel -encoding unicode ; # make sure that the data on the channel is unicode encoded append buffers($channel) [gets $channel] if {[info complete $buffers($channel)} { set event [lindex $buffers($channel) 0] set data [lindex $buffers($channel) 1] if {$event == "start-eval"} { set cmd [lindex $data 0] # set callstack [lindex $data 1] catch { eval $cmd } } elseif {$event == "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 == "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 } [Category Person] Category Clutter?