Patch title: Release 89 bulk changes
Abstract:
File: /graphic/browser/xml/tree.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"


type XmlTree
  field Address buf
  field Pointer:XmlTree first
  field Pointer:XmlTree next
  field Float32 x0 y0 x1 y1


#------------------------------------------------------------------------
# low level handling of attibuts


function build t
  arg_w XmlTree t
  t buf := memory_allocate 2*Int:size addressof:t
  t:buf map Int := 0
  (t:buf translate Int 1) map Int := undefined
  t first :> null map XmlTree
  t x0 := undefined ; t y0 := undefined ; t x1 := undefined ; t y1 := undefined

function destroy t
  arg_w XmlTree t
  memory_free t:buf
  var Pointer:XmlTree c :> t first
  while exists:c
    var Pointer:XmlTree c2 :> c next
    XmlTree destroy_instance addressof:c
    memory_free addressof:c
    c :> c2


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

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

method n buf_size -> s
  arg XmlTree 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


function copy src dest
  arg XmlTree src ; arg_w XmlTree dest
  XmlTree destroy_instance addressof:dest
  var Int size := src buf_size
  dest buf := memory_allocate size addressof:dest
  memory_copy src:buf dest:buf size
  var Pointer:XmlTree s :> src first ; var (Pointer Pointer:XmlTree) d :>> dest first
  while exists:s
    d :> (memory_allocate XmlTree:size addressof:dest) map XmlTree
    XmlTree build_instance addressof:d
    copy s d
    s :> s next ; d :>> d next
  d :> null map XmlTree


function new_xml_node -> n
  arg_RW XmlTree n
  n :> (memory_allocate XmlTree:size null) map XmlTree
  XmlTree build_instance addressof:n
  n next :> null map XmlTree

function free_xml_node n
  arg_rw XmlTree n
  XmlTree destroy_instance addressof:n
  memory_free addressof:n


#------------------------------------------------------------------------
# high level handling of attibuts


method n tag -> value
  arg XmlTree n ; arg Str value
  value set n:buf:characters n:buf:length false
  if (value 0 1)="[0]"
    value := ""

method n 'tag :=' value
  arg_rw XmlTree n ; arg Str value
  var Int new_size := n:buf_size+value:len-n:buf:length
  var Address new_buf := memory_allocate new_size addressof:n
  var Address s := n buf ; var Address d := new_buf
  s := s next ; copy_one value d
  while not s:is_stop
    copy_one s d
  d set_stop
  check d=(new_buf translate Byte new_size-Int:size)
  memory_free n:buf
  n buf := new_buf


method n text -> value
  arg XmlTree n ; arg Str value
  value set n:buf:characters n:buf:length false
  if (value 0 1)="[0]"
    value := value 1 value:len
  else
    value := ""

method n 'text :=' value
  arg_rw XmlTree n ; arg Str value
  n tag := "[0]"+value


method n attribute attr -> value
  arg XmlTree n ; arg Str attr value
  var Address c := n:buf 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 XmlTree n ; arg Str attr value
  var Address c := n:buf 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
      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
      d set_stop
      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
  d set_stop
  check d=(new_buf translate Byte new_size-Int:size)
  memory_free n:buf
  n buf := new_buf


method n discard attr
  arg_rw XmlTree n ; arg Str attr
  var Address c := n:buf 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-(2*Int:size+attr: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
      while not s:is_stop
        (var Str item) set s:characters s:length false
        if item=attr
          s := s:next next
        else
          copy_one s d
          copy_one s d
      d set_stop
      check d=(new_buf translate Byte new_size-Int:size)
      memory_free n:buf
      n buf := new_buf
      return
    c := c next


method n first_attr a v
  arg XmlTree n ; arg_w Str a v
  var Address c := n:buf 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_attr a v
  arg XmlTree 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 t map_first p -> c
  arg XmlTree t ; arg_rw Pointer:XmlTree p ; arg CBool c
  p :> t first
  c := exists p

function map_next p -> c
  arg_rw Pointer:XmlTree p ; arg CBool c
  p :> p next
  c := exists p

meta each e
  if e:size=3 and e:0:is_pure_ident and (e:1 cast XmlTree) and e:2:ident="{}"
    e suckup e:1
    var Link:Instruction end :> instruction the_function:'do nothing'
    var Link:Argument cursor :> e local_variable e:0 Pointer:XmlTree
    var Link:Argument some :> argument local CBool
    e add (instruction (the_function '. map_first' XmlTree Pointer:XmlTree -> CBool) e:1:result cursor some)
    e add (instruction (the_function 'jump if not' CBool) some jump end)
    var Link:Instruction body :> instruction the_function:'do nothing'
    e add body
    e suckup e:1
    e add (instruction (the_function map_next Pointer:XmlTree -> CBool) cursor some)
    e add (instruction (the_function 'jump if' CBool) some jump body)
    e add end
    e set_void_result


#------------------------------------------------------------------------


export XmlTree
export '. tag' '. tag :='
export '. text' '. text :='
export '. attribute' '. attribute :=' '. discard'
export '. first_attr' '. next_attr'
export '. first' '. next'
export '. x0' '. y0' '. x1' '. y1'
export each

export new_xml_node free_xml_node