http://www.skyhunter.com/marcs/capabilityIntro/index.html

 # 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.6
 package require Tcl 8.5
 package provide capicol 0.6.0

 # state:
 #   my_address
 #     <capicol address>
 #   number_of_children
 #     <number>
 #   running
 #     <boolean>
 #   quota
 #     <number>
 #   capabilities
 #     <address>*
 #   in-queue
 #     <in_message>*
 #   out_queue
 #     <out_message>*
 #      <type>
 #   commands
 #     <command name>*
 #       <type> <contents>
 #   returnstack
 #     frame*
 #   frame
 #     pointer
 #       <number>
 #     code
 #       <call template>*
 #     results
 #       <number>
 #         <result>
 #     type
 #       macro | micro
 # einungis fyrir macro frames:
 #     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
 # <type> := "prim" | "execlist" | "script"
 #
 # decided to upvar state from all that stuff that [advance $state] invokes
 # þarf að breyta áköll á exec_prim_set úr öðrum exec_prims yfir í call set <varname> <value>
 # þarf að breyta exec_prim_set þannig að það finni macro frame og breyti breytum þar

 namespace eval capicol {}
 proc capicol::log args {
   # override with another proc to get all kind of debugging data.
 } 
 namespace eval capicol::interp {}

 proc capicol::interp::state_check {} {
   upvar state state
   if {![dict exists $state commands]}        { error "commands missing" }
   if {![dict exists $state frame code]}      { error "code missing" }
   if {![dict exists $state my_address]} {
     error "an capicol state cannot be without an address!"
   }
   if {![dict exists $state capabilities]} {
     error "an capicol without capabilities: why?"
   }
   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 {} }
 }
 proc capicol::interp::prepare_command_to_be_invoked {} {
   upvar state state
   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]]
   return [set cmd&args]
 }
 proc capicol::interp::new_callframe_for_execlist {code args} {
   upvar state state
   dict set state frame code $code
   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
 }
 proc capicol::interp::advance {state} {
   capicol::log invoked [info level] [info level 0]
   state_check
   set args [lassign [prepare_command_to_be_invoked] cmd]
   if {[dict exists $state commands $cmd]} {
     if {[llength [dict get $state commands $cmd]] > 1} { error "malformed command record for $cmd" }
     set rest [lassign [dict get $state commands $cmd] type contents]
     switch -exact -- $type {
       "execlist" {
         push_continuation $state
         new_callframe_for_execlist $contents $args
       }
       "prim"     {
         set pointer [dict get $state frame pointer]
         dict set state frame results $pointer [exec_prim [dict get $state commands $cmd contents] $args]
       }
       "script"   {
         dict set state commands $cmd [list execlist [translate $contents] $contents]
         return [advance $state]
       }
       default {
         error "unknown command type $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 execlist
     set state [lindex [exec_prim_return {} $state] end]
   }
   dict set state frame pointer [expr [dict get $state frame pointer] + 1]; # autoincr
   return $state
 }
 proc capicol::interp::translate {script {offset 0}} {
   upvar state state; # here only for [call error] in this procedure
   capicol::log invoked [info level] [info level 0]
   # todo: refactor this mess of a procedure
   # translates scripts into execlists
   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} { call 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} { call 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} {
         call 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::interp::interpolate {map template} {
   # mig grunar að þessi procedure hafi einhver vandkvæði
   capicol::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::interp::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 capicol::interp::push_continuation {continuation} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   set temp [dict create]
   dict lappend state returnstack [dict get $state frame]
   space_quota_check
 }
 proc capicol::interp::call {args} {
   upvar state state
   capicol::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 capicol::interp::exec_prim {primid arguments} {
   upvar state state
   capicol::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] }
     "<"  -
     "<=" -
     "==" -
     "!=" { return [exec_prim_compare $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_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] }
     "not"             { return [exec_prim_logical_not $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 capicol::interp::exec_prim_math {op arguments} {
   capicol::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 capicol::interp::exec_prim_compare {op arguments} {
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] != 2} {
     upvar state state
     call error "wrong # args: should be \"$op number number\""
     return
   }
   return [expr [lindex $arguments 0] $op [lindex $arguments 1]]
 }
 proc capicol::interp::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 capicol::interp::exec_prim_any_messages? {arguments} {
   upvar state state
   capicol::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 capicol::interp::exec_prim_args {arguments} {
   upvar state state
   capicol::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 capicol::interp::exec_prim_beget {arguments} {
   upvar state state
   capicol::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
   }

   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
   }
   # make new address for the "child" using the replicator serial scheme
   set child "[dict get $state my_address].[dict incr state number_of_children]"
   ::capicol::runtime::beget $child $startup_script $addresses $quota
   # add the child to the states capabilities list
   dict lappend state capabilities $child
   return $child
 }
 proc capicol::interp::exec_prim_break {arguments} {
   # depends on the implementation of exec_prim_while
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # search up the invocation stack for break-goto
   set level [llength [dict get $state returnstack]]
   incr level -1
   while true {
     set frame [lindex [dict get $state returnstack] $level]
     if {[dict exists $frame break-goto]} {
       incr level -1
       dict set state returnstack [lrange [dict get $state returnstack] 0 $level]
       dict set state frame $frame
       dict set state frame pointer [expr [dict get $frame break-goto] - 1]
       return
     }
     if {$level == -1} {
       call error "break invoked outside an loop"
       return
     }
     incr level -1
   }
 }
 proc capicol::interp::exec_prim_catch {arguments} {
   # depends on the implementation of exec_prim_error
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # catch <script> [<var>]
   if {([llength $arguments] < 1) || ([llength $arguments] > 2)} {
     call error "wrong # args: should be \"catch script ?var?\""
     return
   }
   dict set state frame catcher [lindex $arguments 1]
   exec_prim_upevel [list 0 [lindex $arguments 0]]
 }
 proc capicol::interp::exec_prim_capabilities {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {![dict exists $state capabilities]} {
     error "an capicol without capabilities: why?"
   }
   return [dict get $state capabilities]
 }
 proc capicol::interp::exec_prim_continue {arguments} {
   # depends on the implementation of exec_prim_while
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # search up the invocation stack for continue-goto
   set level [llength [dict get $state returnstack]]
   incr level -1
   while true {
     set frame [lindex [dict get $state returnstack] $level]
     if {[dict exists $frame continue-goto]} {
       incr level -1
       dict set state returnstack [lrange [dict get $state returnstack] 0 $level]
       dict set state frame $frame
       dict set state frame pointer [expr [dict get $frame continue-goto] - 1]
       return
     }
     if {$level == -1} {
       call error "continue invoked outside an loop"
       return
     }
     incr level -1
   }
 }
 proc capicol::interp::exec_prim_dict {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"dict subcommand ?arg ...?\""
     return
   }
   # simple dispatcher
   set subcommand [lindex $arguments 0]
   set arguments [lrange $arguments 1 end]
   switch -exact -- $subcommand {
     "append"  { return [exec_prim_dict_append  $arguments] }
     "create"  { return [exec_prim_dict_create  $arguments] }
     "exists"  { return [exec_prim_dict_exists  $arguments] }
     "filter"  { return [exec_prim_dict_filter  $arguments] }
     "for"     { return [exec_prim_dict_for     $arguments] }
     "get"     { return [exec_prim_dict_get     $arguments] }
     "incr"    { return [exec_prim_dict_incr    $arguments] }
     "info"    { return [exec_prim_dict_info    $arguments] }
     "keys"    { return [exec_prim_dict_keys    $arguments] }
     "lappend" { return [exec_prim_dict_lappend $arguments] }
     "merge"   { return [exec_prim_dict_merge   $arguments] }
     "remove"  { return [exec_prim_dict_remove  $arguments] }
     "replace" { return [exec_prim_dict_replace $arguments] }
     "set"     { return [exec_prim_dict_set     $arguments] }
     "size"    { return [exec_prim_dict_size    $arguments] }
     "unset"   { return [exec_prim_dict_unset   $arguments] }
     "update"  { return [exec_prim_dict_update  $arguments] }
     "values"  { return [exec_prim_dict_values  $arguments] }
     "with"    { return [exec_prim_dict_remove  $arguments] }
   }
   call error "bad subcommand \"[lindex $arguments 0]\": must be append, create, exists, filter, for, get, incr, info, keys, lappend, merge, remove, replace, set, size, unset, update, values or with"
 }
 proc capicol::interp::exec_prim_dict_append {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 3} {
     call error "wrong # args: should be \"dict append varName key ?key ...? value\""
     return
   }
   set varname [lindex $arguments 0]
   set keys    [lrange $arguments 1 end-1]
   set value   [lindex $arguments 0]

   set dict [exec_prim_get [list $varname]]
   set prevValue [exec_prim_dict_get [list $dict {*}$keys]]
   set value "[set prevValue][set value]"
   set dict [exec_prim_dict_replace [list $dict {*}$keys $value]]
   exec_prim_dict_set [list $varname $dict]
   return $value
 }
 proc capicol::interp::exec_prim_dict_create {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {([llength $arguments]  % 2) != 0} {
     call error "wrong # args: should be \"dict create ?key value ...?\""
     return
   }
   return $arguments
 }
 proc capicol::interp::exec_prim_dict_exists {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 2} {
     call error "wrong # args: should be \"dict exists dictionary key ?key ...?\""
     return
   }
   set dict [lindex $arguments 0]
   set keys [lrange $arguments 1 end]
   set found no
   while {[llength $keys] > 0} {
     set found no
     foreach {k v} $dict {
       if {[string equal $k [lindex $keys 0]]} {
         set found yes
         set value $v
      }
     }
     if {!$found} { break }
     set dict $value
     set keys [lrange $keys 1 end]
   }
   return $found
 }
 proc capicol::interp::exec_prim_dict_filter {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   call error {not yet implemented: use this idiom instead:
 set results {}
 foreach {key value} $dictionary {
   if $condition {
     lappend result $key
     lappend result $value
   }
 }; # end of error message
 }
 proc capicol::interp::exec_prim_dict_for {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   call error {not yet implemented: ude this idiom instead:
  foreach {keyVar valueVar} dictionary script
 }; # end of error message
 }
 proc capicol::interp::exec_prim_dict_get {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"dict get dictionary ?key ...?\""
     return
   }
   set dict [lindex $arguments 0]
   set keys [lrange $arguments 1 end]
   while {[llength $keys] > 0} {
     set found no
     foreach {k v} $dict {
       if {[string equal $k [lindex $keys 0]]} {
         set found yes
         set value $v
       }
     }
     if {!$found} {
       call error "key \"[lindex $keys 0]\" not known in dictionary"
       return
     }
     set dict $value
     set keys [lrange $keys 1 end]
   }
   return $value
 }
 proc capicol::interp::exec_prim_dict_incr {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 3} {
     call error "wrong # args: should be \"dict append varName key ?key ...? increment\""
     return
   }
   set varname [lindex $arguments 0]
   set keys    [lrange $arguments 1 end-1]
   set value   [lindex $arguments 0]

   set dict [exec_prim_get [list $varname]]
   set prevValue [exec_prim_dict_get [list $dict {*}$keys]]
   set value "[set prevValue][set value]"
   set dict [exec_prim_dict_replace [list $dict {*}$keys $value]]
   exec_prim_dict_set [list $varname $dict]
   return $value
 }
 proc capicol::interp::exec_prim_dict_info {arguments} {
   capicol::log invoked [info level] [info level 0]
   return "no info"
 }
 proc capicol::interp::exec_prim_dict_keys {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"dict keys dictionary ?pattern?\""
     return
   }
   set result {}
   set pattern *
   if {[llength $arguments] == 2} { set pattern [lindex $arguments 1] }
   foreach {key value} [lindex $arguments 0] {
     if {[string match $pattern $key]} {
       lappend result $key
     }
   }
   return $result
 }
 proc capicol::interp::exec_prim_dict_lappend {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # use replace
   call error "not yet implemented!"
 }
 proc capicol::interp::exec_prim_dict_merge {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   set out {}
   foreach dict $arguments {
     if {([llength $dict] % 2) != 0} {
       call error "missing value to go with key"
       return
     }
     foreach key [dict keys $dict] {
       dict set out $key [dict get $dict $key]
     }
   }
   return $out
 }
 proc capicol::interp::exec_prim_dict_remove {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"dict remove dictionary ?key ...?\""
     return
   }
   set dict  [lindex $arguments 0]
   set keys  [lrange $arguments 1 end]
   set vstack [list $dict]
   if {[llength $keys] > 1} {
     foreach key [lrange $keys 0 end-1] {
       set dict [exec_prim_dict_get [list $dict [lindex $keys 0]]]
       lappend vstack $dict
     }
     set key [lindex $keys 0]
   } else {
     set key $keys
   }
   set out {}
   foreach {k v} $dict {
     if {![string equal $k $key]} {
       lappend out $k
       lappend out $v
     }
   }
   if {[llength $keys] > 1} {
     set out [exec_prim_dict_replace [list $out {*}[lrange $keys 0 end-1] $out]]
   }
   return $out
 }
 proc capicol::interp::exec_prim_dict_replace {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 3} {
     call error "wrong # args: should be \"dict replace dictionary key ?key ...? value\""
     return
   }
   set dict  [lindex $arguments 0]
   set keys  [lrange $arguments 1 end-1]
   set value [lindex $arguments end]

   set kstack [lrange $keys 0 end-1]
   set vstack {}
   set d $dict
   while {[llength $kstack] > 0} {
     set v2 {}
     foreach {k v} $d {
       if {[string equal $k [lindex $kstack 0]]} { set v2 $v }
     }
     lappend vstack $v2
     set d $v2
     set kstack [lrange $kstack 1 end]
   }
   lappend vstack $value
   while {[llength $vstack] > 0} {
     set temp [lindex $vstack end-1]
     lappend temp [lindex $keys end]
     lappend temp [lindex $vstack end]
     lset vstack end-1 $temp
     set keys   [lrange $keys 0 end-1]
     set vstack [lrange $vstack 0 end-1]
   }
   set dict $vstack
   return $dict
 }
 proc capicol::interp::exec_prim_dict_set {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 3} {
     call error "wrong # args: should be \"dict set varName key ?key ...? value\""
     return
   }
   set varname [lindex $arguments 0]
   set keys    [lrange $arguments 1 end-1]
   set value   [lindex $arguments end]
   set bool [exec_prim_var_exists? $varname]
   if {$bool} {
     set dict [exec_prim_get $varname]
   }
   lset arguments 0 $dict
   set dict [exec_prim_dict_replace $arguments]
   return [exec_prim_set [list $varname $dict]]
 }
 proc capicol::interp::exec_prim_dict_size {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] != 1} {
     call error "wrong # args: should be \"dict size dictionary\""
     return
   }
   return [expr {[length $arguments] / 2}]
 }
 proc capicol::interp::exec_prim_dict_unset {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # use dict remove
   call error "not yet implemented!"
 }
 proc capicol::interp::exec_prim_dict_update {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   call error "not yet implemented!"
 }
 proc capicol::interp::exec_prim_dict_values {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"dict values dictionary ?pattern?\""
     return
   }
   set result {}
   set pattern *
   if {[llength $arguments] == 3} { set pattern [lindex $arguments 2] }
   foreach {key value} [lindex $arguments 1] {
     if {[string match $pattern $value]} {
       lappend result $value
     }
   }
   return $result
 }
 proc capicol::interp::exec_prim_dict_with {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   call error "not yet implemented!"
 }
 # prim dict -end-
 proc capicol::interp::exec_prim_die {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   capicol::runtime::died $state $arguments
 }
 proc capicol::interp::exec_prim_drop_capability {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] != 1} {
     call error "wrong # args: should be \"drop_capability <address>\""
     return
   }
   if {![dict exists $state capabilities]} {
     error "an capicol without an capabilities: why?"
   }
   if {[set r [lsearch -exact [dict get $state capabilities] $arguments]] == -1} {
     call error "this capicol doesnt have address $arguments on its capabilities list"
     return
   }
   dict set state capabilities [lreplace [dict get $state capabilities] $r $r]
 }
 proc capicol::interp::exec_prim_error {arguments} {
   # depends on the implementation of exec_prim_catch
   upvar state state
   capicol::log invoked [info level] [info level 0]
   while true {
     if {[dict exists $state frame catcher]} break
     if {[string equal [dict get $state returnstack] ""]} {
       call die error $arguments
       return
     }
     exec_prim_return {}
   }
   set catcher [dict get $state frame catcher]
   dict unset state frame catcher
   exec_prim_set [list $catcher $arguments]
   return true
 }
 proc capicol::interp::exec_prim_gain {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   call error "not yet implemented!"
 }
 proc capicol::interp::exec_prim_get {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] != 1} {
     call error "wrong # args: should be \"get varName\"
     return
   }
   if {![dict exists $state frame variables $arguments]} {
     call error "can't read \"[set arguments]\": no such variable"
     return
   }
   return [dict get $state frame variables $arguments]
 }
 proc capicol::interp::exec_prim_if {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   # only primitive if supported:
   #  if <test> <yes-command> [else <no-command>]
   if {([llength $arguments] < 2) || (4 < [llength $arguments])} {
     call error "wrong # args: should be \"if test yes-body \[else no-body\]\""
     return
   }
   if {([llength $arguments] == 4) && ![string equal "else" [lindex $arguments 2]]} {
     call error "else keyword missing"
     return
   }
   set test  [lindex $arguments 0]
   set true  [lindex $arguments 1]
   set false {}
   if {[llength $arguments] == 4} { set false [lindex $arguments 3] }
   set code [list uplevel 1 $test]
   lappend code [list __branch "\[0\]" 4]
   lappend code [list uplevel 1 $false]
   lappend code [list __jump 5]
   lappend code [list uplevel 1 $true]
   lappend code [list]
   push_continuation $state
   dict set state frame code $code
   dict set state frame pointer -1
   return
 }
 proc capicol::interp::exec_prim_lappend {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"lappend varname ?value ...?\""
     return
   }
   set result [exec_prim_get [lindex $arguments 0]]
   foreach item [lrange $arguments 1 end] {
     lappend result $item
   }
   exec_prim_set [list [lindex $arguments 0] $result]
   return $result
 }
 proc capicol::interp::exec_prim_lassign {arguments} {
   upvar state state
   log invoked [info level] [info level 0]
   if {[llength $arguments] < 2} {
     call error "wrong # args: should be \"lassign list varname ?varname ...?\""
     return
   }
   set list [lindex $arguments 0]
   set vars [lrange $arguments 1 end]

   set counter 0
   foreach var $vars {
     exec_prim_set [list $var [lindex $list $counter]]
     incr counter
   }
   return [lrange $list $counter end]
 }
 proc capicol::interp::exec_prim_lindex {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 1} {
     call error "wrong # args: should be \"lindex list ?index ...?\""
     return
   }
   set list    [lindex $arguments 0]
   set indexes [lrange $arguments 1 end]
   foreach item $indexes {
     if {![string is digit $item] && \
         ![string equal -length 3 "end" $item] && \
         ![string equal -length 4 "end-" $item]} {
       call error "bad index \"[set item]\": must be integer or end?-integer?"
       return
     }
     set list [lindex $list $item]
   }
   return [list $list $state]
 }
 proc capicol::interp::exec_prim_linsert {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments] < 3} {
     call error "wrong # args: should be \"linsert list index element ?element ...?\""
     return
   }
   set list     [lindex $arguments 0]
   set index    [lindex $arguments 1]
   if {![string is digit $index] && \
       ![string equal -length 3 "end" $index] && \
       ![string equal -length 4 "end-" $index]} {
     call error "bad index \"[set index]\": must be integer or end?-integer?"
     return
   }
   if {[string equal -length "end-" $index]} {
     set index [expr {[llength $list] - [string range $index 4 end]}
   }
   set elements [lrange $arguments 2 end]
   foreach item $elements {
     set list [linsert $list $index $item]
     incr index +1
   }
   return $list
 }
 proc capicol::interp::exec_prim_list {arguments} {
   capicol::log invoked [info level] [info level 0]
   return $arguments
 }
 proc capicol::exec_prim_llength {arguments} {
   upvar state state
   capicol::log invoked [info level] [info level 0]
   if {[llength $arguments != 1} {
     call error "wrong # args: should be \"llength list\""
     return
   }
   return [llength [lindex $arguments 0]]
 }
 # var hér þann 26. október 2007 kl 01:48
  proc exec_prim_lrange {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments != 3} {
      call error "wrong # args: should be \"lrange list first last\""
      return
    }
    set list  [lindex $arguments 0]
    set first [lindex $arguments 1]
    if {![string is digit $first] && \
        ![string equal -length 3 "end" $first] && \
        ![string equal -length 4 "end-" $first]} {
      call error "bad index \"[set first]\": must be integer or end?-integer?"
      return
    }
    set last  [lindex $arguments 2]
    if {![string is digit $last] && \
        ![string equal -length 3 "end" $last] && \
        ![string equal -length 4 "end-" $last]} {
      call error "bad index \"[set last]\": must be integer or end?-integer?"
      return
    }
    return [list [lrange $list $first $last] $state]
  }
  proc exec_prim_lrepeat {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      call error "wrong # args: should be \"lrepeat positiveCount value ?value ...?\""
      return
    }
    set counter [lindex $arguments 0]
    if {![string is digit $counter]} {
      call error "expected integer but got \"[set counter]\""
      return
    }
    if {$counter < 1} {
      call error "must have a count of at least 1"
      return
    }
    set values [lrange $arguments 1 end]
    set result {}
    while {$counter > 0} {
      foreach value $values {
        lappend result $value
      }
      incr counter -1
    }
    return $result
  }
  proc exec_prim_lsearch {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      call error "wrong # args: should be \"lsearch ?options? list pattern\""
      return
    }
    set list [lindex $arguments end-1]
    set pattern [lindex $arguments end]
    set options [lrange $arguments 0 end-2]

    set option-all no
    set option-ascii no
    set option-decreasing no
    set option-dictionary no
    set option-exact no
    set option-glob no
    set option-increasing no
    set option-index ""
    set option-inline no
    set option-integer no
    set option-not no
    set option-real no
    set option-regexp no
    set option-sorted no
    set option-start ""
    set option-subindices no
    set index 0
    while {$index < [llength $options]} {
      set item [lindex $options $index]
      incr index
      if {[string equal $item "-all"]} {
        set option-all yes
      } elseif {[string equal $item "-ascii"]} {
        set option-ascii yes
      } elseif {[string equal $item "-decreasing"]} {
        set option-decreasing yes
      } elseif {[string equal $item "-dictionary"]} {
        set option-dictionary yes
      } elseif {[string equal $item "-exact"]} {
        set option-exact yes
        if {$option-glob || $option-regexp} {
          call error "make up your damn mind about the options to lsearch will ya!"
          return
        }
      } elseif {[string equal $item "-glob"]} {
        set option-glob yes
        if {$option-exact || $option-regexp} {
          call error "make up your damn mind about the options to lsearch will ya!"
          return
        }
      } elseif {[string equal $item "-increasing"]} {
        set option-increasing yes
      } elseif {[string equal $item "-index"]} {
        set option-index [lindex $options $index]
        incr index
        if {![string is digit $option-index] && \
            ![string equal -length 3 "end" $option-index] && \
            ![string equal -length 4 "end-" $option-index]} {
          call error "bad index \"[set option-index]\": must be integer or end?-integer?"
          return
        }
      } elseif {[string equal $item "-inline"]} {
        set option-inline yes
      } elseif {[string equal $item "-not"]} {
        set option-not yes
      } elseif {[string equal $item "-real"]} {
        set option-real yes
      } elseif {[string equal $item "-regexp"]} {
        set option-regexp yes
        if {$option-glob || $option-exact} {
          call error "make up your damn mind about the options to lsearch will ya!"
          return
        }
      } elseif {[string equal $item "-sorted"]} {
        set sorted yes
      } elseif {[string equal $item "-start"]} {
        set option-start [lindex $options $index]
        incr index
        if {![string is digit $option-start] && \
            ![string equal -length 3 "end" $option-start] && \
            ![string equal -length 4 "end-" $option-start]} {
          call error "bad index \"[set option-start]\": must be integer or end?-integer?"
          return
        }
      } elseif {[string equal $item "-subindices"]} {
        set subindices yes
        if {[string equal $option-index ""]} {
          call error "-subindices cannot be used without -index option"
          return
        }
      } else {
        call error "bad option \"[set item]\": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start or -subindices"
        return
      }
    }
    set tmp "lsearch"
    if {$option-all}        { lappend tmp -all }
    if {$option-ascii}      { lappend tmp -ascii }
    if {$option-decreasing} { lappend tmp -decreasing }
    if {$option-dictionary} { lappend tmp -dictionary }
    if {$option-exact}      { lappend tmp -exact }
    if {$option-glob}       { lappend tmp -glob }
    if {$option-increasing} { lappend tmp -increasing }
    if {![string equal $option-index ""]} { lappend tmp -index $option-index }
    if {$option-inline}     { lappend tmp -inline }
    if {$option-integer}    { lappend tmp -integer }
    if {$option-not}        { lappend tmp -not }
    if {$option-real}       { lappend tmp -real }
    if {$option-regexp}     { lappend tmp -regexp }
    if {$option-sorted}     { lappend tmp -sorted }
    if {![string equal $option-start ""]} { lappend tmp -start $option-start }
    if {$option-subindices} { lappend tmp -subindices }
    lappend tmp $list
    lappend tmp $pattern
    if {[catch $tmp result]} {
      call error $result
      return
    }
    return $result
  }
  proc exec_prim_lset {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 3} {
      call error "lset listVar index ?index...? value"
      return
    }
    set listvar [lindex $arguments 0]
    set indexes [lrange $arguments 1 end-1]
    set value   [lindex $arguments end]
    if {![exec_prim_var_exists? $listvar]} {
      call error "can't read \"$listvar\": no such variable"
      return
    }
    set listval [exec_prim_get $listvar]
    set stack ""
    set counter -1
    foreach index $indexes {
      if {![string is digit $index] && \
          ![string equal -length 3 "end" $index] && \
          ![string equal -length 4 "end-" $index]} {
        call error "bad index \"[set index]\": must be integer or end?-integer?"
      }
      lappend stack $listval
      set listval [lindex $listval $index]
      incr counter
    }
    lappend stack $value
    while {$counter > -1} {
      set listval [lreplace [lindex $stack $counter] [lindex $indexes $counter] [lindex $indexes $counter]]
    }
    exec_prim_set [list $listvar $listval]
    return $listval
  }
  proc exec_prim_lsort {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 1} {
      call error "wrong # args: should be \"lsort ?options? list\""
    }
    set list    [lindex $arguments end]
    set options [lrange $arguments 0 end-1]
    set option-ascii no
    set option-creasing in
    set option-dictionary no
    set option-index ""
    set option-indices no
    set option-integer no
    set option-real no
    set option-unique no
    set index 0
    while {$index < [llenght $options]} {
      set item [lindex $options $index]
      incr index
      if {[string equal $item "-ascii"]} {
        set option-ascii yes
      } elseif {[string equal $item "-command"]} {
        set option-command [lindex $options $index]
        incr index
        call error "sorry not yet implemented! too tricky as it is!"
        return
      } elseif {[string equal $item "-decreasing"]} {
        set option-creasing de
      } elseif {[string equal $item "-dictionary"]} {
        set option-dictionary yes
      } elseif {[string equal $item "-index"]} {
        set option-index [lindex $options $index]
        incr index
        if {![string is digit $option-index] && \
            ![string equal -length 3 "end" $option-index] && \
            ![string equal -length 4 "end-" $option-index]} {
          call error "bad index \"[set option-index]\": must be integer or end?-integer?"
          return
        }
      } elseif {[string equal $item "-indices"]} {
        set option-indices yes
      } elseif {[string equal $item "-integer"]} {
        set option-integer yes
      } elseif {[string equal $item "-real"]} {
        set option-real yes
      } elseif {[string equal $item "-unique"]} {
        set option-unique yes
      } else {
        call error "bad option \"[set item]\": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -real, or -unique"
        return
      }
    }
    set tmp "lsort"
    if {$option-ascii} { lappend tmp -ascii }
    if {[string equal "de" $option-creasing]} { lappend tmp -decreasing }
    if {$option-dictionary} { lappend tmp -dictionary }
    if {![string equal "" $option-index]} { lappend tmp -index $option-index }
    if {$option-indices} { lappend tmp -indices }
    if {$option-integer} { lappend tmp -integer }
    if {$option-real}    { lappend tmp -real }
    if {$option-unique}  { lappend tmp -unique }
    lappend tmp $list
    if {[catch $tmp result]} {
      call [list error $result]
      return
    }
    return $resul
  }
  proc exe_prim_next_message {arguments} {
    upvar state 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
      # because the in-queue is empty
      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
    set tmp [dict get $state capabilities]
    foreach address $addresses {
      lappend tmp $address
    }
    dict set state capabilities $tmp
    dict incr state quota $quota
    return $message
  }
  proc exec_prim_logical_or {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_rename {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      call error "wrong # args: should be \"rename oldName newName\""
      return
    }
    set old [lindex $arguments 0]
    set new [lindex $arguments 1]
    if {![dict exists $state commands $old]} {
      call error "no such command: $old"
      return
    }
    if {[dict exists $state commands $new]} {
      call error "$new exists already"
      return
    }
    if {![string equal $new ""]} {
      dict set state commands $new [dict get $state commands $old]
    }
    dict unset state commands $old
    return
  }
  proc exec_prim_return {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    # return from a frame 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]]} {
      exec_prim_die "end of program"
    }
    # 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 $result
  }; # var hér
  proc exec_prim_routine {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      call error "wrong # args: should be \"routine name body\"
      return
    }
    set name [lindex $arguments 0]
    set body [lindex $arguments 1]
    if {[dict exists $state commands $name]} {
      call error "command already exists!"
      return
    }
    dict set state commands $name type script
    dict set state commands $name contents $body
    space_quota_check
    return $name
  }
  proc exec_prim_command_exists? {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      call error "wrong # args: should be \"command_exists? name\"
      return
    }
    set name [lindex $arguments 0]
    return [dict exists $state commands $name]
  }
  proc exec_prim_send_message {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      call error "wrong # args: should be \"send_message addresses data ?quota?\"
    }
    set addresses [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]} {
      call error "not enaugh quota alotted for data to be sent"
      return
    }
    if {[dict get $state quota] < $quota} {
      call error "not enaugh quota to send message"
      return
    }
    foreach address $addresses {
      if {[lsearch -exact [dict get $state capabilities] $address] == -1} {
        call "this capicol has not address $address in its capabilities list"
        return
      }
    }
    ::capicol::runtime::send_message [dict get $state my_address [list $addresses $data $quota]]
  }; # var hér
  proc exec_prim_set {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      return [call [list error "wrong # args: should be \"set varName value\""] $state]
    }
    set varname [lindex $arguments 0]
    set value   [lindex $arguments 1]
    dict set state variables $varname $value
    return [list $value $state]
  }
  proc exec_prim_string {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 1} {
      return [call [list error "wrong # args: should be \"string option arg ?arg ...?\""] $state]
    }
    set subcommand [lindex $arguments 0]
    set rest       [lrange $arguments 1 end]
    switch -exact -- $subcommand {
      "bytelength" { return [exec_prim_string_bytelength $rest $state] }
      "compare"    { return [exec_prim_string_compare $rest $state] }
      "equal"      { return [exec_prim_string_equal $rest $state] }
      "first"      { return [exec_prim_string_first $rest $state] }
      "index"      { return [exec_prim_string_index $rest $state] }
      "is"         { return [exec_prim_string_is $rest $state] }
      "last"       { return [exec_prim_string_last $rest $state] }
      "length"     { return [exec_prim_string_length $rest $state] }
      "map"        { return [exec_prim_string_map $rest $state] }
      "match"      { return [exec_prim_string_match $rest $state] }
      "range"      { return [exec_prim_string_range $rest $state] }
      "repeat"     { return [exec_prim_string_repeat $rest $state] }
      "replace"    { return [exec_prim_string_replace $rest $state] }
      "tolower"    { return [exec_prim_string_tolower $rest $state] }
      "toupper"    { return [exec_prim_string_toupper $rest $state] }
      "totitle"    { return [exec_prim_string_totitle $rest $state] }
      "trim"       { return [exec_prim_string_trim $rest $state] }
      "trimleft"   { return [exec_prim_string_trimleft $rest $state] }
      "trimright"  { return [exec_prim_string_trimright $rest $state] }
      "wordend"    { return [exec_prim_string_wordend $rest $state] }
      "wordstart"  { return [exec_prim_string_wordstart $rest $state] }
      default { return [call [list error "bad option \"[set subcommand]\": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart"] $state] }
    }
  }
  proc exec_prim_string_bytelength {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      return [call [list error "wrong # args: should be \"string bytelength string\""] $state]
    }
    return [list [string bytelength [lindex $arguments 0]] $state]
  }
  proc exec_prim_string_compare {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      return [call [list error "wrong # args: should be \"string compare ?-nocase? ?-length int? string1 string2\""] $state]
    }
    set string1 [lindex $arguments end-1]
    set string2 [lindex $arguments end]
    set options [lrange $arguments 0 end-2]
    set option-nocase no
    set option-length ""
    set index 0
    while {$index < [llength $options]} {
      set item [lindex $options $index]
      incr index
      if {[string equal $item "-nocase"]} {
        set option-nocase yes
      } elseif {[string equal $item "-length"]} {
        set option-length [lindex $options $index]
        incr index
      } else {
        return [call [list error "bad option \"[set item]\": must be -nocase or -length"] $state]
      }
    }
    set tmp "string"
    lappend tmp "compare"
    if {$option-nocase} { lappend tmp -nocase }
    if {![string equal $option-length ""]} {
      lappend tmp -length
      lappend tmp $option-length
    }
    lappend tmp $string1
    lappend tmp $string2
    catch $tmp result
    return [list $result $state]
  }
  proc exec_prim_string_equal {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      return [call [list error "wrong # args: should be \"string equal ?-nocase? ?-length int? string1 string2\""] $state]
    }
    set string1 [lindex $arguments end-1]
    set string2 [lindex $arguments end]
    set options [lrange $arguments 0 end-2]
    set option-nocase no
    set option-length ""
    set index 0
    while {$index < [llength $options]} {
      set item [lindex $options $index]
      incr index
      if {[string equal $item "-nocase"]} {
        set option-nocase yes
      } elseif {[string equal $item "-length"]} {
        set option-length [lindex $options $index]
        incr index
      } else {
        return [call [list error "bad option \"[set item]\": must be -nocase or -length"] $state]
      }
    }
    set tmp "string"
    lappend tmp "equal"
    if {$option-nocase} { lappend tmp -nocase }
    if {![string equal $option-length ""]} {
      lappend tmp -length
      lappend tmp $option-length
    }
    lappend tmp $string1
    lappend tmp $string2
    catch $tmp result
    return [list $result $state]
  }
  proc exec_prim_string_first {arguments state} {
    log invoked [info level] [info level 0]
    if {([llength $arguments] < 2) || ([llength $arguments] > 3)} {
      return [call [list error "wrong # args: should be \"string first subString string ?startIndex?\""] $state]
    }
    set substring  [lindex $arguments 0]
    set string     [lindex $arguments 1]
    set startIndex [lindex $argumnets 2]
    if {[string equal $startIndex ""]} {
      set startIndex 0
    }
    if {![string is digit $startIndex] && \
        ![string equal -length 3 $startIndex "end"] && \
        ![string equal -length 4 $startIndex "end-"]} {
      return [call [list error "bad index \"[set startIndex]\": must be integer or end?-integer?"] $state]
    }
    return [list [string first $substring $string $startIndex] $state]
  }
  proc exec_prim_string_index {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      return [call [list error "wrong # args: should be \"string index string charIndex\""] $state]
    }
    set string [lindex $arguments 0]
    set index  [lindex $arguments 1]
    if {![string is digit $index] && \
        ![string equal -length 3 $index "end"] && \
        ![string equal -length 4 $index "end-"]} {
      return [call [list error "bad index \"[set index]\": must be integer or end?-integer?"] $state]
    }
    return [list [string index $string $index] $state]
  }
  proc exec_prim_string_is {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 2} {
      return [call [list error "wrong # args: should be \"string is class ?-strict? string\""] $state]
    }
    set class  [lindex $arguments 0]
    set string [lindex $arguments end]
    set option-strict [expr {([string equal "-strict" [lindex $arguments 1]] && ([llength $arguments] == 3)}]
    if {[lsearch -exact {alnum alpha ascii control boolean digit double false graph integer lower print punct space true upper wordchar xdigit} $class] == -1} {
      return [call [list error "bad class \"[set class]\": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, space, true, upper, wordchar or xdigit"] $state]
    }
    set tmp "string"
    lappend tmp "is"
    lappend tmp $class
    if {$option-strict} { lappend tmp -strict }
    lappend tmp $string
    catch $tmp result
    return [list $result $state]
  }
  proc exec_prim_string_last {arguments state} {
    log invoked [info level] [info level 0]
    if {([llength $arguments] < 2) || ([llength $arguments] > 3)} {
      return [call [list error "wrong # args: should be \"string last subString string ?startIndex?\""] $state]
    }
    set substring  [lindex $arguments 0]
    set string     [lindex $arguments 1]
    set startIndex [lindex $argumnets 2]
    if {[string equal $startIndex ""]} {
      set startIndex 0
    }
    if {![string is digit $startIndex] && \
        ![string equal -length 3 $startIndex "end"] && \
        ![string equal -length 4 $startIndex "end-"]} {
      return [call [list error "bad index \"[set startIndex]\": must be integer or end?-integer?"] $state]
    }
    return [list [string last $substring $string $startIndex] $state]
  }
  proc exec_prim_string_length {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      return [call [list error "wrong # args: should be \"string length string\""] $state]
    }
    return [list [string length [lindex $arguments 0]] $state]
  }
  proc exec_prim_string_map {arguments state} {
    log invoked [info level] [info level 0]
  }
  proc exec_prim_string_match {arguments state} {}
  proc exec_prim_string_range {arguments state} {}
  proc exec_prim_string_repeat {arguments state} {}
  proc exec_prim_string_tolower {arguments state} {}
  proc exec_prim_string_toupper {arguments state} {}
  proc exec_prim_string_totitle {arguments state} {}
  proc exec_prim_string_trim {arguments state} {}
  proc exec_prim_string_trimleft {arguments state} {}
  proc exec_prim_string_trimright {arguments state} {}
  proc exec_prim_string_wordend {arguments state} {}
  proc exec_prim_string_wordstart {arguments state} {}

  proc exec_prim_unset {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      return [call [list error "wrong # args: should be \"unset varname\""] $state]
    }
    dict unset state frame variables $arguments
    return [list "" $state]
  }
  proc exec_prim_uplevel {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      return [call [list error "wrong # args: should be \"uplevel level script\""] $state]
    }
    set level  [lindex $arguments 0]
    set script [lindex $arguments 1]
    if {[string equal [string index $level 0] "#"]} {
      set relative {}
      set level [string range $level 1 end]
    } else {
      set relative "end-"
    }
    if {![string is digit $level]} {
      return [call [list error "level must be an number optionaly preceded with #"] $state]
    }
    set state [push_continuation $state]
    set frame [lindex [dict get $state returnstack] [set relative][set level]]
    dict set state frame variables [dict get $frame variables]
    dict set state frame args      [dict get $frame args]
    dict set state frame saveto dest [set relative][set level]
    dict set state frame pointer -1
    dict set state frame code [translate [lindex $arguments 1]]
    return [list {} $state]
  }
  proc exec_prim_var_exists? {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      return [call [list error "wrong # args: should be \"var_exists? varName\""] $state]
    }
    return [list [dict exists $state variables $arguments] $state]
  }
  proc exec_prim_while {arguments state} {
    log invoked [info level] [info level 0]
    # not done
    if {[llength $arguments] != 2} {
      return [call [list error "wrong # args: should be \"while test script\""] $state]
    }
    set code [list error "<empty jump slot>"]
    # script body:
    lappend code [list uplevel 1 [lindex $arguments 1]]
    lset code 0 [list __jump [llength $code]]
    # here I use the picol way: test is an script
    lappend code [list uplevel 1 [lindex $arguments 0]]
    lappend code [list __branch "\[[llength $code]\]" 1]
    return [call $code $state]
  }
  proc exec_prim___branch {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      return [call [list error "wrong # args: should be \"__branch condition destination\""] $state]
    }
    if {![string is bool [lindex $arguments 0]]} {
      return [call [list error "condition must be an boolean value"] $state]
    }
    if {![string is digit [lindex $arguments 1]]} {
      return [call [list error "destination must be numerical"] $state]
    }
    if {[string is true [lindex $arguements 0]]} {
      dict set state frame pointer [expr $arguments - 1]
    }
    return [list {} $state]
  }
  proc exec_prim___jump {arguments state} {
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 1} {
      return [call [list error "wrong # args: should be \"__jump destination\""] $state]
    }
    if {![string is digit $arguments]} {
      return [call [list error "destination must be numerical"] $state]
    }
    dict set state frame pointer [expr $arguments - 1]
    return [list {} $state]
  }

  proc new_state {address} {
    log invoked [info level] [info level 0]
    dict set c my_address $address
    dict set c frame args {}
    dict set c frame pointer 0
    dict set c frame results {}
    dict set c frame variables {}
    dict set c frame code [list [list error "capicol::new_state doesnt supply the code! you do!"]]
    dict set c returnstack {}
    set alist [list]
    foreach content {+ - * / % & | ^ < << >> <= == != and any_messages? args beget break catch capabilities continue dict die drop_capability error gain get
      if lappend lassign lindex linsert list llength lrange lrepeat lreplace lsearch lset lsort next_message or rename return routine send_message
      set string uplevel var_exists? while __branch __jump
    } {
      lappend alist $content [list type prim contents $content]
    }
    dict set c commands $alist
    dict set c quota [expr [string length [dict get $state commands]] + \
                           [string length [dict get $state returnstack]] + \
                           [string length [dict get $state frame]]]
    return $c
  }

 }

 namespace eval capicol::runtime {
  variable capicols {}
  variable runlist  {}
  proc run_one_slice {} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    # round robin scheduling of run slices.
    set name [lindex $runlist 0]
    set runlist [join [list [lrange $runlist 1 end] [list $name]]]

    set state [dict get $capicols $name]
    if {![dict exists $state run_slice_size]} {
      dict set state run_slice_size 8
    }
    set counter [dict get $state run_slize_size]
    while {[dict get $state running]} {
      set state [::capicol::interp::advance $state]
      if {$counter == 0} { break }
      incr counter -1
      if {![dict get $state running]} {
        deschedule $name
        break
      }
    }
    dict set capicols $name $state
  }
  proc died {state reason} {
    variable capicols
    set name [dict get $state my_address]
    set message  [list capicol-death $name $reason $state]
    deschedule $name
    dict unset capicols $name
    set creator [join [lrange [split $name "."] 0 end-1]"."]
    send_message [list $creator $message [string length $message]]
  }
  proc beget {child_name startup_code addresses quota} {
    set child [::capicol::interp::new_state $child_name]
    dict incr child quota $quota
    lassign [caphandles_from_adddresses $addresses $child] dummy child
    dict set child code [translate $startup_code]
    variable capicols
    dict set capicols $child_name $child
    schedule $child_name
  }

  proc schedule {name} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    dict set capicols $name running yes
    if {![dict exists $capicols $name run_slice_size]} {
      dict set capicols $name run_slice_size 8
    }
    if {[lsearch -exact $runlist $name] == -1} {
      lappend runlist $name
    }
    return
  }
  proc deschedule {name} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    dict set capicols $name running no
    set t [lsearch -exact $runlist $name]
    set runlist [lreplace $runlist $t $t]
    return
  }
  proc send_message {sender message} {
    log invoked [info level] [info level 0]
    variable capicols

    lassign $message addresses
    lassign $addresses destination

    if {[dict exists $capicols $destination]} {
      # internal (between capicols on same machine/runtime)
      schedule $destination
      set t [dict get $capicols $destination in_queue]
      lappend t $message
      dict set $capicols $destination in_queue $t
    } else {
      # external (to external objects and between capicols on diffrent machines/runtimes)
      variable external_handlers
      foreach {pattern command} $external_handlers {
        if {[string match $patter $destination]} {
          append command " "
          append command [list $destination]
          append command " "
          append command [list $sender]
          append command " "
          append command [list $message]
          catch $command
        }
      }
    }
    return
  }
  proc register_external_handler {pattern command} {
    variable external_handlers
    set external_handlers "[list $command] [set external handlers]"
    set external_handlers "[list $pattern] [set external handlers]"
    return
  }
  proc unregister_external_handler {pattern command} {
    variable external_handlers
    set index 0
    foreach {p c} $external_handlers {
      if {[string equal $p $pattern] && [string equal $c $command]} {
        set external_handlers [lreplace $external_handlers $index [expr $index +1]]
        return
      }
      incr index 2
    }
  }

  proc store_snapshot {filename} {
    set fd [open $filename w]
    fconfigure $fd -encoding utf-8
    variable capicols
    variable runlist
    dict set tmp runlist $runlist
    dict set tmp capicols $capicols
    puts $fd $tmp
    close $fd
  }
  proc load_snapshot {filename} {
    set fd [open $filename r]
    fconfigure $fd -encoding utf-8
    set tmp [read $fd]
    close $fd
    variable capicols [dict get $tmp capicols]
    variable runlist  [dict get $tmp runlist]
  }
  proc looper {} {
    run_one_slice
    after idle [list ::capicol::runtime::looper]
  }
  proc start {} {
    after idle [list ::capicol::runtime::looper]
  }
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References