[Zarutian] 3. july 2007: Capicol is an variant of [picol], which in turn is an variant of [Tcl]. Capicol stands for Capability [picol] and is my investigation into capability-based security and asynchronous message passing in concurrent environment. It is not complete yet and probably very slow. (I want to get it right before fast, thank you) [Zarutian] 11. july 2007: So how does Capicol (or intend to) implement capabilities? Well, simply through a dictionary that the code running in the capicol interp doesn't have access to. That dictionary maps handles to addresses of other Capicolets (and simple i/o adaptors to the world outside the Capicolets), Capicolet being the snapshot state of an capicol interp, which might themselves be running or stored on other machines. Back to that dictionary. A Capicolet can only send an message to an address it has a handle for. So how does a Capicolet get an handle for a yet unknown address? Via the addresses field of a message that the capicol interp code replaces with handles (making new ones when coming across currently unknown addresses) upon receipt of a message and vice verse on sending. [Zarutian] 20.. july 2007: for an introduction to capability based security see http://www.skyhunter.com/marcs/capabilityIntro/index.html and on capability based security in general see erights.org New and improved version of the following code coming soon. [Zarutian] 23. july 2007: Needs a bit wikignoming that I dont have time to do right now. (Needs a space before each line of code) Turns out I have a bit time. [Zarutian] 19. september 2007: I am thinking about simplifing the capability list saved with each capicol state. # This code is hereby released in the public domain. # Any infriging software patents will be disregarded and # propably made invalid because of obviouseness. # v 0.5 package require Tcl 8.5 package provide capicol 0.5.1 proc log args {}; # override with another proc to get all kind of debugging data. namespace eval capicol {} namespace eval capicol::interp { # state: # my_address # # number_of_children # # running # # quota # # capabilities #
* # in-queue # * # out_queue # * # # commands # * # type # prim | combo | script # contents # returnstack # frame* # frame # pointer # # code # * # results # # # variables # # # arguments # # [break-goto] # # [continue-goto] # # [catcher] # # [save-to] # dest # # variables # # # := # := # := "beget" | "gain" | "message" # := ; for "beget" # := ; for "message" # := ; for "gain" # :=
* # := a string where [] must be replace with that result # # design decision: use primitives gain and beget or just send messages to local addresses? # hugmynd: sleppa [gain] og [beget] úr grunnskipanasafninu # # decided to upvar state from all that stuff that [advance $state] invokes proc advance {state} { log invoked [info level] [info level 0] if {![dict exists $state commands]} { error "commands missing" } if {![dict exists $state frame code]} { error "code missing" } if {![dict exists $state frame pointer]} { dict set state frame pointer 0 } if {![dict exists $state frame results]} { dict set state frame results {} } if {![dict exists $state frame variables]} { dict set state frame variables {} } if {![dict exists $state frame args]} { dict set state frame args {} } if {![dict exists $state returnstack]} { dict set state returnstack {} } set cmd&args [lindex [dict get $state frame code] [dict get $state frame pointer]] set cmd&args [interpolate [dict get $state frame results] [set cmd&args]] set cmd [lindex [set cmd&args] 0] set args [lrange [set cmd&args] 1 end] if {[dict exists $state commands $cmd]} { if {![dict exists $state commands $cmd type]} { error "type of command $cmd missing" } if {![dict exists $state commands $cmd contents]} { error "contents of command $cmd missing" } if {[string equal "combo" [dict get $state commands $cmd type]]} { # nokkuð mjög líklegt að verði mikið notað # push current continuation onto returnstack push_contination $state # stilla state fyrir að keyra innihald procs dict set state frame code [dict get $state commands $cmd contents] dict set state frame pointer -1; # þarf að vera -1 út af autoincr dict set state frame variables {} dict set state frame results {} dict set state frame args $args } elseif {[string equal "prim" [dict get $state commands $cmd type]]} { set pointer [dict get $state frame pointer] dict set state frame results $pointer [exec_prim [dict get $state commands $cmd contents] $args] } elseif {[string equal "script" [dict get $state commands $cmd type]]} { dict set state commands $cmd script [dict get $state commands $cmd contents] dict set state commands $cmd type combo dict set state commands $cmd contents [translate [dict get $state commands $cmd contents]] return [advance $state] } else { error "unknown command type [dict get $state commands $cmd type]" } } else { # the unknown command handling if {![dict exists $state commands unknown]} { call error "unknown command $cmd" return } else { # invoke the unknown command dict set state frame results \[[dict get $state pointer]\] [call unknown [set cmd&args]] } } if {[llength [dict get $state frame code]] < [dict get $state frame pointer]} { # execution fell off the end of an proc set state [lindex [exec_prim_return {} $state] end] } dict set state frame pointer [expr [dict get $state frame pointer] + 1]; # autoincr return $state } proc translate {script {offset 0}} { log invoked [info level] [info level 0] # todo: refactor this mess of a procedure # translates scripts into exec_lists set code [list] set counter $offset set level 0 dict set stack $level {} set index 0 set length [string length $script] set braced 0 set quoted no while {$index < $length} { set char [string index $code $index] incr index if {[string equal "#" $char] && [string is space [dict get $stack $level]]} { # handle comments # deviates from the 11 syntax rules in the way that comments are until end of line while true { set char [string index $code $index] incr index if {[string equal "\n" $char]} { break } } } elseif {[string equal "\$" $char] && !$braced} { # translate $varname into [get varname] set varname "" while true { set char [string index $script $index] incr index if {[string is space $char] || [string equal $char "\""]} { break } else { append varname $char } } lappend code "get $varname" dict append stack $level "\[[set counter]\]" incr counter } elseif {[string equal $char "\""] && !$braced} { # handle quotes if {$quoted} { set quoted no } else { set quoted yes } } elseif {[string equal $char "\\"]} { # handle escaped characters dict append stack $level "\\" dict append stack $level [string index $script $index] incr index } elseif {[string equal $char "\["] && !$braced} { # handle opening bracket incr level +1 dict set stack $level {} } elseif {[string equal $char "\]"] && !$braced} { # handle closeing bracket lappend code [dict get $stack $level] dict unset stack $level incr level -1 if {$level < 0} { error "too many \[ or too few \]" } dict append stack $level \[[set counter]\] incr counter } elseif {([string equal $char "\n"] || [string equal $char ";"]) && !$braced} { # handle newline and semicolon if {$level != 0} { error "unquoted \\n inside an command" } if {![string is space [dict get $stack 0]]} { lappend result [dict get $stack 0] incr counter dict set stack 0 {} } } elseif {[string equal "\{" $char]} { if {!$braced} { set braced 1 } else { incr braced +1 } dict append stack $level $char } elseif {[string equal "\}" $char]} { if {!$braced} { error "missing \{ somewhere or too many \}" } else { incr braced -1 } dict append stack $level $char } else { dict append stack $level $char } } return $code } proc interpolate {map template} { log invoked [info level] [info level 0] set out {} set i 0 while {$i < [string length $template]} { set char [string index $template $i] incr i if {[string equal $char "\["]} { set tag {} while true { set char [string index $template $i] incr i if {[string equal $char "\]"]} { break } elseif {[string equal $char "\["]} { error "only one bracket level allowed in interpolation" } else { append tag $char } if {$i >= [string length $template]} { error "where is the closing bracket?" } } if {![dict exists $map $tag]} { error "tag not found in map" } append out [dict get $map $tag] # finnst eins og ég sé að gleyma einhverju hér } elseif {[string equal $char "\{"]} { append out $char set level 1 while true { set char [string index $template $i] incr i if {[string equal $char "\{"]} { incr level +1 } elseif {[string equal $char "\}"]} { incr level -1 } append out $char if {$level == 0} { break } if {$i >= [string length $template]} { error "missing closing brace some where" } } } elseif {[string equal $char "\\"]} { append out "\\" append out [string index $template $i]; incr i } else { append out $char } } return $out } proc space_quota_check {} { upvar state state if {([string length [dict get $state commands]] + \ [string length [dict get $state returnstack]] + \ [string length [dict get $state frame]]) > [dict get $state quota]} { call error "not enaugh quota to run!" return } } proc push_continuation {continuation} { upvar state state log invoked [info level] [info level 0] set temp [dict create] dict lappend state returnstack [dict get $state frame] space_quota_check } proc call {args} { upvar state state log invoked [info level] [info level 0] push_continuation $state dict set state frame code [list [set args]] dict set state frame pointer -1 #return -code return } # primitives (or built in commands) proc exec_prim {primid arguments} { upvar state state log invoked [info level] [info level 0] # giant despatching switch # I rather use jump tables but cant have them easily in higher level languages # I wonder about the speed of this thing switch -exact -- $primid { "+" - "-" - "*" - "/" - "%" - "&" - "|" - "^" - "<<" - ">>" { return [exec_prim_math $primid $arguments] } "<" - "<=" - "==" - "!=" - "and" { return [exec_prim_logical_and $arguments] } "any_messages?" { return [exec_prim_any_messages? $arguments] } "args" { return [exec_prim_args $arguments] } "beget" { return [exec_prim_beget $arguments] } "break" { return [exec_prim_break $arguments] } "catch" { return [exec_prim_catch $arguments] } "capabilities" { return [exec_prim_capabilites $arguments] } "continue" { return [exec_prim_continue $arguments] } "command_exists?" { return [exec_prim_command_exists? $arguments] } "dict" { return [exec_prim_dict $arguments] } "die" { return [exec_prim_die $arguments] } "drop_capability" { return [exec_prim_drop_capability $arguments] } "error" { return [exec_prim_error $arguments] } "gain" { return [exec_prim_gain $arguments] } "get" { return [exec_prim_get $arguments] } "if" { return [exec_prim_if $arguments] } "lappend" { return [exec_prim_lappend $arguments] } "lassign" { return [exec_prim_lassign $arguments] } "lindex" { return [exec_prim_lindex $arguments] } "linsert" { return [exec_prim_linsert $arguments] } "list" { return [exec_prim_list $arguments] } "llength" { return [exec_prim_llength $arguments] } "lrange" { return [exec_prim_lrange $arguments] } "lrepeat" { return [exec_prim_lrepeat $arguments] } "lsearch" { return [exec_prim_lsearch $arguments] } "lset" { return [exec_prim_lset $arguments] } "lsort" { return [exec_prim_lsort $arguments] } "next_message" { return [exec_prim_next_message $arguments] } "or" { return [exec_prim_logical_or $arguments] } "rename" { return [exec_prim_rename $arguments] } "return" { return [exec_prim_return $arguments] } "routine" { return [exec_prim_routine $arguments] } "send_message" { return [exec_prim_send_message $arguments] } "set" { return [exec_prim_set $arguments] } "string" { return [exec_prim_string $arguments] } "unset" { return [exec_prim_unset $arguments] } "uplevel" { return [exec_prim_uplevel $arguments] } "var_exists?" { return [exec_prim_var_exists? $arguments] } "while" { return [exec_prim_while $arguments] } "__branch" { return [exec_prim___branch $arguments] } "__jump" { return [exec_prim___jump $arguments] } default { error "unknown capicol primitive $primid" } } } proc exec_prim_math {op arguments} { log invoked [info level] [info level 0] set result [lindex $arguments 0] foreach item [lrange $arguments 1 end] { set result [expr $result $op $item] } return $result } proc exec_prim_compare {op arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 2} { call error "wrong # args: should be \"$op number number\"" return } return [expr [lindex $arguments 0] $op [lindex $arguments 1]] } proc exec_prim_logical_and {arguments} { log invoked [info level] [info level 0] set result [lindex $arguments 0] foreach item [lrange $arguments 1 end] { set result [expr $result && $item] } return $result } proc exec_prim_any_messages? {arguments} { upvar state state log invoked [info level] [info level 0] if {![dict exists $state in_queue]} { dict set state in_queue {} } return [expr [llength [dict get $state in_queue]] != 0] } proc exec_prim_args {arguments} { upvar state state log invoked [info level] [info level 0] if {![dict exists $state frame args]} { dict set state frame args {} } return [dict get $state frame args] } proc exec_prim_beget {arguments} { upvar state state log invoked [info level] [info level 0] if {[llength $arguments] != 3} { call error "wrong # args: should be \"beget startup_script capabilities quota\"" return } set startup_script [lindex $arguments 0] set addresses [lindex $arguments 1] set quota [lindex $arguments 2] foreach address $addresses { if {[lsearch -exact [dict get $state capabilities] $address] == -1} { call error "this capicol has no such address in capabilities list: $address" return } } if {[dict get $state quota] < $quota} { call error "this capicol has not enaugh quota for giving to child" return } if {$quota < [string length $startup_script]} { call error "not enaugh quota allotted to child for the startup script!" return } # make new address for the "child" using the replicator serial scheme if {![dict exists $state my_address]} { error "an capicol state cannot be without an address!" } if {![dict exists $state number_of_children]} { dict set state number_of_children 0 } set child "[dict get $state my_address].[dict incr state number_of_children]" dict lappend state out_queue [list beget $child $startup_script $addresses $quota] return $child } proc exec_prim_break {arguments} { upvar state state log invoked [info level] [info level 0] while true { if {[dict exists $state frame break-goto]} break if {[string equal [dict get $state returnstack] ""]} { call error "break invoked outside an loop" return } exec_prim_return {} } dict set state frame pointer [expr [dict get $state frame break-goto] - 1] } proc exec_prim_catch {arguments} { upvar state state log invoked [info level] [info level 0] # catch