Patch title: Release 94 bulk changes
Abstract:
File: /pliant/storage/document/document.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/storage/ground/control.pli"
module "/pliant/language/schedule/threads_engine.pli"
submodule "/pliant/language/data/id.pli"
module "/pliant/language/stream.pli"
module "/pliant/util/pml/io.pli"

type StorageNode
  field Address buf
  field Pointer:StorageNode first
  field Pointer:StorageNode next
  field Pointer:StorageNode back
  field Pointer:StorageNode hnext


type StorageDocument
  inherit CachePrototype
  field Address table
  field Int hashsize
  field Int count
  field Link:StorageControl control
  field Str fiber
  # field Dictionary attached


method a characters -> c
  arg Address a ; arg Address c
  c := a translate Int 1

method a length -> l
  arg Address a ; arg Int l
  l := a map Int

method a next -> a2
  arg Address a ; arg Address a2
  a2 := a:characters translate Char a:length

method a is_stop -> c
  arg Address a ; arg CBool c
  c := (a map Int)=undefined

function copy_one s d
  arg_rw Address s d
  var Int l := s length ; d map Int := l
  memory_copy s:characters d:characters l
  s := s next
  d := d next

function copy_one s d
  arg Str s ; arg_rw Address d
  d map Int := s:len
  memory_copy s:characters d:characters s:len
  d := d next

function set_stop a
  arg Address a
  a map Int := undefined

method n buf_size -> s
  arg StorageNode n ; arg Int s
  var Address c := n buf
  while not c:is_stop
    c := c next
  s := (cast c Int) .-. (cast n:buf Int) + Int:size


method d log_begin -> required
  arg_rw StorageDocument d ; arg CBool required
  if d:is_update
    return false
  if not (exists d:control)
    if (d:id parse "/pliant/fiber/" any:(var Str site) "/" any:(var Str category) "/" any:(var Str object) "/" any:(var Str fiber))
      d control :> storage_control site category object
      d fiber := fiber
  d:control fiber_modify_begin d:fiber current_thread_header:user
  required := true

method d log -> s
  arg_rw StorageDocument d ; arg_C Stream s
  s :> d:control stream

method d log_end
  arg_rw StorageDocument d
  d:control fiber_modify_end


method n id -> value
  arg StorageNode n ; arg Str value
  var Address a := n buf
  value set a:characters a:length false
((the_function '. id' StorageNode -> Str) arg 1) maps := 1

method n tag -> value
  arg StorageNode n ; arg Str value
  var Address a := n:buf next
  value set a:characters a:length false
((the_function '. tag' StorageNode -> Str) arg 1) maps := 1

method sd set_tag n value
  arg_rw StorageDocument sd ; arg_rw StorageNode n ; arg Str value
  if sd:log_begin
    sd:log otag "tag" n:id value
    sd log_end
  var Int new_size := n:buf_size+value:len-n:buf:next:length
  var Address new_buf := memory_allocate new_size addressof:n
  var Address s := n buf ; var Address d := new_buf
  copy_one s d
  s := s next ; copy_one value d
  while not s:is_stop
    copy_one s d
  set_stop d
  check d=(new_buf translate Byte new_size-Int:size)
  memory_free n:buf
  n buf := new_buf


method n attr attr -> value
  arg StorageNode n ; arg Str attr value
  var Address c := n:buf:next next
  while not c:is_stop
    (var Str item) set c:characters c:length false
    c := c next
    if item=attr
      value set c:characters c:length false
      return
    c := c next
  value := ""
((the_function '. attr' StorageNode Str -> Str) arg 2) maps := 1

method sd set_attr n attr value
  arg_rw StorageDocument sd ; arg_rw StorageNode n ; arg Str attr value
  if sd:log_begin
    sd:log otag "attr" n:id attr value
    sd log_end
  var Address c := n:buf:next next
  while not c:is_stop
    (var Str item) set c:characters c:length false
    c := c next
    if item=attr
      var Int new_size := n:buf_size+value:len-c:length
      var Address new_buf := memory_allocate new_size addressof:n
      var Address s := n buf ; var Address d := new_buf
      copy_one s d
      copy_one s d
      while not s:is_stop
        (var Str item) set s:characters s:length false
        copy_one s d
        if item=attr
          s := s next ; copy_one value d
        else
          copy_one s d
      set_stop d
      check d=(new_buf translate Byte new_size-Int:size)
      memory_free n:buf
      n buf := new_buf
      return
    c := c next
  var Int new_size := n:buf_size+2*Int:size+attr:len+value:len
  var Address new_buf := memory_allocate new_size addressof:n
  var Address s := n buf ; var Address d := new_buf
  while not s:is_stop
    copy_one s d
  copy_one attr d
  copy_one value d
  set_stop d
  check d=(new_buf translate Byte new_size-Int:size)
  memory_free n:buf
  n buf := new_buf


