Patch title: Release 90 bulk changes
Abstract:
File: /protocol/http/stack.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"


module "/pliant/language/compiler.pli"


type HtmlBuffer
type TagBuffer
  field ListNode_ node
  field Address cursor stop

  field ListNode_ node
  field Address cursor stop

type HtmlTransition
type TagTransition
  field Int kind # 0 = mark, 1 = assignment
  field Int kind # 0 = mark, 1 = assignment
  field Pointer:HtmlTransition previous
  field Pointer:TagTransition previous
  field Address a0 a1 a2 a3

  field Address a0 a1 a2 a3

type HtmlExtra
type TagExtra
  field Str id
  field Str value
  field Str id
  field Str value
  field Pointer:HtmlExtra next # must be the last field
  field Pointer:TagExtra next # must be the last field


type HtmlStack
type TagStack
  field Array:Address map
  field Array:Address map
  field Pointer:HtmlTransition last_record
  field Pointer:HtmlBuffer buffer
  field Pointer:TagTransition last_record
  field Pointer:TagBuffer buffer
  field List_ buffers
  field List_ buffers
  field Pointer:HtmlExtra first_extra
  field (Pointer Pointer:HtmlExtra) last_extra
  field Pointer:TagExtra first_extra
  field (Pointer Pointer:TagExtra) last_extra






gvar HtmlBuffer no_buffer
memory_clear addressof:no_buffer HtmlBuffer:size
gvar TagBuffer no_buffer
memory_clear addressof:no_buffer TagBuffer:size




function html_stack_slot type default -> index
function tag_stack_slot type default -> index
  arg Type type ; arg Address default ; arg Int index
  sem request
  index := attr_default size
  var Arrow d := entry_new type
  if default<>null
    type copy_instance default d
  attr_default += d
  sem release


function build e
  arg Type type ; arg Address default ; arg Int index
  sem request
  index := attr_default size
  var Arrow d := entry_new type
  if default<>null
    type copy_instance default d
  attr_default += d
  sem release


function build e
  arg_w HtmlStack e
  arg_w TagStack e
  e buffer :> no_buffer
  e buffer :> no_buffer
  e last_record :> null map HtmlTransition
  e first_extra :> null map HtmlExtra
  e last_record :> null map TagTransition
  e first_extra :> null map TagExtra
  e last_extra :>> e first_extra

function destroy e
  e last_extra :>> e first_extra

function destroy e
  arg_w HtmlStack e
  arg_w TagStack e
  if (exists e:last_record)
  if (exists e:last_record)
    error error_id_mismatch "missing HtmlStack rewind instru
    error error_id_mismatch "missing TagStack rewind instruction"
  var Pointer:ListNode_ n :> e:buffers first
  while exists:n
    var Pointer:ListNode_ nn :> n next
    memory_free addressof:n
    n :> nn

method e initialize
  var Pointer:ListNode_ n :> e:buffers first
  while exists:n
    var Pointer:ListNode_ nn :> n next
    memory_free addressof:n
    n :> nn

method e initialize
  arg_rw HtmlStack e
  arg_rw TagStack e
  var Int old_size := e:map size
  sem rd_request
  e:map size := attr_default size
  for (var Int i) old_size e:map:size-1
    e:map i := attr_default i
  sem rd_release


method e allocate size -> adr
  var Int old_size := e:map size
  sem rd_request
  e:map size := attr_default size
  for (var Int i) old_size e:map:size-1
    e:map i := attr_default i
  sem rd_release


