Version 24 of Capicol

Updated 2007-09-19 02:41:53 by Zarutian

Zarutian 3. july 2007: Capicol is an variant of picol, which in turn is an variant of Tcl. Capicol stands for Capability picol and is my investigation into capability-based security and asynchronous message passing in concurrent environment. It is not complete yet and probably very slow. (I want to get it right before fast, thank you)

Zarutian 11. july 2007: So how does Capicol (or intend to) implement capabilities? Well, simply through a dictionary that the code running in the capicol interp doesn't have access to.

That dictionary maps handles to addresses of other Capicolets (and simple i/o adaptors to the world outside the Capicolets), Capicolet being the snapshot state of an capicol interp, which might themselves be running or stored on other machines. Back to that dictionary. A Capicolet can only send an message to an address it has a handle for.

So how does a Capicolet get an handle for a yet unknown address?

Via the addresses field of a message that the capicol interp code replaces with handles (making new ones when coming across currently unknown addresses) upon receipt of a message and vice verse on sending.

Zarutian 20.. july 2007: for an introduction to capability based security see http://www.skyhunter.com/marcs/capabilityIntro/index.html and on capability based security in general see erights.org New and improved version of the following code coming soon.

Zarutian 23. july 2007: Needs a bit wikignoming that I dont have time to do right now. (Needs a space before each line of code) Turns out I have a bit time.

