Zarutian 3. july 2007: Capicol is an variant of picol, which in turn is an variant of Tcl. Capicol stands for Capability picol and is my investigation into capability-based security and asynchronous message passing in concurrent environment. It is not complete yet and probably very slow. (I want to get it right before fast, thank you)
Zarutian 11. july 2007: So how does Capicol (or intend to) implement capabilities? Well, simply through a dictionary that the code running in the capicol interp doesn't have access to.
That dictionary maps handles to addresses of other Capicolets (and simple i/o adaptors to the world outside the Capicolets), Capicolet being the snapshot state of an capicol interp, which might themselves be running or stored on other machines. Back to that dictionary. A Capicolet can only send an message to an address it has a handle for.
So how does a Capicolet get an handle for a yet unknown address?
Via the addresses field of a message that the capicol interp code replaces with handles (making new ones when coming across currently unknown addresses) upon receipt of a message and vice verse on sending.
Zarutian 20.. july 2007: for an introduction to capability based security see http://www.skyhunter.com/marcs/capabilityIntro/index.html and on capability based security in general see erights.org New and improved version of the following code coming soon.
Zarutian 23. july 2007: Needs a bit wikignoming that I dont have time to do right now. (Needs a space before each line of code) Turns out I have a bit time.
Zarutian 19. september 2007: I am thinking about simplifing the capability list saved with each capicol state.
# This code is hereby released in the public domain. # Any infriging software patents will be disregarded and # propably made invalid because of obviouseness. # v 0.5 package require Tcl 8.5 package provide capicol 0.5.1 proc log args {}; # override with another proc to get all kind of debugging data. namespace eval capicol {} namespace eval capicol::interp { # state: # my_address # <capicol address> # number_of_children # <number> # running # <boolean> # quota # <number> # capabilities # <address>* # in-queue # <in_message>* # out_queue # <out_message>* # <type> # commands # <command name>* # type # prim | combo | script # contents # returnstack # frame* # frame # pointer # <number> # code # <call template>* # results # <number> # <result> # variables # <name> # <value> # arguments # <string> # [break-goto] # <number> # [continue-goto] # <number> # [catcher] # <name of a variable> # [save-to] # dest # <number> # variables # <name> # <value> # <in_message> := <addresses> <data> <quota> # <out_message> := <out_message_type> <out_message_contents> # <out_message_type> := "beget" | "gain" | "message" # <out_message_contents> := <startup script> <addresses> <quota>; for "beget" # <out_message_contents> := <in_message> ; for "message" # <out_message_contents> := <cert> ; for "gain" # <addresses> := <address>* # <call template> := a string where [<index into the result table>] must be replace with that result # # design decision: use primitives gain and beget or just send messages to local addresses? # hugmynd: sleppa [gain] og [beget] úr grunnskipanasafninu # # decided to upvar state from all that stuff that [advance $state] invokes proc advance {state} { log invoked [info level] [info level 0] if {![dict exists $state commands]} { error "commands missing" } if {![dict exists $state frame code]} { error "code missing" } if {![dict exists $state frame pointer]} { dict set state frame pointer 0 } if {![dict exists $state frame results]} { dict set state frame results {} } if {![dict exists $state frame variables]} { dict set state frame variables {} } if {![dict exists $state frame args]} { dict set state frame args {} } if {![dict exists $state returnstack]} { dict set state returnstack {} } set cmd&args [lindex [dict get $state frame code] [dict get $state frame pointer]] set cmd&args [interpolate [dict get $state frame 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]]} { # nokkuð mjög líklegt að verði mikið notað # push current continuation onto returnstack push_contination $state # stilla state fyrir að keyra innihald procs dict set state frame code [dict get $state commands $cmd contents] dict set state frame pointer -1; # þarf að vera -1 út af autoincr dict set state frame variables {} dict set state frame results {} dict set state frame args $args } elseif {[string equal "prim" [dict get $state commands $cmd type]]} { set pointer [dict get $state frame pointer] dict set state frame results $pointer [exec_prim [dict get $state commands $cmd contents] $args] } elseif {[string equal "script" [dict get $state commands $cmd type]]} { dict set state commands $cmd script [dict get $state commands $cmd contents] dict set state commands $cmd type combo dict set state commands $cmd contents [translate [dict get $state commands $cmd contents]] return [advance $state] } else { error "unknown command type [dict get $state commands $cmd type]" } } else { # the unknown command handling if {![dict exists $state commands unknown]} { call error "unknown command $cmd" return } else { # invoke the unknown command dict set state frame results \[[dict get $state pointer]\] [call unknown [set cmd&args]] } } if {[llength [dict get $state frame code]] < [dict get $state frame pointer]} { # execution fell off the end of an proc set state [lindex [exec_prim_return {} $state] end] } dict set state frame pointer [expr [dict get $state frame pointer] + 1]; # autoincr return $state } proc translate {script {offset 0}} { log invoked [info level] [info level 0] # todo: refactor this mess of a procedure # translates scripts into exec_lists set code [list] set counter $offset set level 0 dict set stack $level {} set index 0 set length [string length $script] set braced 0 set quoted no while {$index < $length} { set char [string index $code $index] incr index if {[string equal "#" $char] && [string is space [dict get $stack $level]]} { # handle comments # deviates from the 11 syntax rules in the way that comments are until end of line while true { set char [string index $code $index] incr index if {[string equal "\n" $char]} { break } } } elseif {[string equal "\$" $char] && !$braced} { # translate $varname into [get varname] set varname "" while true { set char [string index $script $index] incr index if {[string is space $char] || [string equal $char "\""]} { break } else { append varname $char } } lappend code "get $varname" dict append stack $level "\[[set counter]\]" incr counter } elseif {[string equal $char "\""] && !$braced} { # handle quotes if {$quoted} { set quoted no } else { set quoted yes } } elseif {[string equal $char "\\"]} { # handle escaped characters dict append stack $level "\\" dict append stack $level [string index $script $index] incr index } elseif {[string equal $char "\["] && !$braced} { # handle opening bracket incr level +1 dict set stack $level {} } elseif {[string equal $char "\]"] && !$braced} { # handle closeing bracket lappend code [dict get $stack $level] dict unset stack $level incr level -1 if {$level < 0} { error "too many \[ or too few \]" } dict append stack $level \[[set counter]\] incr counter } elseif {([string equal $char "\n"] || [string equal $char ";"]) && !$braced} { # handle newline and semicolon 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 } } return $code } proc interpolate {map template} { log invoked [info level] [info level 0] set out {} set i 0 while {$i < [string length $template]} { set char [string index $template $i] incr i if {[string equal $char "\["]} { set tag {} while true { set char [string index $template $i] incr i if {[string equal $char "\]"]} { break } elseif {[string equal $char "\["]} { error "only one bracket level allowed in interpolation" } else { append tag $char } if {$i >= [string length $template]} { error "where is the closing bracket?" } } if {![dict exists $map $tag]} { error "tag not found in map" } append out [dict get $map $tag] # finnst eins og ég sé að gleyma einhverju hér } elseif {[string equal $char "\{"]} { append out $char set level 1 while true { set char [string index $template $i] incr i if {[string equal $char "\{"]} { incr level +1 } elseif {[string equal $char "\}"]} { incr level -1 } append out $char if {$level == 0} { break } if {$i >= [string length $template]} { error "missing closing brace some where" } } } elseif {[string equal $char "\\"]} { append out "\\" append out [string index $template $i]; incr i } else { append out $char } } return $out } proc space_quota_check {} { upvar state state if {([string length [dict get $state commands]] + \ [string length [dict get $state returnstack]] + \ [string length [dict get $state frame]]) > [dict get $state quota]} { call error "not enaugh quota to run!" return } } proc push_continuation {continuation} { upvar state state log invoked [info level] [info level 0] set temp [dict create] dict lappend state returnstack [dict get $state frame] space_quota_check } proc call {args} { upvar state state log invoked [info level] [info level 0] push_continuation $state dict set state frame code [list [set args]] dict set state frame pointer -1 #return -code return } # primitives (or built in commands) proc exec_prim {primid arguments} { upvar state state log invoked [info level] [info level 0] # giant despatching switch # I rather use jump tables but cant have them easily in higher level languages # I wonder about the speed of this thing switch -exact -- $primid { "+" - "-" - "*" - "/" - "%" - "&" - "|" - "^" - "<<" - ">>" { return [exec_prim_math $primid $arguments] } "<" - "<=" - "==" - "!=" - "and" { return [exec_prim_logical_and $arguments] } "any_messages?" { return [exec_prim_any_messages? $arguments] } "args" { return [exec_prim_args $arguments] } "beget" { return [exec_prim_beget $arguments] } "break" { return [exec_prim_break $arguments] } "catch" { return [exec_prim_catch $arguments] } "capabilities" { return [exec_prim_capabilites $arguments] } "continue" { return [exec_prim_continue $arguments] } "command_exists?" { return [exec_prim_command_exists? $arguments] } "dict" { return [exec_prim_dict $arguments] } "die" { return [exec_prim_die $arguments] } "drop_capability" { return [exec_prim_drop_capability $arguments] } "error" { return [exec_prim_error $arguments] } "gain" { return [exec_prim_gain $arguments] } "get" { return [exec_prim_get $arguments] } "if" { return [exec_prim_if $arguments] } "lappend" { return [exec_prim_lappend $arguments] } "lassign" { return [exec_prim_lassign $arguments] } "lindex" { return [exec_prim_lindex $arguments] } "linsert" { return [exec_prim_linsert $arguments] } "list" { return [exec_prim_list $arguments] } "llength" { return [exec_prim_llength $arguments] } "lrange" { return [exec_prim_lrange $arguments] } "lrepeat" { return [exec_prim_lrepeat $arguments] } "lsearch" { return [exec_prim_lsearch $arguments] } "lset" { return [exec_prim_lset $arguments] } "lsort" { return [exec_prim_lsort $arguments] } "next_message" { return [exec_prim_next_message $arguments] } "or" { return [exec_prim_logical_or $arguments] } "rename" { return [exec_prim_rename $arguments] } "return" { return [exec_prim_return $arguments] } "routine" { return [exec_prim_routine $arguments] } "send_message" { return [exec_prim_send_message $arguments] } "set" { return [exec_prim_set $arguments] } "string" { return [exec_prim_string $arguments] } "unset" { return [exec_prim_unset $arguments] } "uplevel" { return [exec_prim_uplevel $arguments] } "var_exists?" { return [exec_prim_var_exists? $arguments] } "while" { return [exec_prim_while $arguments] } "__branch" { return [exec_prim___branch $arguments] } "__jump" { return [exec_prim___jump $arguments] } default { error "unknown capicol primitive $primid" } } } proc exec_prim_math {op arguments} { log invoked [info level] [info level 0] set result [lindex $arguments 0] foreach item [lrange $arguments 1 end] { set result [expr $result $op $item] } return $result } proc exec_prim_compare {op arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 2} { call error "wrong # args: should be \"$op number number\"" return } return [expr [lindex $arguments 0] $op [lindex $arguments 1]] } proc exec_prim_logical_and {arguments} { log invoked [info level] [info level 0] set result [lindex $arguments 0] foreach item [lrange $arguments 1 end] { set result [expr $result && $item] } return $result } proc exec_prim_any_messages? {arguments} { upvar state state log invoked [info level] [info level 0] if {![dict exists $state in_queue]} { dict set state in_queue {} } return [expr [llength [dict get $state in_queue]] != 0] } proc exec_prim_args {arguments} { upvar state state log invoked [info level] [info level 0] if {![dict exists $state frame args]} { dict set state frame args {} } return [dict get $state frame args] } proc exec_prim_beget {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 3} { call error "wrong # args: should be \"beget startup_script capabilities quota\"" return } set startup_script [lindex $arguments 0] set addresses [lindex $arguments 1] set quota [lindex $arguments 2] foreach address $addresses { if {[lsearch -exact [dict get $state capabilities] $address] == -1} { call error "this capicol has no such address in capabilities list: $address" return } } if {[dict get $state quota] < $quota} { call error "this capicol has not enaugh quota for giving to child" return } if {$quota < [string length $startup_script]} { call error "not enaugh quota allotted to child for the startup script!" return } # make new address for the "child" using the replicator serial scheme if {![dict exists $state my_address]} { error "an capicol state cannot be without an address!" } if {![dict exists $state number_of_children]} { dict set state number_of_children 0 } set child "[dict get $state my_address].[dict incr state number_of_children]" dict lappend state out_queue [list beget $child $startup_script $addresses $quota] return $child } proc exec_prim_break {arguments} { upvar state state log invoked [info level] [info level 0] while true { if {[dict exists $state frame break-goto]} break if {[string equal [dict get $state returnstack] ""]} { call error "break invoked outside an loop" return } exec_prim_return {} } dict set state frame pointer [expr [dict get $state frame break-goto] - 1] } proc exec_prim_catch {arguments} { upvar state state log invoked [info level] [info level 0] # catch <script> [<var>] if {([llength $arguments] < 1) || ([llength $arguments] > 2)} { call error "wrong # args: should be \"catch script ?var?\"" return } dict set state frame catcher [lindex $arguments 1] exec_prim_upevel [list 0 [lindex $arguments 0]] } proc exec_prim_capabilities {arguments} { upvar state state log invoked [info level] [info level 0] if {![dict exists $state capabilities]} { error "an capicol withuout capabilities dict key" } return [dict get $state capabilities] } proc capicol::exec_prim_continue {arguments} { upvar state state log invoked [info level] [info level 0] while true { if {[dict exists $state frame continue-goto]} break if {[string equal [dict get $state returnstack] ""]} { call error "continue invoked outside an loop" return } exec_prim_return {} } dict set state frame pointer [expr [dict get $state frame continue-goto] - 1] } proc capicol::exec_prim_dict {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"dict subcommand ?arg ...?\"" return } # simple dispatcher set subcommand [lindex $arguments 0] set arguments [lrange $arguments 1 end] switch -exact -- $subcommand { "append" { return [exec_prim_dict_append $arguments] } "create" { return [exec_prim_dict_create $arguments] } "exists" { return [exec_prim_dict_exists $arguments] } "filter" { return [exec_prim_dict_filter $arguments] } "for" { return [exec_prim_dict_for $arguments] } "get" { return [exec_prim_dict_get $arguments] } "incr" { return [exec_prim_dict_incr $arguments] } "info" { return [exec_prim_dict_info $arguments] } "keys" { return [exec_prim_dict_keys $arguments] } "lappend" { return [exec_prim_dict_lappend $arguments] } "merge" { return [exec_prim_dict_merge $arguments] } "remove" { return [exec_prim_dict_remove $arguments] } "replace" { return [exec_prim_dict_replace $arguments] } "set" { return [exec_prim_dict_set $arguments] } "size" { return [exec_prim_dict_size $arguments] } "unset" { return [exec_prim_dict_unset $arguments] } "update" { return [exec_prim_dict_update $arguments] } "values" { return [exec_prim_dict_values $arguments] } "with" { return [exec_prim_dict_remove $arguments] } } call error "bad subcommand \"[lindex $arguments 0]\": must be append, create, exists, filter, for, get, incr, info, keys, lappend, merge, remove, replace, set, size, unset, update, values or with" } proc exec_prim_dict_append {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 3} { call error "wrong # args: should be \"dict append varName key ?key ...? value\"" return } set varname [lindex $arguments 0] set keys [lrange $arguments 1 end-1] set value [lindex $arguments 0] set dict [exec_prim_get [list $varname]] set prevValue [exec_prim_dict_get [list $dict {*}$keys]] set value "[set prevValue][set value]" set dict [exec_prim_dict_replace [list $dict {expand}$keys $value]] exec_prim_dict_set [list $varname $dict] return $value } proc exec_prim_dict_create {arguments} { upvar state state log invoked [info level] [info level 0] if {([llength $arguments] % 2) != 0} { call error "wrong # args: should be \"dict create ?key value ...?\"" return } return $arguments } proc exec_prim_dict_exists {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 2} { call error "wrong # args: should be \"dict exists dictionary key ?key ...?\"" return } set dict [lindex $arguments 0] set keys [lrange $arguments 1 end] set found no while {[llength $keys] > 0} { set found no foreach {k v} $dict { if {[string equal $k [lindex $keys 0]]} { set found yes set value $v } } if {!$found} { break } set dict $value set keys [lrange $keys 1 end] } return $found } proc exec_prim_dict_filter {arguments} { upvar state state log invoked [info level] [info level 0] call error {not yet implemented: use this idiom instead: set results {} foreach {key value} $dictionary { if $condition { lappend result $key lappend result $value } }; # end of error message } proc exec_prim_dict_for {arguments} { upvar state state log invoked [info level] [info level 0] call error {not yet implemented: ude this idiom instead: foreach {keyVar valueVar} dictionary script }; # end of error message } proc exec_prim_dict_get {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"dict get dictionary ?key ...?\"" return } set dict [lindex $arguments 0] set keys [lrange $arguments 1 end] while {[llength $keys] > 0} { set found no foreach {k v} $dict { if {[string equal $k [lindex $keys 0]]} { set found yes set value $v } } if {!$found} { call error "key \"[lindex $keys 0]\" not known in dictionary" return } set dict $value set keys [lrange $keys 1 end] } return $value } proc capicol::exec_prim_dict_incr {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 3} { call error "wrong # args: should be \"dict append varName key ?key ...? increment\"" return } set varname [lindex $arguments 0] set keys [lrange $arguments 1 end-1] set value [lindex $arguments 0] set dict [exec_prim_get [list $varname]] set prevValue [exec_prim_dict_get [list $dict {*}$keys]] set value "[set prevValue][set value]" set dict [exec_prim_dict_replace [list $dict {*}$keys $value]] exec_prim_dict_set [list $varname $dict] return $value } proc exec_prim_dict_info {arguments} { log invoked [info level] [info level 0] return "no info" } proc exec_prim_dict_keys {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"dict keys dictionary ?pattern?\"" return } set result {} set pattern * if {[llength $arguments] == 2} { set pattern [lindex $arguments 1] } foreach {key value} [lindex $arguments 0] { if {[string match $pattern $key]} { lappend result $key } } return $result } proc exec_prim_dict_lappend {arguments} { upvar state state log invoked [info level] [info level 0] # use replace call error "not yet implemented!" } proc exec_prim_dict_merge {arguments} { upvar state state log invoked [info level] [info level 0] set out {} foreach dict $arguments { if {([llength $dict] % 2) != 0} { call error "missing value to go with key" return } foreach key [dict keys $dict] { dict set out $key [dict get $dict $key] } } return $out } proc exec_prim_dict_remove {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"dict remove dictionary ?key ...?\"" return } set dict [lindex $arguments 0] set keys [lrange $arguments 1 end] set vstack [list $dict] if {[llength $keys] > 1} { foreach key [lrange $keys 0 end-1] { set dict [exec_prim_dict_get [list $dict [lindex $keys 0]]] lappend vstack $dict } set key [lindex $keys 0] } else { set key $keys } set out {} foreach {k v} $dict { if {![string equal $k $key]} { lappend out $k lappend out $v } } if {[llength $keys] > 1} { set out [exec_prim_dict_replace [list $out {*}[lrange $keys 0 end-1] $out]] } return $out } proc exec_prim_dict_replace {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 3} { call error "wrong # args: should be \"dict replace dictionary key ?key ...? value\"" return } set dict [lindex $arguments 0] set keys [lrange $arguments 1 end-1] set value [lindex $arguments end] set kstack [lrange $keys 0 end-1] set vstack {} set d $dict while {[llength $kstack] > 0} { set v2 {} foreach {k v} $d { if {[string equal $k [lindex $kstack 0]]} { set v2 $v } } lappend vstack $v2 set d $v2 set kstack [lrange $kstack 1 end] } lappend vstack $value while {[llength $vstack] > 0} { set temp [lindex $vstack end-1] lappend temp [lindex $keys end] lappend temp [lindex $vstack end] lset vstack end-1 $temp set keys [lrange $keys 0 end-1] set vstack [lrange $vstack 0 end-1] } set dict $vstack return $dict } proc exec_prim_dict_set {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 3} { call error "wrong # args: should be \"dict set varName key ?key ...? value\"" return } set varname [lindex $arguments 0] set keys [lrange $arguments 1 end-1] set value [lindex $arguments end] set bool [exec_prim_var_exists? $varname] if {$bool} { set dict [exec_prim_get $varname] } lset arguments 0 $dict set dict [exec_prim_dict_replace $arguments] return [exec_prim_set [list $varname $dict]] } proc exec_prim_dict_size {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 1} { call error "wrong # args: should be \"dict size dictionary\"" return } return [expr {[length $arguments] / 2}] } proc exec_prim_dict_unset {arguments} { upvar state state log invoked [info level] [info level 0] # use dict remove call error "not yet implemented!" } proc exec_prim_dict_update {arguments} { upvar state state log invoked [info level] [info level 0] call error "not yet implemented!" } proc exec_prim_dict_values {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"dict values dictionary ?pattern?\"" return } set result {} set pattern * if {[llength $arguments] == 3} { set pattern [lindex $arguments 2] } foreach {key value} [lindex $arguments 1] { if {[string match $pattern $value]} { lappend result $value } } return $result } proc exec_prim_dict_with {arguments} { upvar state state log invoked [info level] [info level 0] call error "not yet implemented!" } # prim dict -end- proc exec_prim_die {arguments} { upvar state state log invoked [info level] [info level 0] set result {} dict set state running no dict lappend state out_queue [list die $arguments] return $result } proc exec_prim_drop_capability {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 1} { call error "wrong # args: should be \"drop_capability <address>\"" return } if {![dict exists $state capabilities]} { error "an capicol without an capabilities dict key" } if {[set r [lsearch -exact [dict get $state capabilities] $arguments]] == -1} { call error "this capicol doesnt have address $arguments on its capabilities list" return } dict set state capabilities [lreplace [dict get $state capabilities] $r $r] } proc exec_prim_error {arguments} { upvar state state log invoked [info level] [info level 0] while true { if {[dict exists $state frame catcher]} break if {[string equal [dict get $state returnstack] ""]} { call die error $arguments return } exec_prim_return {} } set catcher [dict get $state frame catcher] dict unset state frame catcher exec_prim_set [list $catcher $arguments] return true } proc exec_prim_gain {arguments} { upvar state state log invoked [info level] [info level 0] call error "not yet implemented!" } proc exec_prim_get {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 1} { call error "wrong # args: should be \"get varName\" return } if {![dict exists $state variables $arguments]} { call error "can't read \"[set arguments]\": no such variable" return } return [dict get $state variables $arguments] } proc exec_prim_if {arguments} { upvar state state log invoked [info level] [info level 0] # only primitive if supported: # if <test> <yes-command> [else <no-command>] if {([llength $arguments] < 2) || (4 < [llength $arguments])} { call error "wrong # args: should be \"if test yes-body \[else no-body\]\"" return } if {([llength $arguments] == 4) && ![string equal "else" [lindex $arguments 2]]} { call error "else keyword missing" return } set test [lindex $arguments 0] set true [lindex $arguments 1] set false {} if {[llength $arguments] == 4} { set false [lindex $arguments 3] } set code [list uplevel 1 $test] lappend code [list __branch "\[0\]" 4] lappend code [list uplevel 1 $false] lappend code [list __jump 5] lappend code [list uplevel 1 $true] lappend code [list] push_continuation $state dict set state frame code $code dict set state frame pointer -1 return } proc exec_prim_lappend {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] < 1} { call error "wrong # args: should be \"lappend varname ?value ...?\"" return } set result [exec_prim_get [lindex $arguments 0]] foreach item [lrange $arguments 1 end] { lappend result $item } exec_prim_set [list [lindex $arguments 0] $result] return $result }; # var hér proc exec_prim_lassign {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"lassign list varname ?varname ...?\""] $state] } set list [lindex $arguments 0] set vars [lrange $arguments 1 end] set counter 0 foreach var $vars { lassign [exec_prim_set [list $var [lindex $list $counter]] $state] _ state incr counter } set result [lrange $list $counter end] return [list $result $state] } proc exec_prim_lindex {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 1} { return [call [list error "wrong # args: should be \"lindex list ?index ...?\""] $state] } set list [lindex $arguments 0] set indexes [lrange $arguments 1 end] foreach item $indexes { if {![string is digit $item] && \ ![string equal -length 3 "end" $item] && \ ![string equal -length 4 "end-" $item]} { return [call [list error "bad index \"[set item]\": must be integer or end?-integer?"] $state] } set list [lindex $list $item] } return [list $list $state] } proc exec_prim_linsert {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 3} { return [call [list error "wrong # args: should be \"linsert list index element ?element ...?\""] $state] } set list [lindex $arguments 0] set index [lindex $arguments 1] if {![string is digit $index] && \ ![string equal -length 3 "end" $index] && \ ![string equal -length 4 "end-" $index]} { return [call [list error "bad index \"[set index]\": must be integer or end?-integer?"] $state] } if {[string equal -length "end-" $index]} { set index [expr {[llength $list] - [string range $index 4 end]} } set elements [lrange $arguments 2 end] foreach item $elements { set list [linsert $list $index $item] incr index +1 } return [list $list $state] } proc exec_prim_list {arguments state} { log invoked [info level] [info level 0] # this is intentionaly nearly empty! return [list $arguments $state] } proc exec_prim_llength {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments != 1} { return [call [list error "wrong # args: should be \"llength list\""] } return [list [llength [lindex $arguments 0]] $state] } proc exec_prim_lrange {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments != 3} { return [call [list error "wrong # args: should be \"lrange list first last\""] } set list [lindex $arguments 0] set first [lindex $arguments 1] if {![string is digit $first] && \ ![string equal -length 3 "end" $first] && \ ![string equal -length 4 "end-" $first]} { return [call [list error "bad index \"[set first]\": must be integer or end?-integer?"] $state] } set last [lindex $arguments 2] if {![string is digit $last] && \ ![string equal -length 3 "end" $last] && \ ![string equal -length 4 "end-" $last]} { return [call [list error "bad index \"[set last]\": must be integer or end?-integer?"] $state] } return [list [lrange $list $first $last] $state] } proc exec_prim_lrepeat {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"lrepeat positiveCount value ?value ...?\""] $state] } set counter [lindex $arguments 0] if {![string is digit $counter]} { return [call [list error "expected integer but got \"[set counter]\""] $state] } if {$counter < 1} { return [call [list error "must have a count of at least 1"] $state] } set values [lrange $arguments 1 end] set result {} while {$counter > 0} { foreach value $values { lappend result $value } incr counter -1 } return [list $result $state] } proc exec_prim_lsearch {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"lsearch ?options? list pattern\""] $state] } set list [lindex $arguments end-1] set pattern [lindex $arguments end] set options [lrange $arguments 0 end-2] set option-all no set option-ascii no set option-decreasing no set option-dictionary no set option-exact no set option-glob no set option-increasing no set option-index "" set option-inline no set option-integer no set option-not no set option-real no set option-regexp no set option-sorted no set option-start "" set option-subindices no set index 0 while {$index < [llength $options]} { set item [lindex $options $index] incr index if {[string equal $item "-all"]} { set option-all yes } elseif {[string equal $item "-ascii"]} { set option-ascii yes } elseif {[string equal $item "-decreasing"]} { set option-decreasing yes } elseif {[string equal $item "-dictionary"]} { set option-dictionary yes } elseif {[string equal $item "-exact"]} { set option-exact yes if {$option-glob || $option-regexp} { return [call [list error "make up your damn mind about the options to lsearch will ya!"] $state] } } elseif {[string equal $item "-glob"]} { set option-glob yes if {$option-exact || $option-regexp} { return [call [list error "make up your damn mind about the options to lsearch will ya!"] $state] } } elseif {[string equal $item "-increasing"]} { set option-increasing yes } elseif {[string equal $item "-index"]} { set option-index [lindex $options $index] incr index if {![string is digit $option-index] && \ ![string equal -length 3 "end" $option-index] && \ ![string equal -length 4 "end-" $option-index]} { return [call [list error "bad index \"[set option-index]\": must be integer or end?-integer?" } } elseif {[string equal $item "-inline"]} { set option-inline yes } elseif {[string equal $item "-not"]} { set option-not yes } elseif {[string equal $item "-real"]} { set option-real yes } elseif {[string equal $item "-regexp"]} { set option-regexp yes if {$option-glob || $option-exact} { return [call [list error "make up your damn mind about the options to lsearch will ya!"] $state] } } elseif {[string equal $item "-sorted"]} { set sorted yes } elseif {[string equal $item "-start"]} { set option-start [lindex $options $index] incr index if {![string is digit $option-start] && \ ![string equal -length 3 "end" $option-start] && \ ![string equal -length 4 "end-" $option-start]} { return [call [list error "bad index \"[set option-start]\": must be integer or end?-integer?" } } elseif {[string equal $item "-subindices"]} { set subindices yes if {[string equal $option-index ""]} { return [call [list error "-subindices cannot be used without -index option"] $state] } } else { return [call [list error "bad option \"[set item]\": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start or -subindices"] $state] } } set tmp "lsearch" if {$option-all} { lappend tmp -all } if {$option-ascii} { lappend tmp -ascii } if {$option-decreasing} { lappend tmp -decreasing } if {$option-dictionary} { lappend tmp -dictionary } if {$option-exact} { lappend tmp -exact } if {$option-glob} { lappend tmp -glob } if {$option-increasing} { lappend tmp -increasing } if {![string equal $option-index ""]} { lappend tmp -index $option-index } if {$option-inline} { lappend tmp -inline } if {$option-integer} { lappend tmp -integer } if {$option-not} { lappend tmp -not } if {$option-real} { lappend tmp -real } if {$option-regexp} { lappend tmp -regexp } if {$option-sorted} { lappend tmp -sorted } if {![string equal $option-start ""]} { lappend tmp -start $option-start } if {$option-subindices} { lappend tmp -subindices } lappend tmp $list lappend tmp $pattern if {[catch $tmp result]} { return [call [list error $result] $state] } return [list $result $state] } proc exec_prim_lset {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 3} { return [call [list error "lset listVar index ?index...? value"] $state] } set listvar [lindex $arguments 0] set indexes [lrange $arguments 1 end-1] set value [lindex $arguments end] lassign [exec_prim_var_exists? $listvar $state] exists state if {!$exists} { return [call [list error "can't read \"$listvar\": no such variable"] $state] } lassign [exec_prim_get $listvar $state] listval state set stack "" set counter -1 foreach index $indexes { if {![string is digit $index] && \ ![string equal -length 3 "end" $index] && \ ![string equal -length 4 "end-" $index]} { return [call [list error "bad index \"[set index]\": must be integer or end?-integer?" } lappend stack $listval set listval [lindex $listval $index] incr counter } lappend stack $value while {$counter > -1} { set listval [lreplace [lindex $stack $counter] [lindex $indexes $counter] [lindex $indexes $counter]] } lassign [exec_prim_set [list $listvar $listval] $state] _ state return [list $listval $state] } proc exec_prim_lsort {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 1} { return [call [list error "wrong # args: should be \"lsort ?options? list\""] $state] } set list [lindex $arguments end] set options [lrange $arguments 0 end-1] set option-ascii no set option-creasing in set option-dictionary no set option-index "" set option-indices no set option-integer no set option-real no set option-unique no set index 0 while {$index < [llenght $options]} { set item [lindex $options $index] incr index if {[string equal $item "-ascii"]} { set option-ascii yes } elseif {[string equal $item "-command"]} { set option-command [lindex $options $index] incr index return [call [list error "sorry not yet implemented! too tricky as it is!"] $state] } elseif {[string equal $item "-decreasing"]} { set option-creasing de } elseif {[string equal $item "-dictionary"]} { set option-dictionary yes } elseif {[string equal $item "-index"]} { set option-index [lindex $options $index] incr index if {![string is digit $option-index] && \ ![string equal -length 3 "end" $option-index] && \ ![string equal -length 4 "end-" $option-index]} { return [call [list error "bad index \"[set option-index]\": must be integer or end?-integer?"] $state] } } elseif {[string equal $item "-indices"]} { set option-indices yes } elseif {[string equal $item "-integer"]} { set option-integer yes } elseif {[string equal $item "-real"]} { set option-real yes } elseif {[string equal $item "-unique"]} { set option-unique yes } else { return [call [list error "bad option \"[set item]\": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -real, or -unique"] $state] } } set tmp "lsort" if {$option-ascii} { lappend tmp -ascii } if {[string equal "de" $option-creasing]} { lappend tmp -decreasing } if {$option-dictionary} { lappend tmp -dictionary } if {![string equal "" $option-index]} { lappend tmp -index $option-index } if {$option-indices} { lappend tmp -indices } if {$option-integer} { lappend tmp -integer } if {$option-real} { lappend tmp -real } if {$option-unique} { lappend tmp -unique } lappend tmp $list if {[catch $tmp result]} { return [call [list error $result] $state] } return [list $result $state] } proc exe_prim_next_message {arguments state} { log invoked [info level] [info level 0] # no pattern matching or anything fancy if {[llength [dict get $state in-queue]] == 0} { # suspend the capicol state for a retry later dict set state running no dict incr state pointer -1 return [list <?promise?> $state] } set message [lindex [dict get $state in-queue] 0] dict set state in-queue [lrange [dict get $state in-queue] 1 end] lassign $message addresses data quota lassign [caphandles_from_adddresses $addresses $state] caphandles state dict incr state quota $quota lset message 0 $caphandles return [list $message $state] } proc exec_prim_logical_or {arguments state} { log invoked [info level] [info level 0] set result [lindex $arguments 0] foreach item [lrange $arguments 1 end] { set result [expr $result || $item] } return [list $result $state] } proc exec_prim_rename {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"rename oldName newName\""] $state] } set old [lindex $arguments 0] set new [lindex $arguments 1] if {![dict exists $state commands $old]} { return [call [list error "no such command: $old"] $state] } if {[dict exists $state commands $new]} { return [call [list error "$new exists already"] $state] } if {![string equal $new ""]} { dict set state commands $new [dict get $state commands $old] } dict unset state commands $old return [list {} $state] } proc exec_prim_return {arguments state} { log invoked [info level] [info level 0] # return from a routine command if {[llength $arguments] == 1} { set result [lindex $arguments 0] } else { set last_result_index [lindex [lsort [dict keys [dict get $state frame results] *]] end] set result [dict get $state frame results $last_result_index] } if {0 == [llength [dict get $state returnstack]]} { return [exec_prim_die "end of program" $state] } # related to uplevel -begin- if {[dict exists $state frame saveto]} { dict set state frame saveto variables [dict get $state frame variables] } # related to uplevel -end- dict set state frame [lindex [dict get $state returnstack] end] dict set state returnstack [lrange [dict get $state returnstack] 0 end-1] # related to uplevel -begin- if {[dict exists $state frame saveto]} { set t1 [dict get $state frame saveto dest] set t2 [dict get $state frame saveto variables] set t3 [lindex [dict get $state returnstack] $t1] set t4 [dict merge $t3 [list variables $t2]] set t5 [lreplace [dict get $state returnstack] $t1 $t1 $t4] dict set state returnstack $t5 dict unset state frame saveto } # related to uplevel -end- dict set state results \[[dict get $state frame pointer]\] $result return [list $result $state] } proc exec_prim_routine {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"routine name body\"] $state] } set name [lindex $arguments 0] set body [lindex $arguments 1] if {[dict exists $state commands $name]} { return [call [list error "command already exists!"] $state] } dict set state commands $name type script dict set state commands $name contents $body set state [space_quota_check $state] return [list $name $state] } proc exec_prim_command_exists? {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"command_exists? name\"] $state] } set name [lindex $arguments 0] return [list [dict exists $state commands $name]} { } proc exec_prim_send_message {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"send_message caphandles data ?quota?\"] $state] } set caphandles [lindex $arguments 0] set data [lindex $arguments 1] set quota [lindex $arguments 2] if {[string equal $quota ""]} { set quota [string length $data] } if {$quota < [string length $data]} { return [call [list error "not enaugh quota alotted for data to be sent"] $state] } if {[dict get $state quota] < $quota} { return [call [list error "not enaugh quota to send message"] $state] } dict lappend state out_queue [list message [addresses_from_caphandles $caphandles] $data $quota] return [list {} $state] } proc exec_prim_set {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"set varName value\""] $state] } set varname [lindex $arguments 0] set value [lindex $arguments 1] dict set state variables $varname $value return [list $value $state] } proc exec_prim_string {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 1} { return [call [list error "wrong # args: should be \"string option arg ?arg ...?\""] $state] } set subcommand [lindex $arguments 0] set rest [lrange $arguments 1 end] switch -exact -- $subcommand { "bytelength" { return [exec_prim_string_bytelength $rest $state] } "compare" { return [exec_prim_string_compare $rest $state] } "equal" { return [exec_prim_string_equal $rest $state] } "first" { return [exec_prim_string_first $rest $state] } "index" { return [exec_prim_string_index $rest $state] } "is" { return [exec_prim_string_is $rest $state] } "last" { return [exec_prim_string_last $rest $state] } "length" { return [exec_prim_string_length $rest $state] } "map" { return [exec_prim_string_map $rest $state] } "match" { return [exec_prim_string_match $rest $state] } "range" { return [exec_prim_string_range $rest $state] } "repeat" { return [exec_prim_string_repeat $rest $state] } "replace" { return [exec_prim_string_replace $rest $state] } "tolower" { return [exec_prim_string_tolower $rest $state] } "toupper" { return [exec_prim_string_toupper $rest $state] } "totitle" { return [exec_prim_string_totitle $rest $state] } "trim" { return [exec_prim_string_trim $rest $state] } "trimleft" { return [exec_prim_string_trimleft $rest $state] } "trimright" { return [exec_prim_string_trimright $rest $state] } "wordend" { return [exec_prim_string_wordend $rest $state] } "wordstart" { return [exec_prim_string_wordstart $rest $state] } default { return [call [list error "bad option \"[set subcommand]\": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart"] $state] } } } proc exec_prim_string_bytelength {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"string bytelength string\""] $state] } return [list [string bytelength [lindex $arguments 0]] $state] } proc exec_prim_string_compare {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"string compare ?-nocase? ?-length int? string1 string2\""] $state] } set string1 [lindex $arguments end-1] set string2 [lindex $arguments end] set options [lrange $arguments 0 end-2] set option-nocase no set option-length "" set index 0 while {$index < [llength $options]} { set item [lindex $options $index] incr index if {[string equal $item "-nocase"]} { set option-nocase yes } elseif {[string equal $item "-length"]} { set option-length [lindex $options $index] incr index } else { return [call [list error "bad option \"[set item]\": must be -nocase or -length"] $state] } } set tmp "string" lappend tmp "compare" if {$option-nocase} { lappend tmp -nocase } if {![string equal $option-length ""]} { lappend tmp -length lappend tmp $option-length } lappend tmp $string1 lappend tmp $string2 catch $tmp result return [list $result $state] } proc exec_prim_string_equal {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"string equal ?-nocase? ?-length int? string1 string2\""] $state] } set string1 [lindex $arguments end-1] set string2 [lindex $arguments end] set options [lrange $arguments 0 end-2] set option-nocase no set option-length "" set index 0 while {$index < [llength $options]} { set item [lindex $options $index] incr index if {[string equal $item "-nocase"]} { set option-nocase yes } elseif {[string equal $item "-length"]} { set option-length [lindex $options $index] incr index } else { return [call [list error "bad option \"[set item]\": must be -nocase or -length"] $state] } } set tmp "string" lappend tmp "equal" if {$option-nocase} { lappend tmp -nocase } if {![string equal $option-length ""]} { lappend tmp -length lappend tmp $option-length } lappend tmp $string1 lappend tmp $string2 catch $tmp result return [list $result $state] } proc exec_prim_string_first {arguments state} { log invoked [info level] [info level 0] if {([llength $arguments] < 2) || ([llength $arguments] > 3)} { return [call [list error "wrong # args: should be \"string first subString string ?startIndex?\""] $state] } set substring [lindex $arguments 0] set string [lindex $arguments 1] set startIndex [lindex $argumnets 2] if {[string equal $startIndex ""]} { set startIndex 0 } if {![string is digit $startIndex] && \ ![string equal -length 3 $startIndex "end"] && \ ![string equal -length 4 $startIndex "end-"]} { return [call [list error "bad index \"[set startIndex]\": must be integer or end?-integer?"] $state] } return [list [string first $substring $string $startIndex] $state] } proc exec_prim_string_index {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"string index string charIndex\""] $state] } set string [lindex $arguments 0] set index [lindex $arguments 1] if {![string is digit $index] && \ ![string equal -length 3 $index "end"] && \ ![string equal -length 4 $index "end-"]} { return [call [list error "bad index \"[set index]\": must be integer or end?-integer?"] $state] } return [list [string index $string $index] $state] } proc exec_prim_string_is {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] < 2} { return [call [list error "wrong # args: should be \"string is class ?-strict? string\""] $state] } set class [lindex $arguments 0] set string [lindex $arguments end] set option-strict [expr {([string equal "-strict" [lindex $arguments 1]] && ([llength $arguments] == 3)}] if {[lsearch -exact {alnum alpha ascii control boolean digit double false graph integer lower print punct space true upper wordchar xdigit} $class] == -1} { return [call [list error "bad class \"[set class]\": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, space, true, upper, wordchar or xdigit"] $state] } set tmp "string" lappend tmp "is" lappend tmp $class if {$option-strict} { lappend tmp -strict } lappend tmp $string catch $tmp result return [list $result $state] } proc exec_prim_string_last {arguments state} { log invoked [info level] [info level 0] if {([llength $arguments] < 2) || ([llength $arguments] > 3)} { return [call [list error "wrong # args: should be \"string last subString string ?startIndex?\""] $state] } set substring [lindex $arguments 0] set string [lindex $arguments 1] set startIndex [lindex $argumnets 2] if {[string equal $startIndex ""]} { set startIndex 0 } if {![string is digit $startIndex] && \ ![string equal -length 3 $startIndex "end"] && \ ![string equal -length 4 $startIndex "end-"]} { return [call [list error "bad index \"[set startIndex]\": must be integer or end?-integer?"] $state] } return [list [string last $substring $string $startIndex] $state] } proc exec_prim_string_length {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"string length string\""] $state] } return [list [string length [lindex $arguments 0]] $state] } proc exec_prim_string_map {arguments state} { log invoked [info level] [info level 0] } proc exec_prim_string_match {arguments state} {} proc exec_prim_string_range {arguments state} {} proc exec_prim_string_repeat {arguments state} {} proc exec_prim_string_tolower {arguments state} {} proc exec_prim_string_toupper {arguments state} {} proc exec_prim_string_totitle {arguments state} {} proc exec_prim_string_trim {arguments state} {} proc exec_prim_string_trimleft {arguments state} {} proc exec_prim_string_trimright {arguments state} {} proc exec_prim_string_wordend {arguments state} {} proc exec_prim_string_wordstart {arguments state} {} proc exec_prim_unset {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"unset varname\""] $state] } dict unset state frame variables $arguments return [list "" $state] } proc exec_prim_uplevel {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"uplevel level script\""] $state] } set level [lindex $arguments 0] set script [lindex $arguments 1] if {[string equal [string index $level 0] "#"]} { set relative {} set level [string range $level 1 end] } else { set relative "end-" } if {![string is digit $level]} { return [call [list error "level must be an number optionaly preceded with #"] $state] } set state [push_continuation $state] set frame [lindex [dict get $state returnstack] [set relative][set level]] dict set state frame variables [dict get $frame variables] dict set state frame args [dict get $frame args] dict set state frame saveto dest [set relative][set level] dict set state frame pointer -1 dict set state frame code [translate [lindex $arguments 1]] return [list {} $state] } proc exec_prim_var_exists? {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"var_exists? varName\""] $state] } return [list [dict exists $state variables $arguments] $state] } proc exec_prim_while {arguments state} { log invoked [info level] [info level 0] # not done if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"while test script\""] $state] } set code [list error "<empty jump slot>"] # script body: lappend code [list uplevel 1 [lindex $arguments 1]] lset code 0 [list __jump [llength $code]] # here I use the picol way: test is an script lappend code [list uplevel 1 [lindex $arguments 0]] lappend code [list __branch "\[[llength $code]\]" 1] return [call $code $state] } proc exec_prim___branch {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 2} { return [call [list error "wrong # args: should be \"__branch condition destination\""] $state] } if {![string is bool [lindex $arguments 0]]} { return [call [list error "condition must be an boolean value"] $state] } if {![string is digit [lindex $arguments 1]]} { return [call [list error "destination must be numerical"] $state] } if {[string is true [lindex $arguements 0]]} { dict set state frame pointer [expr $arguments - 1] } return [list {} $state] } proc exec_prim___jump {arguments state} { log invoked [info level] [info level 0] if {[llength $arguments] != 1} { return [call [list error "wrong # args: should be \"__jump destination\""] $state] } if {![string is digit $arguments]} { return [call [list error "destination must be numerical"] $state] } dict set state frame pointer [expr $arguments - 1] return [list {} $state] } proc add_capability {address state} { log invoked [info level] [info level 0] if {![dict exists $state capabilities counter]} { dict set state capabilities counter [expr 2 * [dict size [dict get $state capabilities]]] } if {[lsearch [dict keys $state capabilities] $address] == -1} { set handle cap[dict incr state capabilities counter] dict set state capabilities $handle $address } else { foreach {handle item} [dict get $state capabilities] { if {[string equal $item $address]} break } } return [list $handle $state] } proc addresses_from_caphandles {caphandles state} { log invoked [info level] [info level 0] set addresses {} set caphandles [dict get $state capabilities] foreach caphandle $caphandles { if {![dict exists $capabilities $caphandle]} { error "no such caphandle: $caphandle" } lappend addresses [dict get $capabilities $caphandle] } return [list $addresses $state] } proc caphandles_from_adddresses {addresses state} { log invoked [info level] [info level 0] set tmp [list] foreach item $addresses { lassign [add_capability $item $state] caphandle state lappend tmp $caphandle } return [list $tmp $state] } proc new_state {address} { log invoked [info level] [info level 0] dict set c my_address $address dict set c frame args {} dict set c frame pointer 0 dict set c frame results {} dict set c frame variables {} dict set c frame code [list [list error "capicol::new_state doesnt supply the code! you do!"]] dict set c returnstack {} set alist [list] foreach content {+ - * / % & | ^ < << >> <= == != and any_messages? args beget break catch capabilities continue dict die drop_capability error gain get if lappend lassign lindex linsert list llength lrange lrepeat lreplace lsearch lset lsort next_message or rename return routine send_message set string uplevel var_exists? while __branch __jump } { lappend alist $content [list type prim contents $content] } dict set c commands $alist dict set c quota [expr [string length [dict get $state commands]] + \ [string length [dict get $state returnstack]] + \ [string length [dict get $state frame]]] return $c } } namespace eval capicol::runtime { variable capicols {} variable runlist {} proc run_one_slice {} { log invoked [info level] [info level 0] variable capicols variable runlist set name [lindex $runlist 0] set runlist [join [list [lrange $runlist 1 end] [list $name]]] set state [dict get $capicols $name] if {![dict exists $state run_slice_size]} { dict set state run_slice_size 8 } set counter [dict get $state run_slize_size] while {[dict get $state running]} { set state [::capicol::interp::advance $state] if {$counter == 0} { break } incr counter -1 } if {![dict get $state running]} { deschedule $name } handle_outmessages $state } proc handle_outmessages {state} { log invoked [info level] [info level 0] set messages [dict get $state out_queue] dict set state out_queue {} dict set capicols $name $state foreach message $messages { set type [lindex $message 0] switch -exact -- $type { "die" { set reason [lindex $message 1] set message [list capicol-death $name $reason $state] unschedule $name dict unset capicols $name set creator [join [lrange [split $name "."] 0 end-1]"."] send_message [list $creator $message [string length $message]] break } "beget" { set child_name [lindex $message 1] set startup_code [lindex $message 3] set addresses [lindex $message 4] set quota [lindex $message 5] set child [::capicol::interp::new_state $child_name] dict incr child quota $quota lassign [caphandles_from_adddresses $addresses $child] dummy child dict set child code [translate $startup_code] variable capicols dict set capicols $child_name $child schedule $child_name } "gain" { set certificate [lindex $message 1] # requires SEXP and SPKI # where an certificate contains # . a set of capabilities (capicol addresses in this instance) can be granted to # eather an prinicipal (see SPKI docu) or an capicol # . more quota can be granted to eather an principal or an capicol # . an forzen capicol state that can be thawed and run # . an beget code as in the beget capicol primitive } "message" { send_message $name [lindex $message 1] } default { error "unknown out-queue type: [set type] in $message" } } } return } proc schedule {name} { log invoked [info level] [info level 0] variable capicols variable runlist dict set capicols $name running yes if {![dict exists $capicols $name run_slice_size]} { dict set capicols $name run_slice_size 8 } if {[lsearch -exact $runlist $name] == -1} { lappend runlist $name } return } proc deschedule {name} { log invoked [info level] [info level 0] variable capicols variable runlist dict set capicols $name running no set t [lsearch -exact $runlist $name] set runlist [lreplace $runlist $t $t] return } proc send_message {sender message} { log invoked [info level] [info level 0] variable capicols lassign $message addresses lassign $addresses destination if {[dict exists $capicols $destination]} { # internal (between capicols on same machine/runtime) schedule $destination set t [dict get $capicols $destination in_queue] lappend t $message dict set $capicols $destination in_queue $t } else { # external (to external objects and between capicols on diffrent machines/runtimes) variable external_handlers foreach {pattern command} $external_handlers { if {[string match $patter $destination]} { append command " " append command [list $destination] append command " " append command [list $sender] append command " " append command [list $message] catch $command } } } return } proc register_external_handler {pattern command} { variable external_handlers set external_handlers "[list $command] [set external handlers]" set external_handlers "[list $pattern] [set external handlers]" return } proc unregister_external_handler {pattern command} { variable external_handlers set index 0 foreach {p c} $external_handlers { if {[string equal $p $pattern] && [string equal $c $command]} { set external_handlers [lreplace $external_handlers $index [expr $index +1]] return } incr index 2 } } proc store_snapshot {filename} { set fd [open $filename w] fconfigure $fd -encoding utf-8 variable capicols variable runlist dict set tmp runlist $runlist dict set tmp capicols $capicols puts $fd $tmp close $fd } proc load_snapshot {filename} { set fd [open $filname r] fconfigure $fd -encoding utf-8 set tmp [read $fd] close $fd variable capicols [dict get $tmp capicols] variable runlist [dict get $tmp runlist] } proc looper {} { run_one_slice after idle [list ::capicol::runtime::looper] } proc start {} { after idle [list ::capicol::runtime::looper] } }