method n first_attr a v -> found
  arg StorageNode n ; arg_w Str a v ; arg CBool found
  var Address c := n:buf:next next
  if not c:is_stop
    a set c:characters c:length false
    c := c next
    v set c:characters c:length false
    found := true
  else
    a := ""
    v := ""
    found := false
((the_function '. first_attr' StorageNode Str Str -> CBool) arg 1) maps := 1
((the_function '. first_attr' StorageNode Str Str -> CBool) arg 2) maps := 1
 
method n next_attr a v -> found
  arg StorageNode n ; arg_rw Str a v ; arg CBool found
  var Address c := v:characters translate Char v:len
  if not c:is_stop
    a set c:characters c:length false
    c := c next
    v set c:characters c:length false
    found := true
  else
    a := ""
    v := ""
    found := false
((the_function '. next_attr' StorageNode Str Str -> CBool) arg 1) maps := 1
((the_function '. next_attr' StorageNode Str Str -> CBool) arg 2) maps := 1


method sd reset_attr n
  arg_rw StorageDocument sd ; arg_rw StorageNode n
  var Address new_buf := memory_allocate 3*Int:size+n:buf:length+n:buf:next:length addressof:n
  var Address s := n buf ; var Address d := new_buf
  copy_one s d
  copy_one s d
  set_stop d
  check d=(new_buf translate Byte 2*Int:size+n:buf:length+n:buf:next:length)
  memory_free n:buf
  n buf := new_buf
  if sd:log_begin
    sd:log otag "reset" n:id
    sd log_end


method n previous -> p
  arg StorageNode n ; arg_C StorageNode p
  p :> n back
  if exists:p and (addressof p:first)=addressof:n
    p :> null map StorageNode

method n parent -> p
  arg StorageNode n ; arg_C StorageNode p
  var Pointer:StorageNode l :> n
  while { p :> l back ; exists:p and (addressof p:next)=addressof:l }
    l :> p

method n is_root -> c
  arg StorageNode n ; arg CBool c
  c := not (exists n:back)


function build d
  arg_w StorageDocument d
  d table := null
  d hashsize := 0
  d count := 0

function destroy d
  arg_w StorageDocument d
  for (var Int i) 0 d:hashsize-1
    var Pointer:StorageNode n :> (d:table translate Address i) map Pointer:StorageNode
    while addressof:n<>null
      var Pointer:StorageNode n2 :> n hnext
      memory_free n:buf
      memory_free addressof:n
      n :> n2
  memory_free d:table

method d sleep
  oarg_rw StorageDocument d
  if (exists d:control)
    d control :> null map StorageControl


method d resize size
  arg_rw StorageDocument d ; arg Int size
  var Address newtable := memory_zallocate size*Address:size addressof:d
  for (var Int i) 0 d:hashsize-1
    var Pointer:StorageNode n :> (d:table translate Address i) map Pointer:StorageNode
    while addressof:n<>null
      var Pointer:StorageNode n2 :> n hnext
      var Int newi := (hash n:id)%(cast size uInt)
      n hnext :> newtable map Pointer:StorageNode newi
      newtable map Pointer:StorageNode newi :> n
      n :> n2
  memory_free d:table
  d table := newtable
  d hashsize := size


method d create_node id tag -> n
  arg_rw StorageDocument d ; arg Str id tag ; arg_RW StorageNode n
  n :> (memory_allocate StorageNode:size addressof:d) map StorageNode
  n buf := memory_allocate 3*Int:size+id:len+tag:len addressof:n
  var Address a := n buf
  copy_one id a
  copy_one tag a
  set_stop a
  n first :> null map StorageNode
  n next :> null map StorageNode
  n back :> null map StorageNode
  if d:count>=d:hashsize
    d resize (max 2*d:count 16)
  var Int i := (hash n:id)%(cast d:hashsize uInt)
  n hnext :> d:table map Pointer:StorageNode i
  d:table map Pointer:StorageNode i :> n
  d count += 1
  if d:log_begin
    d:log otag "create" id tag
    d log_end


method d unstick1 n
  arg_rw StorageDocument d ; arg_rw StorageNode n
  if (exists n:next)
    n:next back :> n back
  if (exists n:back)
    if (addressof n:back:first)=addressof:n
      n:back first :> n next
    else
      check (addressof n:back:next)=addressof:n
      n:back next :> n next
    n back :> null map StorageNode
    n next :> null map StorageNode

method d unstick n
  arg_rw StorageDocument d ; arg_rw StorageNode n
  d unstick1 n
  if d:log_begin
    d:log otag "unstick" n:id
    d log_end


