Patch title: Release 87 bulk changes
Abstract:
File: /pliant/language/type/misc/tag.pli
Key:
    Removed line
    Added line
scope "/pliant/language/""/pliant/install/"
scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring1.pli"
public
  

constant use_properties false

type TagMarker
  void

function active_type tp access e
  arg TagMarker tp ; arg Int access ; arg_rw Expression e
  e set_void_result

export TagMarker

method t 'get position' -> pos
  oarg Universal t; arg ListingPosition pos
  generic
  pos:=new ListingPosition
export '. get position'

gvar Int 'pliant generate listing tags' := 1
gvar List 'pliant tag watch active list'
gvar List 'pliant tag watch constant list'
'pliant tag watch active list' append addressof:Meta
'pliant tag watch active list' append addressof:Function
'pliant tag watch active list' append addressof:LocalVariable
'pliant tag watch active list' append addressof:GlobalVariable
'pliant tag watch active list' append addressof:TagMarker
'pliant tag watch constant list' append addressof:InlineText
'pliant tag watch constant list' append addressof:Type
gvar Relation 'pliant tag watch'

function 'pliant watch' t is_active -> data
  arg Type t; arg CBool is_active; arg_RW Str data
  has_no_side_effect
  if is_active
    var Address adr := 'pliant tag watch' query addressof:t null
    if adr=null
      'pliant tag watch' define addressof:t null (addressof new:Str)
      adr := 'pliant tag watch' query addressof:t null
  else
    var Address adr := 'pliant tag watch' query null addressof:t
    if adr=null
      'pliant tag watch' define null addressof:t (addressof new:Str)
      adr := 'pliant tag watch' query null addressof:t
  return (adr map Str)

method t 'pliant is_watched' is_active -> data
  arg Type t; arg CBool is_active; arg_RW Str data
  has_no_side_effect
  if is_active
    var Address adr := 'pliant tag watch' query addressof:t null
  else
    var Address adr := 'pliant tag watch' query null addressof:t
  return (adr map Str)

export 'pliant watch' '. pliant is_watched'

'pliant watch' Meta true
'pliant watch' Function true
'pliant watch' LocalVariable true
'pliant watch' GlobalVariable true
'pliant watch' TagMarker true
'pliant watch' InlineText false
'pliant watch' Type false

export 'pliant generate listing tags' 

type ListingTag
  field Int line
  field Int column
  field Arrow value

export ListingTag '. line' '. column' '. value'


type ListingTags
  field Address ptr
  field Int size
  field Int nb

function build lt
  arg_w ListingTags lt
  lt ptr := null
  lt size := 0

method lt add t
  arg_rw ListingTags lt; arg ListingTag t
  var Int tsize := Int:size
  var Int code := t:line*(2^17)+t:column*2
  arg_rw ListingTags lt ; arg ListingTag t
  var Int tsize := Int size
  var Int code := t:line*2^17+t:column*2
  if t:value<>null
    tsize := tsize+Arrow:size
    code := code+1
  if ('.and.' code 1)<>0
    tsize := tsize+Arrow:size
  lt ptr := memory_resize lt:ptr lt:size+tsize addressof:lt
  var Address a := lt:ptr translate Byte lt:size
  a map Int := code
  if t:value<>null
    Arrow build_instance (a translate Int 1)
    (a translate Int 1) map Arrow := t:value
  if ('.and.' code 1)<>0
    entry_lock t:value
    (a translate Int 1) map Address := t value
  lt size := lt:size+tsize

method lt first -> a
  arg ListingTags lt; arg Address a
  arg ListingTags lt ; arg Address a
  a := lt ptr

method lt next a -> aa
  arg ListingTags lt; arg Address a aa
  var Pointer:Int pc :> a map Int
  if ('.and.' pc 1) <> 0
  arg ListingTags lt ; arg Address a aa
  var Int code := a map Int
  if ('.and.' code 1)<>0
    aa := (a translate Int 1) translate Arrow 1
  else
    aa := a translate Int 1
  if (lt:ptr translate Byte lt:size)=aa
    aa:=null
  if aa=(lt:ptr translate Byte lt:size)
    aa := null

function destroy lt
  arg_w ListingTags lt
  var Address cur := lt first
  while cur<>null
    var Pointer:Int pc :> cur map Int
    if ('.and.' pc 1)<>0
      Arrow destroy_instance (cur translate Int 1)
    cur := lt next cur
  if true # FIXME: this is the part of the code disturbing the memory unload at the end of debugging level 2 precompiling
    var Address cur := lt first
    while cur<>null
      var Int code := cur map Int
      if ('.and.' code 1)<>0
        entry_unlock ((cur translate Int 1) map Address)
      cur := lt next cur
  memory_free lt:ptr