method e allocate size -> adr
  arg_rw HtmlStack e ; arg Int size ; arg Address adr
  var Pointer:HtmlBuffer b :> e buffer
  arg_rw TagStack e ; arg Int size ; arg Address adr
  var Pointer:TagBuffer b :> e buffer
  part try
    if (cast b:stop Int).-.(cast b:cursor Int)<size
  part try
    if (cast b:stop Int).-.(cast b:cursor Int)<size
      b :> (addressof b:node:next) map HtmlBuffer
      b :> (addressof b:node:next) map TagBuffer
      if exists:b
      if exists:b
        b cursor := addressof:b translate HtmlBuffer 1
        b cursor := addressof:b translate TagBuffer 1
        e buffer :> b
        restart try
      var Int bsize := max default_buffer_size size
        e buffer :> b
        restart try
      var Int bsize := max default_buffer_size size
      b :> (memory_allocate HtmlBuffer:size+bsize addressof:
      b cursor := addressof:b translate HtmlBuffer 1
      b :> (memory_allocate TagBuffer:size+bsize addressof:e) map TagBuffer
      b cursor := addressof:b translate TagBuffer 1
      b stop := b:cursor translate Byte bsize
      e:buffers append b:node
      e buffer :> b
  adr := b cursor
  b cursor := b:cursor translate Byte size


method e map index -> adr
      b stop := b:cursor translate Byte bsize
      e:buffers append b:node
      e buffer :> b
  adr := b cursor
  b cursor := b:cursor translate Byte size


method e map index -> adr
  arg HtmlStack e ; arg Int index ; arg Address adr
  arg TagStack e ; arg Int index ; arg Address adr
  adr := e:map index


method e mark
  adr := e:map index


method e mark
  arg_rw HtmlStack e
  var Pointer:HtmlTransition t :> (e allocate HtmlTransition
  arg_rw TagStack e
  var Pointer:TagTransition t :> (e allocate TagTransition:size) map TagTransition
  t kind := 0
  t previous :> e last_record
  t a0 := addressof e:buffer
  t a1 := e:buffer cursor
  t a2 := addressof e:first_extra
  t kind := 0
  t previous :> e last_record
  t a0 := addressof e:buffer
  t a1 := e:buffer cursor
  t a2 := addressof e:first_extra
  t a3 := addressof Pointer:HtmlExtra e:last_extra
  t a3 := addressof Pointer:TagExtra e:last_extra
  e last_record :> t
  e last_record :> t
  e first_extra :> null map HtmlExtra
  e first_extra :> null map TagExtra
  e last_extra :>> e first_extra

method e rewind
  e last_extra :>> e first_extra

method e rewind
  arg_rw HtmlStack e
  var Pointer:HtmlTransition t :> e last_record
  arg_rw TagStack e
  var Pointer:TagTransition t :> e last_record
  while t:kind=1
    (t:a1 map Type) destroy_instance e:map:(cast t:a0 Int)
    e:map (cast t:a0 Int) := t a2
    t :> t previous
  while t:kind=1
    (t:a1 map Type) destroy_instance e:map:(cast t:a0 Int)
    e:map (cast t:a0 Int) := t a2
    t :> t previous
  e buffer :> t:a0 map HtmlBuffer
  e buffer :> t:a0 map TagBuffer
  e:buffer cursor := t a1
  e:buffer cursor := t a1
  e first_extra :> t:a2 map HtmlExtra
  e last_extra :>> t:a3 map Pointer:HtmlExtra
  e first_extra :> t:a2 map TagExtra
  e last_extra :>> t:a3 map Pointer:TagExtra
  e last_record :> t previous


method e push index value type
  e last_record :> t previous


method e push index value type
  arg_rw HtmlStack e ; arg Int index ; arg Address value ; a
  arg_rw TagStack e ; arg Int index ; arg Address value ; arg Type type
  check (entry_type attr_default:index)=type
  check (entry_type attr_default:index)=type
  var Pointer:HtmlTransition t :> (e allocate HtmlTransition
  var Pointer:TagTransition t :> (e allocate TagTransition:size) map TagTransition
  t kind := 1
  t previous :> e last_record
  t a0 := cast index Address
  t a1 := addressof type
  t a2 := e:map index
  e last_record :> t
  var Address a := e allocate type:size
  type build_instance a
  type copy_instance value a
  e:map index := a


method e set id value
  t kind := 1
  t previous :> e last_record
  t a0 := cast index Address
  t a1 := addressof type
  t a2 := e:map index
  e last_record :> t
  var Address a := e allocate type:size
  type build_instance a
  type copy_instance value a
  e:map index := a


method e set id value
  arg_rw HtmlStack e ; arg Str id value
  var Pointer:HtmlExtra ex :> (e allocate HtmlExtra:size+id:
  HtmlExtra build_instance addressof:ex
  ex:id set (addressof:ex translate HtmlExtra 1) id:len fals
  arg_rw TagStack e ; arg Str id value
  var Pointer:TagExtra ex :> (e allocate TagExtra:size+id:len+value:len) map TagExtra
  TagExtra build_instance addressof:ex
  ex:id set (addressof:ex translate TagExtra 1) id:len false
  memory_copy id:characters ex:id:characters id:len
  ex:value set (ex:id:characters translate Char id:len) valu
  memory_copy value:characters ex:value:characters value:len
  memory_copy id:characters ex:id:characters id:len
  ex:value set (ex:id:characters translate Char id:len) valu
  memory_copy value:characters ex:value:characters value:len
  ex next :> null map HtmlExtra
  ex next :> null map TagExtra
  e last_extra :> ex
  e last_extra :>> ex next

  
method e walk id value
  e last_extra :> ex
  e last_extra :>> ex next

  
method e walk id value
  arg HtmlStack e ; arg_w Str id value
  id set ((addressof Pointer:HtmlExtra e:first_extra) transl
  arg TagStack e ; arg_w Str id value
  id set ((addressof Pointer:TagExtra e:first_extra) translate Pointer:TagExtra 1) 0 false

method e another id value -> available

method e another id value -> available
  arg HtmlStack e ; arg_w Str id ; arg_rw Str value ; arg CB
  var Pointer:HtmlExtra ex :> id:characters map HtmlExtra -1
  arg TagStack e ; arg_w Str id ; arg_rw Str value ; arg CBool available
  var Pointer:TagExtra ex :> id:characters map TagExtra -1
  ex :> ex next
  if exists:ex
    id set ex:id:characters ex:id:len false
    value set ex:value:characters ex:value:len false
    available := true
  else
    id := ""
    value := ""
    available := false


  ex :> ex next
  if exists:ex
    id set ex:id:characters ex:id:len false
    value set ex:value:characters ex:value:len false
    available := true
  else
    id := ""
    value := ""
    available := false


export html_stack_slot
export HtmlStack '. initialize' '. mark' '. rewind'
export tag_stack_slot
export TagStack '. initialize' '. mark' '. rewind'
export '. map' '. push'
export '. set' '. walk' '. another'








export '. map' '. push'
export '. set' '. walk' '. another'