/pliant/protocol/http/stack.pli
 
 1  module "/pliant/language/compiler.pli" 
 2   
 3  constant default_buffer_size 1024 
 4   
 5   
 6  type TagBuffer 
 7    field ListNode_ node 
 8    field Address cursor stop 
 9   
 10  type TagTransition 
 11    field Int kind # 0 = mark, 1 = assignment 
 12    field Pointer:TagTransition previous 
 13    field Address a0 a1 a2 a3 
 14   
 15  type TagExtra 
 16    field Str id 
 17    field Str value 
 18    field Pointer:TagExtra next # must be the last field 
 19   
 20  type TagStack 
 21    field Array:Address map 
 22    field Pointer:TagTransition last_record 
 23    field Pointer:TagBuffer buffer 
 24    field List_ buffers 
 25    field Pointer:TagExtra first_extra 
 26    field (Pointer Pointer:TagExtra) last_extra 
 27   
 28   
 29  gvar Array:Arrow attr_default 
 30  gvar Sem sem 
 31   
 32  gvar TagBuffer no_buffer 
 33  memory_clear addressof:no_buffer TagBuffer:size 
 34   
 35   
 36  function tag_stack_slot type default -> index 
 37    arg Type type ; arg Address default ; arg Int index 
 38    sem request 
 39    index := attr_default size 
 40    var Arrow := entry_new type 
 41    if default<>null 
 42      type copy_instance default d 
 43    attr_default += d 
 44    sem release 
 45   
 46   
 47  function build e 
 48    arg_w TagStack e 
 49    buffer :> no_buffer 
 50    last_record :> null map TagTransition 
 51    first_extra :> null map TagExtra 
 52    last_extra :>> first_extra 
 53   
 54  function destroy e 
 55    arg_w TagStack e 
 56    if (exists e:last_record) 
 57      error error_id_mismatch "missing TagStack rewind instruction" 
 58    var Pointer:ListNode_ :> e:buffers first 
 59    while exists:n 
 60      var Pointer:ListNode_ nn :> next 
 61      memory_free addressof:n 
 62      :> nn 
 63   
 64  method e initialize 
 65    arg_rw TagStack e 
 66    var Int old_size := e:map size 
 67    sem rd_request 
 68    e:map size := attr_default size 
 69    for (var Int i) old_size e:map:size-1 
 70      e:map := attr_default i 
 71    sem rd_release 
 72   
 73   
 74  method e allocate size -> adr 
 75    arg_rw TagStack e ; arg Int size ; arg Address adr 
 76    var Pointer:TagBuffer :> buffer 
 77    part try 
 78      if (cast b:stop Int).-.(cast b:cursor Int)<size 
 79        :> (addressof b:node:next) map TagBuffer 
 80        if exists:b 
 81          cursor := addressof:translate TagBuffer 1 
 82          buffer :> b 
 83          restart try 
 84        var Int bsize := max default_buffer_size size 
 85        :> (memory_allocate TagBuffer:size+bsize addressof:e) map TagBuffer 
 86        cursor := addressof:translate TagBuffer 1 
 87        stop := b:cursor translate Byte bsize 
 88        e:buffers append b:node 
 89        buffer :> b 
 90    adr := cursor 
 91    cursor := b:cursor translate Byte size 
 92   
 93   
 94  method e map index -> adr 
 95    arg TagStack e ; arg Int index ; arg Address adr 
 96    adr := e:map index 
 97   
 98   
 99  method e mark 
 100    arg_rw TagStack e 
 101    var Pointer:TagTransition :> (allocate TagTransition:size) map TagTransition 
 102    kind := 0 
 103    previous :> last_record 
 104    a0 := addressof e:buffer 
 105    a1 := e:buffer cursor 
 106    a2 := addressof e:first_extra 
 107    a3 := addressof Pointer:TagExtra e:last_extra 
 108    last_record :> t 
 109    first_extra :> null map TagExtra 
 110    last_extra :>> first_extra 
 111   
 112  method e rewind 
 113    arg_rw TagStack e 
 114    var Pointer:TagTransition :> last_record 
 115    while t:kind=1 
 116      (t:a1 map Type) destroy_instance e:map:(cast t:a0 Int) 
 117      e:map (cast t:a0 Int) := a2 
 118      :> previous 
 119    buffer :> t:a0 map TagBuffer 
 120    e:buffer cursor := a1 
 121    first_extra :> t:a2 map TagExtra 
 122    last_extra :>> t:a3 map Pointer:TagExtra 
 123    last_record :> previous 
 124   
 125   
 126  method e push index value type 
 127    arg_rw TagStack e ; arg Int index ; arg Address value ; arg Type type 
 128    check (entry_type attr_default:index)=type 
 129    var Pointer:TagTransition :> (allocate TagTransition:size) map TagTransition 
 130    kind := 1 
 131    previous :> last_record 
 132    a0 := cast index Address 
 133    a1 := addressof type 
 134    a2 := e:map index 
 135    last_record :> t 
 136    var Address := allocate type:size 
 137    type build_instance a 
 138    type copy_instance value a 
 139    e:map index := a 
 140   
 141   
 142  method e set id value 
 143    arg_rw TagStack e ; arg Str id value 
 144    var Pointer:TagExtra ex :> (allocate TagExtra:size+id:len+value:len) map TagExtra 
 145    TagExtra build_instance addressof:ex 
 146    ex:id set (addressof:ex translate TagExtra 1) id:len false 
 147    memory_copy id:characters ex:id:characters id:len 
 148    ex:value set (ex:id:characters translate Char id:len) value:len false 
 149    memory_copy value:characters ex:value:characters value:len 
 150    ex next :> null map TagExtra 
 151    last_extra :> ex 
 152    last_extra :>> ex next 
 153   
 154     
 155  method e walk id value 
 156    arg TagStack e ; arg_w Str id value 
 157    id set ((addressof Pointer:TagExtra e:first_extra) translate Pointer:TagExtra 1) 0 false 
 158   
 159  method e another id value -> available 
 160    arg TagStack e ; arg_w Str id ; arg_rw Str value ; arg CBool available 
 161    var Pointer:TagExtra ex :> id:characters map TagExtra -1 
 162    ex :> ex next 
 163    if exists:ex 
 164      id set ex:id:characters ex:id:len false 
 165      value set ex:value:characters ex:value:len false 
 166      available := true 
 167    else 
 168      id := "" 
 169      value := "" 
 170      available := false 
 171   
 172   
 173  export tag_stack_slot 
 174  export TagStack '. initialize' '. mark' '. rewind' 
 175  export '. map' '. push' 
 176  export '. set' '. walk' '. another' 
 177   
 178   
 179   
 180   
 181   
 182   
 183   
 184   
 185