Zarutian 3. july 2007: Capicol is an variant of picol wich in turn is an variant of Tcl. Capicol stands for Capability picol and is my investigation into capability based security and asynchronus message passing in concurrent enviroment. It is not complete yet and probably very slow. (I want to get it right before fast, thank you)
# 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.1
package require Tcl 8.5
package provide capicol 0.3
# state:
# running
# <boolean>
# quota
# <number>
# capabilities
# <caphandle>
# <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
proc log args {
if {[string equal [lindex $args 0] "invoked"]} {
set call_level [lindex $args 1]
puts "log: [string repeat { } $call_level] invoked [lindex $args 2 0]"
} else {
puts "log: $args"
}
}
namespace eval capicol {}
proc capicol::basic_tester {code} {
set t1 [capicol::new_state]
dict set t1 frame code $code
set i [llength $code]
while {$i > 0} {
set t1 [capicol::advance $t1]
incr i -1
}
return $t1
}
# tests (not complete and should be moved to the end)
# capicol::basic_tester {{+ 1 2 3}}
# capicol::basic_tester {{- 3 2 1}}
# capicol::basic_tester {{* 5 3 2}}
# capicol::basic_tester {{/ 60 5 2}}
# capicol::basic_tester {{% 20 4}}
# capicol::basic_tester {{& 0xFF 0x0E}}
# capicol::basic_tester {{| 0xF0 0x0F}}
# capicol::basic_tester {{^ 0xF0 0x0F}}
# capicol::basic_tester {{<< 2 1}}
# capicol::basic_tester {{>> 8 2}}
# capicol::basic_tester {{< 10 5}}
# capicol::basic_tester {{<= 9 10}}
# capicol::basic_tester {{== 20 20}}
# capicol::basic_tester {{!= 20 20}}
# capicol::basic_tester {{and yes yes}}
# capicol::basic_tester {{any_messages?}}
proc capicol::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
set state [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]
lassign [exec_prim [dict get $state commands $cmd contents] $args $state] result state
dict set state frame results $pointer $result
} 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]} {
lassign [call [list error "unknown command $cmd"] $state] _ state
} else {
# invoke the unknown command
lassign [call [list unknown [set cmd&args]] $state] temp state
dict set state frame results \[[dict get $state pointer]\] $temp
}
}
if {[llength [dict get $state frame code]] < [dict get $state frame pointer]} {
set state [lindex [exec_prim_return {} $state] end]
}
if {([string length [dict get $state commands]] + \
[string length [dict get $state returnstack]] + \
[string length [dict get $state frame]]) > [dict get $state quota]} {
lassign [call [list error "not enaugh quota to run!"] $state] _ state
}
dict set state frame pointer [expr [dict get $state frame pointer] + 1]; # autoincr
return $state
}
proc capicol::push_continuation {state} {
log invoked [info level] [info level 0]
set temp [dict create]
dict lappend state returnstack [dict get $state frame]
return $state
}
proc capicol::call {cmd&args state} {
log invoked [info level] [info level 0]
set state [push_continuation $state]
dict set state frame code [list [set cmd&args]]
dict set state frame pointer -1
return [list {} $state]
}
proc capicol::exec_prim {prim arguments 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
switch -exact -- $prim {
"+" { return [exec_prim_math + $arguments $state] }
"-" { return [exec_prim_math - $arguments $state] }
"*" { return [exec_prim_math * $arguments $state] }
"/" { return [exec_prim_math / $arguments $state] }
"%" { return [exec_prim_math % $arguments $state] }
"&" { return [exec_prim_math & $arguments $state] }
"|" { return [exec_prim_math | $arguments $state] }
"^" { return [exec_prim_math ^ $arguments $state] }
"<<" { return [exec_prim_math << $arguments $state] }
">>" { return [exec_prim_math >> $arguments $state] }
"<" { return [exec_prim_compare < $arguments $state] }
"<=" { return [exec_prim_compare <= $arguments $state] }
"==" { return [exec_prim_compare == $arguments $state] }
"!=" { return [exec_prim_compare != $arguments $state] }
"and" { return [exec_prim_logical_and $arguments $state] }
"any_messages?" { return [exec_prim_any_messages? $arguments $state] }
"args" { return [exec_prim_args $arguments $state] }
"beget" { return [exec_prim_beget $arguments $state] }
"break" { return [exec_prim_break $arguments $state] }
"catch" { return [exec_prim_catch $arguments $state] }
"capabilities" { return [exec_prim_capabilites $arguments $state] }
"continue" { return [exec_prim_continue $arguments $state] }
"dict" { return [exec_prim_dict $arguments $state] }
"die" { return [exec_prim_die $arguments $state] }
"drop_capability" { return [exec_prim_drop_capability $arguments $state] }
"error" { return [exec_prim_error $arguments $state] }
"gain" { return [exec_prim_gain $arguments $state] }
"get" { return [exec_prim_get $arguments $state] }
"if" { return [exec_prim_if $arguments $state] }
"lappend" { return [exec_prim_lappend $arguments $state] }
"lassign" { return [exec_prim_lassign $arguments $state] }
"lindex" { return [exec_prim_lindex $arguments $state] }
"linsert" { return [exec_prim_linsert $arguments $state] }
"list" { return [exec_prim_list $arguments $state] }
"llength" { return [exec_prim_llength $arguments $state] }
"lrange" { return [exec_prim_lrange $arguments $state] }
"lrepeat" { return [exec_prim_lrepeat $arguments $state] }
"lsearch" { return [exec_prim_lsearch $arguments $state] }
"lset" { return [exec_prim_lset $arguments $state] }
"lsort" { return [exec_prim_lsort $arguments $state] }
"next_message" { return [exec_prim_next_message $arguments $state] }
"or" { return [exec_prim_or $arguments $state] }
"rename" { return [exec_prim_rename $arguments $state] }
"return" { return [exec_prim_return $arguments $state] }
"routine" { return [exec_prim_routine $arguments $state] }
"send_message" { return [exec_prim_send_message $arguments $state] }
"set" { return [exec_prim_Set $arguments $state] }
"string" { return [exec_prim_string $arguments $state] }
"unset" { return [exec_prim_unset $arguments $state] }
"uplevel" { return [exec_prim_uplevel $arguments $state] }
"var_exists?" { return [exec_prim_var_exists? $arguments $state] }
"while" { return [exec_prim_while $arguments $state] }
"__branch" { return [exec_prim___branch $arguments $state] }
"__jump" { return [exec_prim___jump $arguments $state] }
default { error "unknown capicol primitive $prim" }
}
}
proc capicol::exec_prim_math {op arguments state} {
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 [list $result $state]
}
proc capicol::exec_prim_compare {op arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] != 2} {
return [call [list error "wrong # args: should be \"$op number number\""] $state]
}
set result [expr [lindex $arguments 0] $op [lindex $arguments 1]]
return [list $result $state]
}
proc capicol::exec_prim_logical_and {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 capicol::exec_prim_any_messages? {arguments state} {
log invoked [info level] [info level 0]
if {![dict exists $state in_queue]} {
dict set state in_queue {}
}
return [list [expr [llength [dict get $state in_queue]] != 0] $state]
}
proc capicol::exec_prim_args {arguments state} {
log invoked [info level] [info level 0]
if {![dict exists $state frame args]} {
dict set state frame args {}
}
return [list [dict get $state frame args] $state]
}
proc capicol::exec_prim_beget {arguments state} {
log invoked [info level] [info level 0]
# beget <startup script> <capabilities> <quota> returns <capability>
if {[llength $arguments] != 3} {
return [call [list error "wrong # args: should be \"beget startupscript capabilities quota\""] $state]
}
# 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]"
if {[catch [list addresses_from_caphandles [lindex $arguments 1] $state] res]} {
return [call [list error $res] $state]
} else {
set addresses [lindex $res 0]
set state [lindex $res end]
unset res
}
set res [add_capability $child $state]
set state [lindex $res end]
set handle [lindex $res 0]
unset res
if {[dict get $state quota] < $quota} {
return [call [list error "not enaugh quota!"] $state]
}
if {$quota < [string length [lindex $arguments 0]]} {
return [call [list error "not enaugh quota allotted to child!"] $state]
}
dict lappend state out_queue [list beget $child [lindex $arguments 0] $adresses $quota]
return [list $handle $state]
}
proc capicol::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 capicol::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 capicol::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 capicol::exec_prim_break {arguments 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] ""]} {
return [call [list error "break invoked outside an loop"] $state]
}
set state [lindex [exec_prim_return {} $state] end]
}
dict set state frame pointer [expr [dict get $state frame break-goto] - 1]
return [list {} $state]
}
proc capicol::exec_prim_catch {arguments state} {
log invoked [info level] [info level 0]
# catch <script> [<var>]
if {([llength $arguments] < 1) || ([llength $arguments] > 2)} {
return [call [list error "wrong # args: should be \"catch script ?var?\""] $state]
}
dict set state frame catcher [lindex $arguments 1]
return [exec_prim_upevel [list 0 [lindex $arguments 0]] $state]
}
proc capicol::exec_prim_capabilities {arguments state} {
log invoked [info level] [info level 0]
set result [dict keys $state capabilities]
set t1 [lsearch -exact $result counter]
set result [lreplace $result $t1 $t1]
return [list $result $state]
}
proc capicol::exec_prim_continue {arguments 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] ""]} {
return [call [list error "continue invoked outside an loop"] $state]
}
set state [lindex [exec_prim_return {} $state] end]
}
dict set state frame pointer [expr [dict get $state frame continue-goto] - 1]
return [list {} $state]
}
proc capicol::exec_prim_dict {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"dict subcommand ?arg ...?\""] $state]
}
# simple dispatcher
set subcommand [lindex $arguments 0]
if {[string equal "append" $subcommand]} {
return [exec_prim_dict_append [lrange $arguments 1 end] $state]
} elseif {[string equal "create" $subcommand]} {
return [exec_prim_dict_create [lrange $arguments 1 end] $state]
} elseif {[string equal "exists" $subcommand]} {
return [exec_prim_dict_exists [lrange $arguments 1 end] $state]
} elseif {[string equal "filter" $subcommand]} {
return [exec_prim_dict_filter [lrange $arguments 1 end] $state]
} elseif {[string equal "for" $subcommand]} {
return [exec_prim_dict_for [lrange $arguments 1 end] $state]
} elseif {[string equal "get" $subcommand]} {
return [exec_prim_dict_get [lrange $arguments 1 end] $state]
} elseif {[string equal "incr" $subcommand]} {
return [exec_prim_dict_incr [lrange $arguments 1 end] $state]
} elseif {[string equal "info" $subcommand]} {
return [exec_prim_dict_info [lrange $arguments 1 end] $state]
} elseif {[string equal "keys" $subcommand]} {
return [exec_prim_dict_keys [lrange $arguments 1 end] $state]
} elseif {[string equal "lappend" $subcommand]} {
return [exec_prim_dict_lappend [lrange $arguments 1 end] $state]
} elseif {[string equal "merge" $subcommand]} {
return [exec_prim_dict_merge [lrange $arguments 1 end] $state]
} elseif {[string equal "remove" $subcommand]} {
return [exec_prim_dict_remove [lrange $arguments 1 end] $state]
} elseif {[string equal "replace" $subcommand]} {
return [exec_prim_dict_replace [lrange $arguments 1 end] $state]
} elseif {[string equal "set" $subcommand]} {
return [exec_prim_dict_set [lrange $arguments 1 end] $state]
} elseif {[string equal "size" $subcommand]} {
return [exec_prim_dict_size [lrange $arguments 1 end] $state]
} elseif {[string equal "unset" $subcommand]} {
return [exec_prim_dict_unset [lrange $arguments 1 end] $state]
} elseif {[string equal "update" $subcommand]} {
return [exec_prim_dict_update [lrange $arguments 1 end] $state]
} elseif {[string equal "values" $subcommand]} {
return [exec_prim_dict_values [lrange $arguments 1 end] $state]
} elseif {[string equal "with" $subcommand]} {
return [exec_prim_dict_remove [lrange $arguments 1 end] $state]
} else {
return [call [list 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"] $state]
}
}
proc capicol::exec_prim_dict_append {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 3} {
return [call [list error "wrong # args: should be \"dict append varName key ?key ...? value\""] $state]
}
set varname [lindex $arguments 0]
set keys [lrange $arguments 1 end-1]
set value [lindex $arguments 0]
lassign [exec_prim_get [list $varname] $state] dict state
lassign [exec_prim_dict_get [list $dict {expand}$keys] $state] prevValue state
set value "[set prevValue][set value]"
lassign [exec_prim_dict_replace [list $dict {expand}$keys $value] $state] dict state
return [exec_prim_dict_set [list $varname $dict] $state]
}
proc capicol::exec_prim_dict_create {arguments state} {
log invoked [info level] [info level 0]
if {([llength $arguments] % 2) != 0} {
return [call [list error "wrong # args: should be \"dict create ?key value ...?\""] $state]
}
return [list $arguments $state]
}
proc capicol::exec_prim_dict_exists {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 2} {
return [call [list error "wrong # args: should be \"dict exists dictionary key ?key ...?\""] $state]
}
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 [list $found $state]
}
proc capicol::exec_prim_dict_filter {arguments state} {
log invoked [info level] [info level 0]
set message "not yet implemented: use this idiom instead:\n"
append message " set results {}\n"
append message " foreach {key value} \$dictionary \{\n"
append message " if $condition \{\n"
append message " lappend result $key\n"
append message " lappend result $value\n"
append message " \}\n"
append message " \}\n"
return [call [list error $message] $state]
}
proc capicol::exec_prim_dict_for {arguments state} {
log invoked [info level] [info level 0]
set message "not yet implemented: ude this idiom instead:\n"
append message " foreach {keyVar valueVar} dictionary script\n"
return [call [list error $message] $state]
}
proc capicol::exec_prim_dict_get {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"dict get dictionary ?key ...?\""] $state]
}
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} {
return [call [list error "key \"[lindex $keys 0]\" not known in dictionary"] $state]
}
set dict $value
set keys [lrange $keys 1 end]
}
return [list $value $state]
}
proc capicol::exec_prim_dict_incr {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 3} {
return [call [list error "wrong # args: should be \"dict append varName key ?key ...? increment\""] $state]
}
set varname [lindex $arguments 0]
set keys [lrange $arguments 1 end-1]
set value [lindex $arguments 0]
lassign [exec_prim_get [list $varname] $state] dict state
lassign [exec_prim_dict_get [list $dict {expand}$keys] $state] prevValue state
set value "[set prevValue][set value]"
lassign [exec_prim_dict_replace [list $dict {expand}$keys $value] $state] dict state
return [exec_prim_dict_set [list $varname $dict] $state]
}
proc capicol::exec_prim_dict_info {arguments state} {
log invoked [info level] [info level 0]
return [list "" $state]
}
proc capicol::exec_prim_dict_keys {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"dict keys dictionary ?pattern?\""] $state]
}
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 [list $result $state]
}
proc capicol::exec_prim_dict_lappend {arguments state} {
log invoked [info level] [info level 0]
# use replace
}
proc capicol::exec_prim_dict_merge {arguments state} {
log invoked [info level] [info level 0]
set out {}
foreach dict $arguments {
if {([llength $dict] % 2) != 0} {
return [call [list error "missing value to go with key"] $state]
}
foreach key [dict keys $dict] {
dict set out $key [dict get $dict $key]
}
}
return [list $out $state]
}
proc capicol::exec_prim_dict_remove {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"dict remove dictionary ?key ...?] $state]
}
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] {
lassign [exec_prim_dict_get [list $dict [lindex $keys 0]] $state] dict state
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} {
lassign [exec_prim_dict_replace [list $out {expand}[lrange $keys 0 end-1] $out] $state] $out state
}
return [list $out $state]
}
proc capicol::exec_prim_dict_replace {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 3} {
return [call [list error "wrong # args: should be \"dict replace dictionary key ?key ...? value\""] $state]
}
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 [list $dict $state]
}
proc capicol::exec_prim_dict_set {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 3} {
return [call [list error "wrong # args: should be \"dict set varName key ?key ...? value\""] $state]
}
set varname [lindex $arguments 0]
set keys [lrange $arguments 1 end-1]
set value [lindex $arguments end]
lassign [exec_prim_var_exists? $varname $state] bool state
if {$bool} {
lassign [exec_prim_get $varname $state] dict state
}
lset arguments 0 $dict
lassign [exec_prim_dict_replace $arguments $state] dict state
return [exec_prim_set [list $varname $dict] $state]
}
proc capicol::exec_prim_dict_size {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] != 1} {
return [call [list error "wrong # args: should be \"dict size dictionary\""] $state]
}
return [list [expr {[length $arguments] / 2}] $state]
}
proc capicol::exec_prim_dict_unset {arguments state} {
log invoked [info level] [info level 0]
# use dict remove
}
proc capicol::exec_prim_dict_update {arguments state} {
log invoked [info level] [info level 0]
return [call [list error "not yet implemented"] $state]
}
proc capicol::exec_prim_dict_values {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"dict values dictionary ?pattern?\""] $state]
}
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 [list $result $state]
}
proc capicol::exec_prim_dict_with {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_die {arguments state} {
log invoked [info level] [info level 0]
set result {}
dict set state running no
dict lappend state out_queue [list die $arguments]
return [list $result $state]
}
proc capicol::exec_prim_drop_capability {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] != 1} {
return [call [list error "wrong # args: should be \"drop_capability\"] $state]
}
set caphandle [lindex $arguments 0]
if {![dict exists $state capabilities $caphandle]} {
return [call [list error "no such caphandle $caphandle"] $state]
}
dict unset state capabilities $caphandle
return [list {} $state]
}
proc capicol::exec_prim_error {arguments state} {
log invoked [info level] [info level 0]
while true {
if {[dict exists $state frame catcher]} break
if {[string equal [dict get $state returnstack] ""]} {
return [call [list die error $arguments] $state]
}
set state [lindex [exec_prim_return {} $state] end]
}
set catcher [dict get $state frame catcher]
dict unset state frame catcher
set state [lindex [exec_prim_set [list $catcher $arguments] $state] end]
return [list true $state]
}
proc capicol::exec_prim_gain {arguments state} {
log invoked [info level] [info level 0]
return [call [list error "not yet implemented sorry!"] $state]
}
proc capicol::exec_prim_get {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] != 1} {
return [call [list error "wrong # args: should be \"get varName\"] $state]
}
if {![dict exists $state variables $arguments]} {
return [call [list error "can't read \"[set arguments]\": no such variable"] $state]
}
return [list [dict get $state variables $arguments] $state]
}
proc capicol::exec_prim_if {arguments 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])} {
return [call [list error "wrong # args: should be \"if test yes-body \[else no-body\]\""] $state]
}
if {([llength $arguments] == 4) && ![string equal "else" [lindex $arguments 2]]} {
return [call [list error "else keyword missing"] $state]
}
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]
return [call $code $state]
}
proc capicol::exec_prim_lappend {arguments state} {
log invoked [info level] [info level 0]
if {[llength $arguments] < 1} {
return [call [list error "wrong # args: should be \"lappend varname ?value ...?\""] $state]
}
lassign [exec_prim_get [lindex $arguments 0] $state] result state
foreach item [lrange $arguments 1 end] {
lappend result $item
}
return [list $result $state]
}
proc capicol::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 capicol::exec_prim_lindex {arguments state} {
log invoked [info level] [info level 0]
set tmp "lindex"
foreach item $arguments { lappend tmp $item }
if {[catch $tmp result]} {
return [call [list error $result] $state]
}
return [list $result $state]
}
proc capicol::exec_prim_linsert {arguments state} {
log invoked [info level] [info level 0]
set tmp "linsert"
foreach item $arguments { lappend tmp $item }
if {[catch $tmp result]} {
return [call [list error $result] $state]
}
return [list $result $state]
}
proc capicol::exec_prim_list {arguments state} {
log invoked [info level] [info level 0]
return [list $arguments $state]
}
proc capicol::exec_prim_llength {arguments state} {
log invoked [info level] [info level 0]
return [list [llength $arguments] $state]
}
proc capicol::exec_prim_lrange {arguments state} {
log invoked [info level] [info level 0]
set tmp "lrange"
foreach item $arguments { lappend tmp $item }
if {[catch $tmp result]} {
return [call [list error $result] $state]
}
return [list $result $state]
}
proc capicol::exec_prim_lrepeat {arguments state} {
log invoked [info level] [info level 0]
set tmp "lrepeat"
foreach item $arguments { lappend tmp $item }
if {[catch $tmp result]} {
return [call [list error $result] $state]
}
return [list $result $state]
}
proc capicol::exec_prim_lsearch {arguments state} {
log invoked [info level] [info level 0]
set tmp "lsearch"
foreach item $arguments { lappend tmp $item }
if {[catch $tmp result]} {
return [call [list error $result] $state]
}
return [list $result $state]
}
proc capicol::exec_prim_lset {arguments state} {
log invoked [info level] [info level 0]
# not yet implemented
return [list $result $state]
}
proc capicol::exec_prim_lsort {arguments state} {
log invoked [info level] [info level 0]
# not yet implemented
return [list $result $state]
}
proc capicol::exec_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 capicol::exec_prim_or {arguments state} {
log invoked [info level] [info level 0]
# not yet implemented
return [list $result $state]
}
proc capicol::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 capicol::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 capicol::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
return [list $name $state]
}
proc capicol::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 capicol::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 capicol::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]
if {[string equal "bytelength" $subcommand]} {
return [exec_prim_string_bytelength $rest $state]
} elseif {[string equal "compare" $subcommand]} {
return [exec_prim_string_compare $rest $state]
} elseif {[string equal "equal" $subcommand]} {
return [exec_prim_string_equal $rest $state]
} elseif {[string equal "first" $subcommand]} {
return [exec_prim_string_first $rest $state]
} elseif {[string equal "index" $subcommand]} {
return [exec_prim_string_index $rest $state]
} elseif {[string equal "is" $subcommand]} {
return [exec_prim_string_is $rest $state]
} elseif {[string equal "last" $subcommand]} {
return [exec_prim_string_last $rest $state]
} elseif {[string equal "length" $subcommand]} {
return [exec_prim_string_length $rest $state]
} elseif {[string equal "map" $subcommand]} {
return [exec_prim_string_map $rest $state]
} elseif {[string equal "match" $subcommand]} {
return [exec_prim_string_match $rest $state]
} elseif {[string equal "range" $subcommand]} {
return [exec_prim_string_range $rest $state]
} elseif {[string equal "repeat" $subcommand]} {
return [exec_prim_string_repeat $rest $state]
} elseif {[string equal "replace" $subcommand]} {
return [exec_prim_string_replace $rest $state]
} elseif {[string equal "tolower" $subcommand]} {
return [exec_prim_string_tolower $rest $state]
} elseif {[string equal "toupper" $subcommand]} {
return [exec_prim_string_toupper $rest $state]
} elseif {[string equal "totitle" $subcommand]} {
return [exec_prim_string_totitle $rest $state]
} elseif {[string equal "trim" $subcommand]} {
return [exec_prim_string_trim $rest $state]
} elseif {[string equal "trimleft" $subcommand]} {
return [exec_prim_string_trimleft $rest $state]
} elseif {[string equal "trimright" $subcommand]} {
return [exec_prim_string_trimright $rest $state]
} elseif {[string equal "wordend" $subcommand]} {
return [exec_prim_string_wordend $rest $state]
} elseif {[string equal "wordstart" $subcommand]} {
return [exec_prim_string_wordstart $rest $state]
} else {
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 capicol::exec_prim_string_bytelength {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_compare {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_equal {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_first {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_index {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_is {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_last {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_length {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_map {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_match {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_range {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_repeat {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_replace {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_tolower {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_toupper {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_totitle {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_trim {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_trimleft {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_trimright {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_wordend {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::exec_prim_string_wordstart {arguments state} {
log invoked [info level] [info level 0]
}
proc capicol::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 capicol::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 capicol::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 capicol::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 capicol::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 capicol::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 capicol::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 capicol::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 capicol::new_state {} {
log invoked [info level] [info level 0]
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 {}
dict set c quota 4096; # bit of an quota well here, no?
dict set c commands {
+ {type prim contents +}
- {type prim contents -} / {type prim contents /}
% {type prim contents %}
& {type prim contents &}
| {type prim contents |}
^ {type prim contents ^}
< {type prim contents <}
<< {type prim contents <<}
>> {type prim contents >>}
<= {type prim contents <=}
== {type prim contents ==}
!= {type prim contents !=}
and {type prim contents and}
any_messages? {type prim contents any_messages?}
args {type prim contents args}
beget {type prim contents beget}
break {type prim contents break}
catch {type prim contents catch}
capabilities {type prim contents capabilities}
continue {type prim contents continue}
dict {type prim contents dict}
die {type prim contents die}
drop_capability {type prim contents drop_capability}
error {type prim contents error}
gain {type prim contents gain}
get {type prim contents get}
if {type prim contents if}
lappend {type prim contents lappend}
lassign {type prim contents lassign}
lindex {type prim contents lindex}
linsert {type prim contents linsert}
list {type prim contents list}
llength {type prim contents llength}
lrange {type prim contents lrange}
lrepeat {type prim contents lrepeat}
lreplace {type prim contents lreplace}
lsearch {type prim contents lsearch}
lset {type prim contents lset}
lsort {type prim contents lsort}
next_message {type prim contents next_message}
or {type prim contents or}
rename {type prim contents rename}
return {type prim contents return}
routine {type prim contents routine}
send_message {type prim contents send_message}
set {type prim contents set}
string {type prim contents string}
uplevel {type prim contents uplevel}
var_exists? {type prim contents var_exists?}
while {type prim contents while}
__branch {type prim contents __branch}
__jump {type prim contents __jump}
}
return $c
}
proc capicol::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)
send_message_out $sender $message
}
return
}
proc capicol::send_message_out {sender message} {
log invoked [info level] [info level 0]
# for now just print the whole thing
puts stdout "capicol message: [list $message]"
flush stdout
}
proc capicol::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 capicol::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 capicol::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 [advance $state]
if {$counter == 0} { break }
incr counter -1
}
if {![dict get $state running]} {
deschedule $name
}
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]
if {[string equal $type "die"]} {
set reason [lindex $message 1]
# for now print to stderr
puts stderr "capicol $name died because of \"$reason\" (but its carcass is still around mind you)"
# later:
#set message [list capicol-death $name $reason $state]
#unschedule $name
#dict unset capicols $name
#send_message [list $creator $message [string length $message]]
break
} elseif {[string equal $type "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 [new_state]
dict set child my_address $child_name
dict incr child quota $quota
lassign [caphandles_from_adddresses $addresses $child] dummy child
dict set child code [translate $startup_code]
dict set capicols $child_name $child
schedule $child_name
return
} elseif {[string equal $type "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
} elseif {[string equal $type "message"]} {
send_message $name [lindex $message 1]
} else {
error "what the heck is [set type]? ([set message])"
}
}
}
# added at wiki:
proc capicol::start {} {
capicol::run_one_slice
after idle [info level 0]
}