Zarutian 19. september 2007: I am thinking about simplifing the capability list saved with each capicol state.

 # This code is hereby released in the public domain.
 # Any infriging software patents will be disregarded and
 # propably made invalid because of obviouseness.
 # v 0.5
 package require Tcl 8.5
 package provide capicol 0.5.1

 proc log args {}; # override with another proc to get all kind of debugging data.

 namespace eval capicol {}
 namespace eval capicol::interp {
  # state:
  #   my_address
  #     <capicol address>
  #   number_of_children
  #     <number>
  #   running
  #     <boolean>
  #   quota
  #     <number>
  #   capabilities
  #     <address>*
  #   in-queue
  #     <in_message>*
  #   out_queue
  #     <out_message>*
  #      <type> 
  #   commands
  #     <command name>*
  #       type
  #         prim | combo | script
  #       contents
  #   returnstack
  #     frame*
  #   frame
  #     pointer
  #       <number>
  #     code
  #       <call template>*
  #     results
  #       <number>
  #         <result>
  #     variables
  #       <name>
  #         <value>
  #     arguments
  #       <string>
  #    [break-goto]
  #       <number>
  #    [continue-goto]
  #       <number>
  #    [catcher]
  #       <name of a variable>
  #    [save-to]
  #      dest
  #        <number>
  #      variables
  #        <name>
  #          <value>
  # <in_message> := <addresses> <data> <quota>
  # <out_message> := <out_message_type> <out_message_contents>
  # <out_message_type>     := "beget" | "gain" | "message"
  # <out_message_contents> := <startup script> <addresses> <quota>; for "beget"
  # <out_message_contents> := <in_message> ; for "message"
  # <out_message_contents> := <cert> ; for "gain"
  # <addresses> := <address>*
  # <call template> := a string where [<index into the result table>] must be replace with that result
  #
  # design decision: use primitives gain and beget or just send messages to local addresses?
  # hugmynd: sleppa [gain] og [beget] úr grunnskipanasafninu
  #
  # decided to upvar state from all that stuff that [advance $state] invokes

  proc advance {state} {
    log invoked [info level] [info level 0]
    if {![dict exists $state commands]}        { error "commands missing" }
    if {![dict exists $state frame code]}      { error "code missing" }
    if {![dict exists $state frame pointer]}   { dict set state frame pointer 0 }
    if {![dict exists $state frame results]}   { dict set state frame results {} }
    if {![dict exists $state frame variables]} { dict set state frame variables {} }
    if {![dict exists $state frame args]}      { dict set state frame args {} }
    if {![dict exists $state returnstack]}     { dict set state returnstack {} }

    set cmd&args [lindex [dict get $state frame code] [dict get $state frame pointer]]
    set cmd&args [interpolate [dict get $state frame results] [set cmd&args]]
    set cmd      [lindex [set cmd&args] 0]
    set args     [lrange [set cmd&args] 1 end]
    if {[dict exists $state commands $cmd]} {
      if {![dict exists $state commands $cmd type]} { error "type of command $cmd missing" }
      if {![dict exists $state commands $cmd contents]} { error "contents of command $cmd missing" }
      if {[string equal "combo" [dict get $state commands $cmd type]]} {
        # nokkuð mjög líklegt að verði mikið notað
        # push current continuation onto returnstack
        push_contination $state
        # stilla state fyrir að keyra innihald procs
        dict set state frame code [dict get $state commands $cmd contents]
        dict set state frame pointer -1; # þarf að vera -1 út af autoincr
        dict set state frame variables {}
        dict set state frame results {}
        dict set state frame args $args
      } elseif {[string equal "prim" [dict get $state commands $cmd type]]} {
        set pointer [dict get $state frame pointer]
        dict set state frame results $pointer [exec_prim [dict get $state commands $cmd contents] $args]
      } elseif {[string equal "script" [dict get $state commands $cmd type]]} {
        dict set state commands $cmd script [dict get $state commands $cmd contents]
        dict set state commands $cmd type combo
        dict set state commands $cmd contents [translate [dict get $state commands $cmd contents]]
        return [advance $state]
      } else {
        error "unknown command type [dict get $state commands $cmd type]"
      }
    } else {
      # the unknown command handling
      if {![dict exists $state commands unknown]} {
        call error "unknown command $cmd"
        return
      } else {
        # invoke the unknown command
        dict set state frame results \[[dict get $state pointer]\] [call unknown [set cmd&args]]
      }
    }
    if {[llength [dict get $state frame code]] < [dict get $state frame pointer]} {
      # execution fell off the end of an proc
      set state [lindex [exec_prim_return {} $state] end]
    }

    dict set state frame pointer [expr [dict get $state frame pointer] + 1]; # autoincr
    return $state
  }
  proc translate {script {offset 0}} {
    log invoked [info level] [info level 0]
    # todo: refactor this mess of a procedure
    # translates scripts into exec_lists
    set code [list]
    set counter $offset
    set level 0
    dict set stack $level {}
    set index 0
    set length [string length $script]
    set braced 0
    set quoted no
    while {$index < $length} {
      set char [string index $code $index]
      incr index
      if {[string equal "#" $char] && [string is space [dict get $stack $level]]} {
        # handle comments
        # deviates from the 11 syntax rules in the way that comments are until end of line
        while true {
          set char [string index $code $index]
          incr index
          if {[string equal "\n" $char]} { break }
        }
      } elseif {[string equal "\$" $char] && !$braced} {
        # translate $varname into [get varname]
        set varname ""
        while true {
          set char [string index $script $index]
          incr index
          if {[string is space $char] || [string equal $char "\""]} {
            break
          } else {
            append varname $char
          }
        }
        lappend code "get $varname"
        dict append stack $level "\[[set counter]\]"
        incr counter
      } elseif {[string equal $char "\""] && !$braced} {
        # handle quotes
        if {$quoted} {
          set quoted no
        } else {
          set quoted yes
        }
      } elseif {[string equal $char "\\"]} {
        # handle escaped characters
        dict append stack $level "\\"
        dict append stack $level [string index $script $index]
        incr index
      } elseif {[string equal $char "\["] && !$braced} {
        # handle opening bracket
        incr level +1
        dict set stack $level {}
      } elseif {[string equal $char "\]"] && !$braced} {
        # handle closeing bracket
        lappend code [dict get $stack $level]
        dict unset stack $level
        incr level -1
        if {$level < 0} { error "too many \[ or too few \]" }
        dict append stack $level \[[set counter]\]
        incr counter
      } elseif {([string equal $char "\n"] || [string equal $char ";"]) && !$braced} {
        # handle newline and semicolon
        if {$level != 0} { error "unquoted \\n inside an command" }
        if {![string is space [dict get $stack 0]]} {
          lappend result [dict get $stack 0]
          incr counter
          dict set stack 0 {}
        }
      } elseif {[string equal "\{" $char]} {
        if {!$braced} {
          set braced 1
        } else {
          incr braced +1
        }
        dict append stack $level $char
      } elseif {[string equal "\}" $char]} {
        if {!$braced} {
          error "missing \{ somewhere or too many \}"
        } else {
          incr braced -1
        }
        dict append stack $level $char
      } else {
        dict append stack $level $char
      }
    }
    return $code
  }
  proc interpolate {map template} {
    log invoked [info level] [info level 0]
    set out {}
    set i 0
    while {$i < [string length $template]} {
      set char [string index $template $i]
      incr i
      if {[string equal $char "\["]} {
        set tag {}
        while true {
          set char [string index $template $i]
          incr i
          if {[string equal $char "\]"]} {
            break
          } elseif {[string equal $char "\["]} {
            error "only one bracket level allowed in interpolation"
          } else {
            append tag $char
          }
          if {$i >= [string length $template]} {
            error "where is the closing bracket?"
          }
        }
        if {![dict exists $map $tag]} { error "tag not found in map" }
        append out [dict get $map $tag]
        # finnst eins og ég sé að gleyma einhverju hér
      } elseif {[string equal $char "\{"]} {
        append out $char
        set level 1
        while true {
          set char [string index $template $i]
          incr i
          if {[string equal $char "\{"]} {
            incr level +1
          } elseif {[string equal $char "\}"]} {
            incr level -1
          }
          append out $char
          if {$level == 0} { break }
          if {$i >= [string length $template]} {
            error "missing closing brace some where"
          }
        }
      } elseif {[string equal $char "\\"]} {
        append out "\\"
        append out [string index $template $i]; incr i
      } else {
        append out $char
      }
    }
    return $out
  }

  proc space_quota_check {} {
    upvar state state
    if {([string length [dict get $state commands]] + \
         [string length [dict get $state returnstack]] + \
         [string length [dict get $state frame]]) > [dict get $state quota]} {
      call error "not enaugh quota to run!"
      return
    }
  }

  proc push_continuation {continuation} {
    upvar state state
    log invoked [info level] [info level 0]
    set temp [dict create]
    dict lappend state returnstack [dict get $state frame]
    space_quota_check
  }
  proc call {args} {
    upvar state state
    log invoked [info level] [info level 0]
    push_continuation $state
    dict set state frame code [list [set args]]
    dict set state frame pointer -1
    #return -code return
  }

  # primitives (or built in commands)
  proc exec_prim {primid arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    # giant despatching switch
    # I rather use jump tables but cant have them easily in higher level languages
    # I wonder about the speed of this thing
    switch -exact -- $primid {
       "+" - 
       "-" -
       "*" -
       "/" -
       "%" -
       "&" -
       "|" -
       "^" -
      "<<" -
      ">>" { return [exec_prim_math $primid $arguments] }
      "<"  -
      "<=" -
      "==" -
      "!=" -
      "and" { return [exec_prim_logical_and $arguments] }
      "any_messages?" { return [exec_prim_any_messages? $arguments] }
      "args" { return [exec_prim_args $arguments] }
      "beget" { return [exec_prim_beget $arguments] }
      "break" { return [exec_prim_break $arguments] }
      "catch" { return [exec_prim_catch $arguments] }
      "capabilities" { return [exec_prim_capabilites $arguments] }
      "continue" { return [exec_prim_continue $arguments] }
      "command_exists?" { return [exec_prim_command_exists? $arguments] }
      "dict"            { return [exec_prim_dict $arguments] }    
      "die"             { return [exec_prim_die $arguments] }
      "drop_capability" { return [exec_prim_drop_capability $arguments] }
      "error"           { return [exec_prim_error $arguments] }
      "gain"            { return [exec_prim_gain $arguments] }
      "get"             { return [exec_prim_get $arguments] }
      "if"              { return [exec_prim_if $arguments] }
      "lappend"         { return [exec_prim_lappend $arguments] }
      "lassign"         { return [exec_prim_lassign $arguments] }
      "lindex"          { return [exec_prim_lindex $arguments] }
      "linsert"         { return [exec_prim_linsert $arguments] }
      "list"            { return [exec_prim_list $arguments] }
      "llength"         { return [exec_prim_llength $arguments] }
      "lrange"          { return [exec_prim_lrange $arguments] }
      "lrepeat"         { return [exec_prim_lrepeat $arguments] }
      "lsearch"         { return [exec_prim_lsearch $arguments] }
      "lset"            { return [exec_prim_lset $arguments] }
      "lsort"           { return [exec_prim_lsort $arguments] }
      "next_message"    { return [exec_prim_next_message $arguments] }
      "or"              { return [exec_prim_logical_or $arguments] }
      "rename"          { return [exec_prim_rename $arguments] }
      "return"          { return [exec_prim_return $arguments] }
      "routine"         { return [exec_prim_routine $arguments] }
      "send_message"    { return [exec_prim_send_message $arguments] }
      "set"             { return [exec_prim_set $arguments] }
      "string"          { return [exec_prim_string $arguments] }
      "unset"           { return [exec_prim_unset $arguments] }
      "uplevel"         { return [exec_prim_uplevel $arguments] }
      "var_exists?"     { return [exec_prim_var_exists? $arguments] }
      "while"           { return [exec_prim_while $arguments] }
      "__branch"        { return [exec_prim___branch $arguments] }
      "__jump"          { return [exec_prim___jump $arguments] }
      default  { error "unknown capicol primitive $primid" }
    }
  }
  proc exec_prim_math {op arguments} {
    log invoked [info level] [info level 0]
    set result [lindex $arguments 0]
    foreach item [lrange $arguments 1 end] {
      set result [expr $result $op $item]
    }
    return $result
  }
  proc exec_prim_compare {op arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 2} {
      call error "wrong # args: should be \"$op number number\""
      return
    }
    return [expr [lindex $arguments 0] $op [lindex $arguments 1]]
  }
  proc exec_prim_logical_and {arguments} {
    log invoked [info level] [info level 0]
    set result [lindex $arguments 0]
    foreach item [lrange $arguments 1 end] {
      set result [expr $result && $item]
    }
    return $result
  }
  proc exec_prim_any_messages? {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {![dict exists $state in_queue]} {
      dict set state in_queue {}
    } 
    return [expr [llength [dict get $state in_queue]] != 0]
  }
  proc exec_prim_args {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {![dict exists $state frame args]} {
      dict set state frame args {}
    }
    return [dict get $state frame args]
  }
  proc exec_prim_beget {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] != 3} {
      call error "wrong # args: should be \"beget startup_script capabilities quota\""
      return
    }

    set startup_script [lindex $arguments 0]
    set addresses      [lindex $arguments 1]
    set quota          [lindex $arguments 2]

    foreach address $addresses {
      if {[lsearch -exact [dict get $state capabilities] $address] == -1} {
        call error "this capicol has no such address in capabilities list: $address"
        return
      }
    }

    if {[dict get $state quota] < $quota} {
      call error "this capicol has not enaugh quota for giving to child"
      return
    }
    if {$quota < [string length $startup_script]} {
      call error "not enaugh quota allotted to child for the startup script!"
      return
    }

    # make new address for the "child" using the replicator serial scheme
    if {![dict exists $state my_address]} {
      error "an capicol state cannot be without an address!"
    }
    if {![dict exists $state number_of_children]} {
      dict set state number_of_children 0
    }

    set child "[dict get $state my_address].[dict incr state number_of_children]"
    dict lappend state out_queue [list beget $child $startup_script $addresses $quota]
    return $child
  }
  proc exec_prim_break {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    while true {
      if {[dict exists $state frame break-goto]} break
      if {[string equal [dict get $state returnstack] ""]} {
        call error "break invoked outside an loop"
        return
      }
      exec_prim_return {}
    }
    dict set state frame pointer [expr [dict get $state frame break-goto] - 1]
  }
  proc exec_prim_catch {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    # catch <script> [<var>]
    if {([llength $arguments] < 1) || ([llength $arguments] > 2)} {
      call error "wrong # args: should be \"catch script ?var?\""
      return
    }
    dict set state frame catcher [lindex $arguments 1]
    exec_prim_upevel [list 0 [lindex $arguments 0]]
  }
  proc exec_prim_capabilities {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {![dict exists $state capabilities]} {
      error "an capicol withuout capabilities dict key"
    }
    return [dict get $state capabilities]
  }
  proc capicol::exec_prim_continue {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    while true {
      if {[dict exists $state frame continue-goto]} break
      if {[string equal [dict get $state returnstack] ""]} {
        call error "continue invoked outside an loop"
        return
      }
      exec_prim_return {}
    }
    dict set state frame pointer [expr [dict get $state frame continue-goto] - 1]
  }
  proc capicol::exec_prim_dict {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 1} {
      call error "wrong # args: should be \"dict subcommand ?arg ...?\""
      return
    }
    # simple dispatcher
    set subcommand [lindex $arguments 0]
    set arguments [lrange $arguments 1 end]
    switch -exact -- $subcommand {
      "append"  { return [exec_prim_dict_append  $arguments] }
      "create"  { return [exec_prim_dict_create  $arguments] }
      "exists"  { return [exec_prim_dict_exists  $arguments] }
      "filter"  { return [exec_prim_dict_filter  $arguments] }
      "for"     { return [exec_prim_dict_for     $arguments] }
      "get"     { return [exec_prim_dict_get     $arguments] }
      "incr"    { return [exec_prim_dict_incr    $arguments] }
      "info"    { return [exec_prim_dict_info    $arguments] }
      "keys"    { return [exec_prim_dict_keys    $arguments] }
      "lappend" { return [exec_prim_dict_lappend $arguments] }
      "merge"   { return [exec_prim_dict_merge   $arguments] }
      "remove"  { return [exec_prim_dict_remove  $arguments] }
      "replace" { return [exec_prim_dict_replace $arguments] }
      "set"     { return [exec_prim_dict_set     $arguments] }
      "size"    { return [exec_prim_dict_size    $arguments] }
      "unset"   { return [exec_prim_dict_unset   $arguments] }
      "update"  { return [exec_prim_dict_update  $arguments] }
      "values"  { return [exec_prim_dict_values  $arguments] }
      "with"    { return [exec_prim_dict_remove  $arguments] }
    }
    call error "bad subcommand \"[lindex $arguments 0]\": must be append, create, exists, filter, for, get, incr, info, keys, lappend, merge, remove, replace, set, size, unset, update, values or with"
  }
  proc exec_prim_dict_append {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 3} {
      call error "wrong # args: should be \"dict append varName key ?key ...? value\""
      return
    }
    set varname [lindex $arguments 0]
    set keys    [lrange $arguments 1 end-1]
    set value   [lindex $arguments 0]

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

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

    set vstack [list $dict]
    if {[llength $keys] > 1} {
      foreach key [lrange $keys 0 end-1] {
        set dict [exec_prim_dict_get [list $dict [lindex $keys 0]]]
        lappend vstack $dict
      }
      set key [lindex $keys 0]
    } else {
      set key $keys
    }
    set out {}
    foreach {k v} $dict {
      if {![string equal $k $key]} {
        lappend out $k
        lappend out $v
      }
    }
    if {[llength $keys] > 1} {
      set out [exec_prim_dict_replace [list $out {*}[lrange $keys 0 end-1] $out]]
    }
    return $out
  }
  proc exec_prim_dict_replace {arguments} {
    upvar state state
    log invoked [info level] [info level 0]
    if {[llength $arguments] < 3} {
      call error "wrong # args: should be \"dict replace dictionary key ?key ...? value\""
      return
    }
    set dict  [lindex $arguments 0]
    set keys  [lrange $arguments 1 end-1]
    set value [lindex $arguments end]

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

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

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

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

  proc add_capability {address state} {
    log invoked [info level] [info level 0]
    if {![dict exists $state capabilities counter]} {
      dict set state capabilities counter [expr 2 * [dict size [dict get $state capabilities]]] 
    }
    if {[lsearch [dict keys $state capabilities] $address] == -1} {
      set handle cap[dict incr state capabilities counter]
      dict set state capabilities $handle $address
    } else {
      foreach {handle item} [dict get $state capabilities] {
        if {[string equal $item $address]} break
      }
    }
    return [list $handle $state]
  }
  proc addresses_from_caphandles {caphandles state} {
    log invoked [info level] [info level 0]
    set addresses {}
    set caphandles [dict get $state capabilities]
    foreach caphandle $caphandles {
      if {![dict exists $capabilities $caphandle]} {
        error "no such caphandle: $caphandle"
      }
      lappend addresses [dict get $capabilities $caphandle]
    }
    return [list $addresses $state]
  }
  proc caphandles_from_adddresses {addresses state} {
    log invoked [info level] [info level 0]
    set tmp [list]
    foreach item $addresses {
      lassign [add_capability $item $state] caphandle state
      lappend tmp $caphandle
    }
    return [list $tmp $state]
  }

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

 }

 namespace eval capicol::runtime {
  variable capicols {}
  variable runlist  {}
  proc run_one_slice {} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    set name [lindex $runlist 0]
    set runlist [join [list [lrange $runlist 1 end] [list $name]]]
    set state [dict get $capicols $name]
    if {![dict exists $state run_slice_size]} {
      dict set state run_slice_size 8
    }
    set counter [dict get $state run_slize_size]
    while {[dict get $state running]} {
      set state [::capicol::interp::advance $state]
      if {$counter == 0} { break }
      incr counter -1
    }
    if {![dict get $state running]} {
      deschedule $name
    }
    handle_outmessages $state
  }
  proc handle_outmessages {state} {
    log invoked [info level] [info level 0]
    set messages [dict get $state out_queue]
    dict set state out_queue {}
    dict set capicols $name $state

    foreach message $messages {
      set type [lindex $message 0]
      switch -exact -- $type {
        "die" {
          set reason [lindex $message 1]
          set message  [list capicol-death $name $reason $state]
          unschedule $name
          dict unset capicols $name
          set creator [join [lrange [split $name "."] 0 end-1]"."]
          send_message [list $creator $message [string length $message]]
          break
        }
        "beget" {
          set child_name   [lindex $message 1]
          set startup_code [lindex $message 3]
          set addresses    [lindex $message 4]
          set quota        [lindex $message 5]

          set child [::capicol::interp::new_state $child_name]
          dict incr child quota $quota
          lassign [caphandles_from_adddresses $addresses $child] dummy child
          dict set child code [translate $startup_code]
          variable capicols
          dict set capicols $child_name $child
          schedule $child_name
        }
        "gain" {
          set certificate [lindex $message 1]
          # requires SEXP and SPKI
          # where an certificate contains
          #   . a set of capabilities (capicol addresses in this instance) can be granted to
          #     eather an prinicipal (see SPKI docu) or an capicol
          #   . more quota can be granted to eather an principal or an capicol
          #   . an forzen capicol state that can be thawed and run
          #   . an beget code as in the beget capicol primitive
        }
        "message" { send_message $name [lindex $message 1] }
        default { error "unknown out-queue type: [set type] in $message" }
      }
    }
    return
  }
  proc schedule {name} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    dict set capicols $name running yes
    if {![dict exists $capicols $name run_slice_size]} {
      dict set capicols $name run_slice_size 8
    }
    if {[lsearch -exact $runlist $name] == -1} {
      lappend runlist $name
    }
    return
  }
  proc deschedule {name} {
    log invoked [info level] [info level 0]
    variable capicols
    variable runlist
    dict set capicols $name running no
    set t [lsearch -exact $runlist $name]
    set runlist [lreplace $runlist $t $t]
    return
  }
  proc send_message {sender message} {
    log invoked [info level] [info level 0]
    variable capicols

    lassign $message addresses
    lassign $addresses destination

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

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

[Category Tcl Implementations|Category Design]