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.
# 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? 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 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] }