Patch title: Release 84 bulk changes
Abstract:
File: /pliant/language/compiler/expression/freeze.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring3.pli"


gvar Int freeze_counter := 0


method e uses a -> answer
  arg Expression e ; arg Argument a ; arg CBool answer
  var Pointer:Arrow c :> e:instructions first 
  while c<>null
    var Pointer:Instruction instr :> c map Instruction
    for (var Int i) 0 instr:size-1
      var Pointer:Argument arg :> instr i
      if addressof:arg=addressof:a
        return true
      while arg:where=argument_indirect
        var Pointer:Argument arg :> arg pointer
        if addressof:arg=addressof:a
          return true
    c :> e:instructions next c
  answer := false

method final freeze expressions byaddress functions type
  arg_rw Expression final ; arg_rw List expressions byaddress ; arg_rw List functions ; arg_rw Link:Type type
  var Pointer:Module module :> final module
  var Address mark := module mark
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant locals"
  var Link:List external_locals
  if c=null
    external_locals :> new List
    module define "pliant locals" addressof:external_locals
  else
    check (addressof entry_type:c)=addressof:List
    external_locals :> c map List
  var List instructions instructions2
  type :> new Type
  freeze_counter := freeze_counter+1
  type name := "(Freeze "+string:freeze_counter+")"
  type position := final position
  var Link:Argument newadr :> argument local Address
  var Link:Argument newobj :> argument indirect type newadr 0
  instructions append addressof:(instruction (the_function entry_new Type -> Address) (argument mapped_constant Type type) newadr)
  var Pointer:Arrow r :> expressions first
  while r<>null
    check (addressof entry_type:r)=addressof:Expression
    var Pointer:Expression e :> r map Expression
    var Link:Function fun :> new Function
    var Link:Array arguments :> new Array
    arguments 'size :=' 1
    module define "pliant arguments" addressof:arguments
    var Link:Argument arg :> argument local Address
    arguments 0 := addressof:arg
    var Relation originals := var Relation empty_relation
    var Link:List intern_locals :> new List
    module define "pliant locals" addressof:intern_locals
    var Pointer:Arrow c :> external_locals first
    while c<>null
      check (addressof entry_type:c)=(addressof LocalVariable)
      var Link:LocalVariable l :> c map LocalVariable
      var Pointer:Type t :> l:body type
      var Link:LocalVariable l2 :> new LocalVariable
      l2 name := l name
      l2 function :> fun
      l2 body :> argument local t
      l2:body name := l:body name
      l2 access := l access
      module define l:name addressof:l2
      intern_locals append addressof:l2
      originals define addressof:l2 null addressof:l
      c :> external_locals next c
    fun name := "frozen expression at "+e:position
    fun position := e position
    fun define_argument Address access_read+access_byvalue "" null
    fun terminate_arguments 0
    functions append addressof:fun
    module define "pliant function" addressof:fun
    e compile
    if error_notified
      module rewind mark
      if error_top_record:id=error_id_compile and final:error_message="" 
        final error_message := error_top_record message
      return
    var Link:Argument da :> argument local DelayedAction
    var Link:Argument adr :> argument local Address
    instructions2 append addressof:(instruction (the_function 'address Universal' Universal -> Address) da adr)
    var Link:Argument field :> argument indirect Arrow adr 0
    instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) (argument mapped_constant Function fun) field)
    field :> argument indirect Arrow adr Arrow:size
    instructions2 append addressof:(instruction (the_function 'arrow Universal' Universal -> Arrow) newobj field)
    var Pointer:Arrow c :> intern_locals first
    while c<>null
      check (addressof entry_type:c)=addressof:LocalVariable
      var Link:LocalVariable l2 :> c map LocalVariable
      var Link:LocalVariable l :> (originals query addressof:l2 null) map LocalVariable
      if addressof:l<>null and (e uses l2:body)
        var Int i := 0
        while i<type:nb_fields and (type field i):name<>l2:name
          i := i+1
        var Pointer:Type t :> l2:body type
        var CBool v := (t:flags .and. type_flag_do_not_copy)=0
        var Pointer:Arrow c2 :> byaddress first
        while c2<>null
          check (addressof entry_type:c2)=addressof:Ident
          if (cast (c2 map Ident) Str)=l2:name
            v := false
          c2 :> byaddress next c2
        var Int offset
        if i<>type:nb_fields
          offset := (type field i) offset
        else
          offset := type size
          if v
            type define_field t l2:name null
          else
            type define_field Address l2:name null
          var Link:Argument field :> argument indirect Address newadr offset
          if v
            instructions append addressof:(instruction (the_function 'copy Universal' Universal Universal Type) l:body field (argument mapped_constant Type t))
          else
            instructions append addressof:(instruction (the_function 'address Universal' Universal -> Address) l:body field)
        l2:body locate t argument_indirect
        if v
          l2:body pointer :> arg ; l2:body offset := offset
        else
          l2:body pointer :> (argument indirect Address arg offset) ; l2:body offset := 0
      c :> intern_locals next c
    var Link:GeneratorContext gc :> new GeneratorContext
    gc setup e fun
    gc optimize
    e set_result da access_read_write
    module rewind mark
    r :> expressions next r
  type terminate_fields
  r :> functions first
  while r<>null
    check (addressof entry_type:r)=addressof:Function
    var Pointer:Function f :> r map Function
    (f arg 0) type :> pointerto type
    r :> functions next r
  r :> instructions first
  while r<>null
    final add (r map Instruction)
    r :> instructions next r
  r :> instructions2 first
  while r<>null
    final add (r map Instruction)
    r :> instructions2 next r


method e freeze 
  arg_rw Expression e
  var List expressions byaddress functions ; var Link:Type type
  expressions append addressof:e
  e freeze expressions byaddress functions type


meta 'pliant share arguments' e
  var Pointer:Arrow r :> e:module first "pliant shared"
  if r=null
    return
  if e:size<1
    return
  for (var Int i) 0 e:size-1
    if not e:i:is_pure_ident
      return
  for (var Int i) 0 e:size-1
    e:i compile ?
  var Pointer:List byaddress :> r map List
  for (var Int i) 0 e:size-1
    var Pointer:Arrow r :> byaddress first
    while r<>null and (r map Ident)<>(e:i:value map Ident)
      r :> byaddress next r
    if r=null
      byaddress append addressof:(e:i:value map Ident)
  if e:size=1
    e set_result e:0:result e:0:access
  else
    e set_void_result


export '. freeze'
export 'pliant share arguments'