method d delete_node n
  arg_rw StorageDocument d ; arg_rw StorageNode n
  if d:log_begin
    d:log otag "delete" n:id
    d log_end
  d unstick1 n
  var Int i := (hash n:id)%(cast d:hashsize uInt)
  var (Pointer Pointer:StorageNode) ptr :>> d:table map Pointer:StorageNode i
  while addressof:ptr<>addressof:n
    ptr :>> ptr hnext
  ptr :> n hnext
  memory_free n:buf
  memory_free addressof:n
  d count -= 1


method d search_node id -> n
  arg StorageDocument d ; arg Str id ; arg_C StorageNode n
  if d:hashsize=0
    n :> null map StorageNode
    return
  var Int i := hash:id%(cast d:hashsize uInt)
  n :> d:table map Pointer:StorageNode i
  while exists:n and n:id<>id
    n :> n hnext

method d stick_beetwen n parent previous next
  arg_rw StorageDocument d ; arg_rw StorageNode n parent previous next
  if exists:previous
    n back :> previous
    previous next :> n
  else
    n back :> parent
    parent first :> n
  n next :> next
  if exists:next
    next back :> n

public
  constant stick_before 301
  constant stick_after 302
  constant stick_head 303
  constant stick_tail 304

method d stick n mode ref
  arg_rw StorageDocument d ; arg_rw StorageNode n ; arg Int mode ; arg StorageNode ref
  d unstick1 n
  if mode=stick_before
    var Pointer:StorageNode next :> ref
    var Pointer:StorageNode parent :> null map StorageNode
    var Pointer:StorageNode previous :> next back
    if (addressof previous:next)<>addressof:next
      previous :> null map StorageNode
      parent :> next back
    d stick_beetwen n parent previous next
  eif mode=stick_after
    var Pointer:StorageNode previous :> ref
    d stick_beetwen n (null map StorageNode) previous previous:next
  eif mode=stick_head
    var Pointer:StorageNode parent :> ref
    d stick_beetwen n parent (null map StorageNode) parent:first
  eif mode=stick_tail
    var Pointer:StorageNode parent :> ref
    if (exists parent:first)
      var Pointer:StorageNode previous :> parent first
      while (exists previous:next)
        previous :> previous next
      d stick_beetwen n parent previous (null map StorageNode)
    else
      d stick_beetwen n parent (null map StorageNode) (null map StorageNode)
  else
    error error_id_unexpected "Incorrect stick mode parameter"
  if d:log_begin
    d:log otag "stick" n:id (shunt mode=stick_before (cast "before" Ident) mode=stick_after (cast "after" Ident) mode=stick_head (cast "head" Ident) mode=stick_tail (cast "tail" Ident) (cast "error" Ident)) ref:id
    d log_end


method d update s -> status
  oarg_rw StorageDocument d ; arg_rw Stream s ; arg ExtendedStatus status
  d update_begin
  while s:iavailable
    if (s itag "create" (var Str id) (var Str tag))
      d create_node id tag
    eif (s itag "delete" (var Str id))
      var Pointer:StorageNode n :> d search_node id
      if exists:n
        d delete_node n
    eif (s itag "tag" (var Str id) (var Str tag))
      var Pointer:StorageNode n :> d search_node id
      if exists:n
        d set_tag n tag
    eif (s itag "attr" (var Str id) (var Str attr) (var Str value))
      var Pointer:StorageNode n :> d search_node id
      if exists:n
        d set_attr n attr value
    eif (s itag "stick" (var Str id) (addressof:(var Str mode) map Ident) (var Str ref))
      var Pointer:StorageNode n :> d search_node id
      var Int m := shunt mode="before" stick_before mode="after" stick_after mode="head" stick_head mode="tail" stick_tail (cast undefined Int)
      var Pointer:StorageNode r :> d search_node ref
      if exists:n and m<>undefined and exists:r
        d stick n m r
    eif (s itag "unstick" (var Str id))
      var Pointer:StorageNode n :> d search_node id
      if exists:n
        d unstick n
    else
      d update_end
      return failure
  d update_end
  status := success


named_expression each_prototype
  var Pointer:StorageNode v :> n first
  while exists:v
    body
    v :> v next

meta each e
  if e:size=3 and e:0:is_pure_ident and (e:1 cast StorageNode) and e:2:ident="{}"
    e compile_as (expression duplicate each_prototype substitute v e:0 substitute n e:1 substitute body e:2)


function record_storage_class
  storage_control_type_sem request
  storage_control_types insert "StorageDocument" true addressof:StorageDocument
  storage_control_type_sem release
record_storage_class


export StorageNode '. id' '. tag' '. set_tag' '. attr' '. set_attr'
export '. first_attr' '. next_attr' '. reset_attr'
export '. first' '. next' '. previous' '. parent' '. is_root'
export each
export StorageDocument '. create_node' '. delete_node' '. search_node'
export '. stick' '. unstick'
# export '. attached'