function copy src dest
  arg ListingTags src; arg_w ListingTags dest
  ListingTags destroy_instance addressof:dest
  dest ptr := memory_allocate src:size addressof:dest
  dest size := src size
  memory_copy src:ptr dest:ptr src:size
  var Address cur := src first
  while cur<>null
    var Pointer:Int pc :> cur map Int
    if ('.and.' pc 1)<>0
      entry_lock ((cur translate Int 1) map Address)
    cur := src next cur

method lt get cur -> t
  arg ListingTags lt; arg Address cur; arg ListingTag t
  var Pointer:Int pc :> cur map Int
  t column := '.and.' (pc \ 2) (2^16-1)
  t line := pc \ (2^17)
  if ('.and.' pc 1) <> 0
  if ('.and.' pc 1)<>0
    t value := (cur translate Int 1) map Arrow
  else
    t value := null

private
  
export ListingTags '. add' '. first' '. next' '. get'


function active_record object access e
  arg Universal object; arg Int access; arg_rw Expression e
  if 'pliant generate listing tags'<>0 and (e:properties first "active")=null
    var Link:Type t :> entry_type addressof:object
    if addressof:(t 'pliant is_watched' true)<>null
      e:properties insert "active" true addressof:object

entry_root addressof:(the_function active_record Universal Int Expression)
 

method e recursive_uncompile
  arg_rw Expression e
  for (var Int i) 0 e:size-1
    e:i recursive_uncompile
  e uncompile

function parser_tag_record2 e lt
  arg_rw Expression e; arg_rw ListingTags lt
  var ListingTag t
  t line := e:position:line
  t column := e:position:column
  t value := null
  var Pointer:Arrow r :> e:properties first "active"
  if r<>null
    if entry_type:(e value)<>Ident or (e:ident<>"{}" and e:ident<>"()")
      t value := r
      lt add t
  else
    if ('.and.' e:access access_constant)<>0 and e:size=0 and e:result:type<>Void
      var Pointer:Arrow c :>  'pliant tag watch constant list' first
      var CBool notfound:=true
      while notfound and c<>null
        if (entry_type:c=Type and e:result:type=(c map Type)) or 'pliant generate listing tags'=2
          t value := e:result:constant
          notfound:=false
        else
          c :> 'pliant tag watch constant list' next c
      if addressof:(e:result:type 'pliant is_watched' false)<>null or 'pliant generate listing tags'=2
        t value := e:result:constant
    eif entry_type:(e value)<>Ident
      var Pointer:Arrow c :>  'pliant tag watch constant list' first
      var CBool notfound:=true
      while notfound and c<>null
        if entry_type:c=Type and entry_type:(e value)=(c map Type)
          t value := e value
          notfound:=false
        else
          c :> 'pliant tag watch constant list' next c
      if addressof:(entry_type:(e value) 'pliant is_watched' false)<>null
        t value := e value
    lt add t
  for (var Int i) 0 e:size-1
     parser_tag_record2 e:i lt

method e recursive_uncompile
  arg_rw Expression e
  for (var Int i) 0 e:size-1
    e:i recursive_uncompile
  e uncompile


function active_record object access e
  arg Universal object; arg Int access; arg_rw Expression e
  if 'pliant generate listing tags'<>0 and (e:properties first "active")=null
    var Link:Type t :> entry_type addressof:object
    var Pointer:Arrow c :> 'pliant tag watch active list' first
    while c<>null
      if entry_type:c=Type and t=(c map Type)
        e:properties insert "active" true addressof:object
        return
      c :> 'pliant tag watch active list' next c
entry_root addressof:(the_function active_record Universal Int Expression)
    
function parser_tag_record e
  arg_rw Expression e
  e recursive_uncompile
  e compile
  var Link:Module module :> e module
  if addressof:(module:external)<>null
    module :> module external
  var Pointer:Arrow r :> module first "pliant tags list"+module:name
  if use_properties
    var Pointer:Arrow r :> module:properties first "pliant tags list"
  else
    var Pointer:Arrow r :> module first "pliant tags list "+module:name
  if r=null
    var Link:ListingTags lt :> new ListingTags
    module define "pliant tags list"+module:name addressof:lt
    if use_properties
      module:properties insert "pliant tags list" true addressof:lt
    else
      module define "pliant tags list "+module:name addressof:lt
  else
    lt :> r map ListingTags
  parser_tag_record2 e lt
entry_root addressof:(the_function parser_tag_record Expression)


function activate_tag_hooks
  pliant_compiler_post_active_hook := (the_function active_record Universal Int Expression) executable
  pliant_parser_pre_execute_hook := (the_function parser_tag_record Expression) executable

if pliant_debugging_level>=1
  activate_tag_hooks