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"
module "/pliant/install/ring1.pli"
public
  

constant use_properties false

type TagMarker
  void


type TagMarker
  void


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 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:LocalVariabl
'pliant tag watch active list' append addressof:GlobalVariab
'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

type ListingTag
  field Int line
  field Int column
  field Arrow value

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


type ListingTags
  field Address ptr
  field Int size
type ListingTags
  field Address ptr
  field Int size
  field Int nb


method lt add t


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
  if t:value<>null
    tsize := tsize+Arrow:size
    code := code+1
    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
  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
  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
  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
    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

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


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)
  memory_free lt:ptr


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

    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:i
      t value := r
      lt add t
  else
    if ('.and.' e:access access_constant)<>0 and e:size=0 an
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:i
      t value := r
      lt add t
  else
    if ('.and.' e:access access_constant)<>0 and e:size=0 an
      var Pointer:Arrow c :>  'pliant tag watch constant lis
      var CBool notfound:=true
      while notfound and c<>null
        if (entry_type:c=Type and e:result:type=(c map Type)
          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
    eif entry_type:(e value)<>Ident
      var Pointer:Arrow c :>  'pliant tag watch constant lis
      var CBool notfound:=true
      while notfound and c<>null
        if entry_type:c=Type and entry_type:(e value)=(c map
          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

    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 fir
    var Link:Type t :> entry_type addressof:object
    var Pointer:Arrow c :> 'pliant tag watch active list' fi
    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 I
    
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
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"+mod
  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
  if r=null
    var Link:ListingTags lt :> new ListingTags
    module define "pliant tags list"+module:name addressof:l
    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 Express

  else
    lt :> r map ListingTags
  parser_tag_record2 e lt
entry_root addressof:(the_function parser_tag_record Express


function activate_tag_hooks
  pliant_compiler_post_active_hook := (the_function active_r
  pliant_parser_pre_execute_hook := (the_function parser_tag

if pliant_debugging_level>=1
  activate_tag_hooks
function activate_tag_hooks
  pliant_compiler_post_active_hook := (the_function active_r
  pliant_parser_pre_execute_hook := (the_function parser_tag

if pliant_debugging_level>=1
  activate_tag_hooks