/pliant/language/type/misc/tag.pli
 
 1  scope "/pliant/language/" "/pliant/install/" 
 2  module "/pliant/install/ring1.pli" 
 3   
 4  constant use_properties false 
 5   
 6  type TagMarker 
 7    void 
 8   
 9  function active_type tp access e 
 10    arg TagMarker tp ; arg Int access ; arg_rw Expression e 
 11    e set_void_result 
 12   
 13  export TagMarker 
 14   
 15  method t 'get position' -> pos 
 16    oarg Universal t; arg ListingPosition pos 
 17    generic 
 18    pos:=new ListingPosition 
 19  export '. get position' 
 20   
 21  gvar Int 'pliant generate listing tags' := 1 
 22  gvar Relation 'pliant tag watch' 
 23   
 24  function 'pliant watch' t is_active -> data 
 25    arg Type t; arg CBool is_active; arg_RW Str data 
 26    has_no_side_effect 
 27    if is_active 
 28      var Address adr := 'pliant tag watch' query addressof:t null 
 29      if adr=null 
 30        'pliant tag watch' define addressof:t null (addressof new:Str) 
 31        adr := 'pliant tag watch' query addressof:t null 
 32    else 
 33      var Address adr := 'pliant tag watch' query null addressof:t 
 34      if adr=null 
 35        'pliant tag watch' define null addressof:t (addressof new:Str) 
 36        adr := 'pliant tag watch' query null addressof:t 
 37    return (adr map Str) 
 38   
 39  method t 'pliant is_watched' is_active -> data 
 40    arg Type t; arg CBool is_active; arg_RW Str data 
 41    has_no_side_effect 
 42    if is_active 
 43      var Address adr := 'pliant tag watch' query addressof:t null 
 44    else 
 45      var Address adr := 'pliant tag watch' query null addressof:t 
 46    return (adr map Str) 
 47   
 48  export 'pliant watch' '. pliant is_watched' 
 49   
 50  'pliant watch' Meta true 
 51  'pliant watch' Function true 
 52  'pliant watch' LocalVariable true 
 53  'pliant watch' GlobalVariable true 
 54  'pliant watch' TagMarker true 
 55  'pliant watch' InlineText false 
 56  'pliant watch' Type false 
 57   
 58  export 'pliant generate listing tags'  
 59   
 60  type ListingTag 
 61    field Int line 
 62    field Int column 
 63    field Arrow value 
 64   
 65  export ListingTag '. line' '. column' '. value' 
 66   
 67   
 68  type ListingTags 
 69    field Address ptr 
 70    field Int size 
 71   
 72  function build lt 
 73    arg_w ListingTags lt 
 74    lt ptr := null 
 75    lt size := 0 
 76   
 77  method lt add t 
 78    arg_rw ListingTags lt ; arg ListingTag t 
 79    var Int tsize := Int size 
 80    var Int code := t:line*2^17+t:column*2 
 81    if t:value<>null 
 82      code := code+1 
 83    if ('.and.' code 1)<>0 
 84      tsize := tsize+Arrow:size 
 85    lt ptr := memory_resize lt:ptr lt:size+tsize addressof:lt 
 86    var Address a := lt:ptr translate Byte lt:size 
 87    a map Int := code 
 88    if ('.and.' code 1)<>0 
 89      entry_lock t:value 
 90      (a translate Int 1) map Address := t value 
 91    lt size := lt:size+tsize 
 92   
 93  method lt first -> a 
 94    arg ListingTags lt ; arg Address a 
 95    a := lt ptr 
 96   
 97  method lt next a -> aa 
 98    arg ListingTags lt ; arg Address a aa 
 99    var Int code := a map Int 
 100    if ('.and.' code 1)<>0 
 101      aa := (a translate Int 1) translate Arrow 1 
 102    else 
 103      aa := a translate Int 1 
 104    if aa=(lt:ptr translate Byte lt:size) 
 105      aa := null 
 106   
 107  function destroy lt 
 108    arg_w ListingTags lt 
 109    if true # FIXME: this is the part of the code disturbing the memory unload at the end of debugging level 2 precompiling 
 110      var Address cur := lt first 
 111      while cur<>null 
 112        var Int code := cur map Int 
 113        if ('.and.' code 1)<>0 
 114          entry_unlock ((cur translate Int 1) map Address) 
 115        cur := lt next cur 
 116    memory_free lt:ptr 
 117   
 118  function copy src dest 
 119    arg ListingTags src; arg_w ListingTags dest 
 120    ListingTags destroy_instance addressof:dest 
 121    dest ptr := memory_allocate src:size addressof:dest 
 122    dest size := src size 
 123    memory_copy src:ptr dest:ptr src:size 
 124    var Address cur := src first 
 125    while cur<>null 
 126      var Pointer:Int pc :> cur map Int 
 127      if ('.and.' pc 1)<>0 
 128        entry_lock ((cur translate Int 1) map Address) 
 129      cur := src next cur 
 130   
 131  method lt get cur -> t 
 132    arg ListingTags lt; arg Address cur; arg ListingTag t 
 133    var Pointer:Int pc :> cur map Int 
 134    t column := '.and.' (pc \ 2) (2^16-1) 
 135    t line := pc \ (2^17) 
 136    if ('.and.' pc 1)<>0 
 137      t value := (cur translate Int 1) map Arrow 
 138    else 
 139      t value := null 
 140   
 141  export ListingTags '. add' '. first' '. next' '. get' 
 142   
 143   
 144  function active_record object access e 
 145    arg Universal object; arg Int access; arg_rw Expression e 
 146    if 'pliant generate listing tags'<>0 and (e:properties first "active")=null 
 147      var Link:Type t :> entry_type addressof:object 
 148      if addressof:(t 'pliant is_watched' true)<>null 
 149        e:properties insert "active" true addressof:object 
 150   
 151  entry_root addressof:(the_function active_record Universal Int Expression) 
 152    
 153   
 154  method e recursive_uncompile 
 155    arg_rw Expression e 
 156    for (var Int i) 0 e:size-1 
 157      e:i recursive_uncompile 
 158    e uncompile 
 159   
 160  function parser_tag_record2 e lt 
 161    arg_rw Expression e; arg_rw ListingTags lt 
 162    var ListingTag t 
 163    t line := e:position:line 
 164    t column := e:position:column 
 165    t value := null 
 166    var Pointer:Arrow r :> e:properties first "active" 
 167    if r<>null 
 168      if entry_type:(e value)<>Ident or (e:ident<>"{}" and e:ident<>"()") 
 169        t value := r 
 170        lt add t 
 171    else 
 172      if ('.and.' e:access access_constant)<>0 and e:size=0 and e:result:type<>Void 
 173        if addressof:(e:result:type 'pliant is_watched' false)<>null or 'pliant generate listing tags'=2 
 174          t value := e:result:constant 
 175      eif entry_type:(e value)<>Ident 
 176        if addressof:(entry_type:(e value) 'pliant is_watched' false)<>null 
 177          t value := e value 
 178      lt add t 
 179    for (var Int i) 0 e:size-1 
 180       parser_tag_record2 e:i lt 
 181   
 182  function parser_tag_record e 
 183    arg_rw Expression e 
 184    e recursive_uncompile 
 185    e compile 
 186    var Link:Module module :> e module 
 187    if addressof:(module:external)<>null 
 188      module :> module external 
 189    if use_properties 
 190      var Pointer:Arrow r :> module:properties first "pliant tags list" 
 191    else 
 192      var Pointer:Arrow r :> module first "pliant tags list "+module:name 
 193    if r=null 
 194      var Link:ListingTags lt :> new ListingTags 
 195      if use_properties 
 196        module:properties insert "pliant tags list" true addressof:lt 
 197      else 
 198        module define "pliant tags list "+module:name addressof:lt 
 199    else 
 200      lt :> r map ListingTags 
 201    parser_tag_record2 e lt 
 202  entry_root addressof:(the_function parser_tag_record Expression) 
 203   
 204   
 205  function activate_tag_hooks 
 206    pliant_compiler_post_active_hook := (the_function active_record Universal Int Expression) executable 
 207    pliant_parser_pre_execute_hook := (the_function parser_tag_record Expression) executable 
 208   
 209  if pliant_debugging_level>=1 
 210    activate_tag_hooks 
 211