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!):
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)
Code snippets:
# lambda (anon procs)
proc lambda args {
# lambda [list <script> <vars>] ?value for var1? ?...?
bind_vars [lindex [info level 0] 1 0] [lrange [info level 0] 2 end]
eval [lindex [info level 0] 1 1]
}
proc bind_vars {vars values} {
if {[string equal $vars "args"]} {
upvar args var
set var $values
} else {
set index 0
foreach varn $vars {
upvar $varn var
set var [lindex $values $index]
incr index
}
}
}
=== 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
# <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 {[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 <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 {[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 <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 {[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] <old name> <new name>"]
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] <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 {[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] <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 {[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:
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] == "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?