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

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

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

type ListingTag
  field Int line
  field Int column
  field Arrow 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
  if t:value<>null
    tsize := tsize+Arrow:size
    code := code+1
  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
  lt size := lt:size+tsize

method lt first -> 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
    aa := (a translate Int 1) translate Arrow 1
  else
    aa := a translate Int 1
  if (lt:ptr translate Byte lt:size)=aa
    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
  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
    t value := (cur translate Int 1) map Arrow
  else
    t value := null

private
  
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
    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
    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 r=null
    var Link:ListingTags lt :> new ListingTags
    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