Patch title: Release 92 bulk changes
Abstract:
File: /appli/browser/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/language/stream.pli"
submodule "/pliant/language/data/id.pli"

constant use_extra true


type DocumentNode
  field Address buf
  field Pointer:DocumentNode first
  field Pointer:DocumentNode next
  field Pointer:DocumentNode back
  field Pointer:DocumentNode hnext
  if use_extra
    field Address extra


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 DocumentNode 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 n id -> value
  arg DocumentNode n ; arg Str value
  var Address a := n:buf
  value set a:characters a:length false


method n tag -> value
  arg DocumentNode n ; arg Str value
  var Address a := n:buf next
  value set a:characters a:length false

method n 'tag :=' value
  arg_rw DocumentNode n ; arg Str value
  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 attribute attr -> value
  arg DocumentNode 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 := ""

method n 'attribute :=' attr value
  arg_rw DocumentNode 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
      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_attribute a v
  arg DocumentNode n ; arg_w Str a v
  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
  else
    a := ""
    v := ""
 
method n next_attribute a v
  arg DocumentNode n ; arg_rw Str a v
  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
  else
    a := ""
    v := ""


method n parent -> p
  arg DocumentNode n ; arg_C DocumentNode p
  var Pointer:DocumentNode l :> n
  while { p :> l back ; exists:p and (addressof p:first)<>addressof:l }
    l :> p ; p :> p back

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


type Document
  inherit CachePrototype
  field DocumentNode root
  field Address table
  field Int hashsize
  field Int count
  field Sem sem
  field Link:Stream stream

method d drop
  oarg_rw Document d
  generic


function build d
  arg_w Document d
  d:root buf := memory_allocate 3*Int:size addressof:d
  var Address a := d:root buf
  copy_one "" a
  copy_one "" a
  set_stop a
  d:root first :> null map DocumentNode
  d:root next :> null map DocumentNode
  d:root back :> null map DocumentNode
  if use_extra
    d:root extra := null
  d table := null
  d hashsize := 0
  d count := 0

function destroy d
  arg_w Document d
  for (var Int i) 0 d:hashsize-1
    var Pointer:DocumentNode n :> (d:table translate Address i) map Pointer:DocumentNode
    while addressof:n<>null
      var Pointer:DocumentNode n2 :> n hnext
      memory_free n:buf
      if use_extra
        memory_free n:extra
      memory_free addressof:n
      n :> n2
  memory_free d:root:buf
  memory_free d:table


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


method d create_node id tag -> n
  arg_rw Document d ; arg Str id tag ; arg_RW DocumentNode n
  n :> (memory_allocate DocumentNode:size addressof:d) map DocumentNode
  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 DocumentNode
  n next :> null map DocumentNode
  n back :> null map DocumentNode
  if use_extra
    n extra := null
  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:DocumentNode i
  d:table map Pointer:DocumentNode i :> n


method n unstick
  arg_rw DocumentNode n
  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 DocumentNode

method d delete_node n
  arg_rw Document d ; arg_rw DocumentNode n
  n unstick
  var Int i := (hash n:id)%(cast d:hashsize uInt)
  var (Pointer Pointer:DocumentNode) ptr :>> d:table map Pointer:DocumentNode i
  while addressof:ptr<>addressof:n
    ptr :>> ptr hnext
  ptr :> n hnext
  memory_free n:buf
  if use_extra
    memory_free n:extra
  memory_free addressof:n


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


method d stick_beetwen n parent previous next
  arg_rw Document d ; arg_rw DocumentNode 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 Document d ; arg_rw DocumentNode n ; arg Int mode ; arg DocumentNode ref
  n unstick
  if mode=stick_before
    var Pointer:DocumentNode next :> ref
    var Pointer:DocumentNode parent :> null map DocumentNode
    var Pointer:DocumentNode previous :> next back
    if (addressof previous:next)<>addressof:next
      previous :> null map DocumentNode
      parent :> next back
    d stick_beetwen n parent previous next
  eif mode=stick_after
    var Pointer:DocumentNode previous :> ref
    d stick_beetwen n (null map DocumentNode) previous previous:next
  eif mode=stick_head
    var Pointer:DocumentNode parent :> ref
    d stick_beetwen n parent (null map DocumentNode) parent:first
  eif mode=stick_tail
    var Pointer:DocumentNode parent :> ref
    if (exists parent:first)
      var Pointer:DocumentNode previous :> parent first
      while (exists previous:next)
        previous :> previous next
      d stick_beetwen n parent previous (null map DocumentNode)
    else
      d stick_beetwen n parent (null map DocumentNode) (null map DocumentNode)
  else
    error error_id_unexpected "Incorrect stick mode parameter"


named_expression each_prototype
  var Pointer:DocumentNode 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 DocumentNode) and e:2:ident="{}"
    e compile_as (expression duplicate each_prototype substitute v e:0 substitute n e:1 substitute body e:2)


export DocumentNode '. id' '. tag' '. tag :=' '. attribute' '. attribute :='
export '. first_attribute' '. next_attribute'
export '. first' '. next' '. parent' '. is_root'
export each
if use_extra
  export '. extra'
export Document '. root' '. create_node' '. delete_node' '. search_node'
export '. stick' '. unstick'