Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/compiler/expression/expression2.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
# Copyright (C) 1999  Patrice Ossona de Mendez  pom@ehess.fr
#
# 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/ring2.pli"


method e packed_size -> s
  arg Expression e ; arg Int s
  if (entry_type e:value)=Ident and (e:value map Str):len<256
    s := Int:size+(e:value map Str):len
  else
    s := Address size
  s := s+ListingPosition:size
  s := s+Int:size
  for (var Int i) 0 e:size-1
    s := s+(e:i packed_size)

function pack e c
  arg Expression e ; arg_rw Address c
  if (entry_type e:value)=Ident and (e:value map Str):len<256
    var Int l := (e:value map Str) len
    c map Int := l ; c := c translate Int 1
    memory_copy (e:value map Str):characters c l ; c := c translate Byte l
  else
    c map Address := e value ; entry_lock e:value ; c := c translate Address 1
  ListingPosition build_instance c
  c map ListingPosition := e position ; c := c translate ListingPosition 1
  c map Int := e size ; c := c translate Int 1
  for (var Int i) 0 e:size-1
    pack e:i c
 
function unpack c -> e
  arg_rw Address c ; arg Link:Expression e
  e :> new Expression
  if (c map Int)<256
    var Int l := c map Int ; c := c translate Int 1
    (var Str s) set c l false
    e value := entry_new Ident
    e:value map Str := s ; c := c translate Byte l
  else
    e value := c map Address ; c := c translate Address 1
  e position := c map ListingPosition ; c := c translate ListingPosition 1
  e 'size :=' (c map Int) ; c := c translate Int 1
  for (var Int i) 0 e:size-1
    e:arguments i := addressof unpack:c 
 
function drop c
  arg_rw Address c
  if (c map Int)<256
    var Int l := c map Int ; c := (c translate Int 1) translate Byte l
  else
    entry_unlock (c map Address) ; c := c translate Address 1
  ListingPosition destroy_instance c ; c := c translate ListingPosition 1 
  l := c map Int ; c := c translate Int 1
  for (var Int i) 0 l-1
    drop c
 
type PackedExpression
  field Address buffer <- null

function destroy pe
  arg_w PackedExpression pe
  if pe:buffer<>null
    var Address c := pe buffer
    drop c
    memory_free pe:buffer

function 'cast (Link PackedExpression)' e -> pe
  arg Expression e ; arg Link:PackedExpression pe
  implicit
  pe :> new PackedExpression
  var Int ps := e packed_size
  pe buffer := memory_allocate ps addressof:pe
  var Address c := pe buffer ; pack e c
  check c=(pe:buffer translate Byte ps)

function 'cast (Link Expression)' pe -> e
  arg PackedExpression pe ; arg Link:Expression e
  implicit
  check pe:buffer<>null
  var Address c := pe buffer
  e :> unpack c

export PackedExpression 'cast (Link PackedExpression)' 'cast (Link Expression)'


function duplicate e -> e2
  arg Expression e ; arg_RW Expression e2  
  e2 :> new Expression
  e2 module :> e module
  e2 position := e position
  e2 value := e value
  e2 'size :=' e:size
  for (var Int i) 0 e:size-1
    e2:arguments i := addressof (duplicate e:i)


method e 'ident :=' id
  arg_rw Expression e ; arg Str id
  e value := entry_new Ident
  e:value map Ident := cast id Ident


method e near original
  arg_rw Expression e ; arg Expression original
  if (addressof e:module)=null
    e module :> original module
  if e:position=""
    e position := original position
  for (var Int i) 0 e:size-1
    e:i near original

method e near_nothing
  arg_rw Expression e
  e module :> null map Module
  e position := var ListingPosition empty_position
  for (var Int i) 0 e:size-1
    e:i near_nothing

function duplicate_near_nothing e -> e2
  arg Expression e ; arg_RW Expression e2  
  e2 :> duplicate e
  e2 near_nothing


method e is_linked -> c
  arg Expression e ; arg CBool c
  for (var Int i) 0 e:size-1
    if not e:i:is_linked
      return false
  c := (addressof e:module)<>null


type ExpressionRange
  field Link:Expression expr
  field Int base nb

method e '' base nb -> range
  arg Expression e ; arg Int base nb ; arg ExpressionRange range
  check base>=0 and nb>=0 and base+nb<=e:size
  range expr :> e
  range base := base
  range nb := nb


method e substitute id value -> newone
  arg_rw Expression e ; arg Str id ; arg Expression value ; arg_RW Expression newone
  check value:is_linked error_id_unexpected "The substituted expression must be linked to a module"
  if e:ident=id and (addressof e:module)=null
    if e:size=0
      newone :> duplicate:value
    eif value:size=0
      newone :> duplicate value
      newone 'size :=' e:size
      for (var Int i) 0 e:size-1
        newone:arguments i := addressof (e:i substitute id value)
    else
      newone :> new Expression
      newone position := e position
      newone module :> e module
      newone value := addressof entry_new:Ident ; (newone value) map Ident := cast "()" Ident
      newone 'size :=' e:size+1
      newone:arguments 0 := addressof (duplicate value)
      for (var Int i) 0 e:size-1
        e:arguments i+1 := addressof (e:i substitute id value)
  else
    for (var Int i) 0 e:size-1
      e:arguments i := addressof (e:i substitute id value)
    newone :> e


method e substitute id values
  arg_rw Expression e ; arg Str id ; arg ExpressionRange values
  if pliant_debugging_level>=2
    for (var Int i) 0 values:nb-1
      check values:expr:(values:base+i):is_linked error_id_unexpected "The substituted expressions must be linked to a module"
  var Int i := 0
  while i<e:size
    if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
      if values:nb>1
        e:arguments 'size :=' e:size+values:nb-1
        for (var Int j) e:size-values:nb i step -1
          e:arguments j+(values:nb-1) := e:arguments j
      eif values:nb=0
        for (var Int j) i e:size-2
          e:arguments j := e:arguments j+1
        e:arguments 'size :=' e:size-1
      for (var Int j) 0 values:nb-1
        e:arguments i+j := addressof (duplicate values:expr:(values:base+j))
      i := i+values:nb
    else
      e:i substitute id values
      i := i+1


method e insert id value
  arg_rw Expression e ; arg Str id ; arg Expression value
  check value:is_linked error_id_unexpected "The substituted expression must be linked to a module"
  var Int i := 0
  while i<e:size
    if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
      e:arguments 'size :=' e:size+1
      for (var Int j) e:size-2 i step -1
        e:arguments j+1 := e:arguments j
      e:arguments i := addressof duplicate:value
      i := i+2
    else
      e:i insert id value
      i := i+1

method e remove id
  arg_rw Expression e ; arg Str id
  var Int i := 0
  while i<e:size
    if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null
      for (var Int j) i e:size-2
        e:arguments j := e:arguments j+1
      e:arguments 'size :=' e:size-1
    else
      e:i remove id
      i := i+1


gvar Int counter := 0

method e auto_rename2 dict
  arg_rw Expression e ; arg_rw Dictionary dict
  if e:ident:len>0 and (e:ident e:ident:len-1 1)="_" and (addressof e:module)=null
    var Link:Ident id
    var Pointer:Arrow a :> dict first e:ident
    if a=null
      counter := counter+1
      id :> new Ident
      id := cast "pliant ident "+'convert to string':counter+"("+e:ident+")" Ident
      dict insert e:ident true addressof:id
    else
      id :> a map Ident
    e value := addressof:id
  for (var Int i) 0 e:size-1
    e:i auto_rename2 dict

method e auto_rename
  arg_rw Expression e
  var Dictionary dict
  e auto_rename2 dict


function new_expression -> e2
  arg_RW Expression e2
  e2 :> new Expression

method e set_constant_value type value
  arg_rw Expression e ; arg Type type ; arg Universal value
  e value := entry_new type
  type copy_instance addressof:value e:value

method e set_mapped_constant_value type value
  arg_rw Expression e ; arg Type type ; arg Universal value
  e value := addressof:value

method e add_subexpression sub
  arg_rw Expression e ; arg Expression sub
  var Int i := e size
  e 'size :=' i+1
  e:arguments i := addressof:sub

method e add_subexpressions range
  arg_rw Expression e ; arg ExpressionRange range
  var Int i := e size
  e 'size :=' i+range:nb
  for (var Int j) 0 range:nb-1
    e:arguments i+j := addressof (range:expr range:base+j)

meta expression e
  var CBool done := false
  var Link:Argument expr :> argument indirect Expression (argument local Address) 0
  var Int i := 0
  while i<e:size
    if e:i:ident="map" and i+1<e:size and (e:(i+1) cast Expression) and not done
      e suckup e:(i+1)
      expr :> e:(i+1) result
      done := true ; i := i+2 
    eif e:i:ident="duplicate" and i+1<e:size and (e:(i+1) cast Expression) and not done
      e suckup e:(i+1)
      e add (instruction (the_function duplicate Expression -> Expression) e:(i+1):result expr)
      done := true ; i := i+2 
    eif e:i:ident="immediat" and i+1<e:size and not done
      e add (instruction (the_function duplicate Expression -> Expression) (argument mapped_constant Expression (duplicate_near_nothing e:(i+1))) expr)
      done := true ; i := i+2 
    eif e:i:ident="constant" and i+1<e:size
      if not done
        e add (instruction (the_function new_expression -> Expression) expr)
        done := true
      e:(i+1) compile
      var Pointer:Type t :>e:(i+1):result:type:real_data_type
      if not (e:(i+1) cast t) return
      e suckup e:(i+1)
      e add (instruction (the_function '. set_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result)
      i := i+2
    eif e:i:ident="mapped_constant" and i+1<e:size
      if not done
        e add (instruction (the_function new_expression -> Expression) expr)
        done := true
      e:(i+1) compile
      var Pointer:Type t :>e:(i+1):result:type:real_data_type
      if not (e:(i+1) cast t) return
      e suckup e:(i+1)
      e add (instruction (the_function '. set_mapped_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result)
      i := i+2
    eif e:i:ident="ident" and i+1<e:size and (e:(i+1) cast Str)
      if not done
        e add (instruction (the_function new_expression -> Expression) expr)
        done := true
      e suckup e:(i+1)
      e add (instruction (the_function '. ident :=' Expression Str) expr e:(i+1):result)
      i := i+2
    eif e:i:ident="auto_rename" and done
      e add (instruction (the_function '. auto_rename' Expression) expr)
      i := i+1
    eif e:i:ident="near" and i+1<e:size and done and (e:(i+1) cast Expression)
      e suckup e:(i+1)
      e add (instruction (the_function '. near' Expression Expression) expr e:(i+1):result)
      i := i+2
    eif e:i:ident="subexpressions" and done
      if not done
        e add (instruction (the_function new_expression -> Expression) expr)
        done := true
      e add (instruction (the_function '. size :=' Expression Int) expr (argument constant Int 0))
      for (var Int j) i+1 e:size-1
        if (e:j cast Expression)
          e suckup e:j
          e add(instruction (the_function '. add_subexpression' Expression Expression) expr e:j:result)
        eif (e:j cast ExpressionRange)
          e suckup e:j
          e add(instruction (the_function '. add_subexpressions' Expression ExpressionRange) expr e:j:result)
        else
          return          
      i := e:size
    eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done
      e suckup e:(i+2)
      e add (instruction (the_function '. substitute' Expression Str Expression -> Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result expr)
      i := i+3
    eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast ExpressionRange) and done
      e suckup e:(i+2)
      e add (instruction (the_function '. substitute' Expression Str ExpressionRange) expr (argument constant Str e:(i+1):ident) e:(i+2):result)
      i := i+3
    eif e:i:ident="insert" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done
      e suckup e:(i+2)
      e add (instruction (the_function '. insert' Expression Str Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result)
      i := i+3
    eif e:i:ident="remove" and i+1<e:size and e:(i+1):ident<>"" and done
      e add (instruction (the_function '. remove' Expression Str) expr (argument constant Str e:(i+1):ident))
      i := i+2
    else
      return
  if done
    e set_result expr access_read+access_write


method e might_compile_as e2 -> success
  arg_rw Expression e e2 ; arg CBool success
  entry_lock addressof:e2
  e2 near e
  e2 compile_step3
  if e2:is_compiled
    if e:is_compiled
      error error_id_compile "ambiguous expression at "+e:position
    if e:instructions:first<>null
      error error_id_corrupted "Expression instructions list is not empty"
    e suckup e2
    e set_result e2:result e2:access
    success := true
  else
    success := false
  entry_unlock addressof:e2

method e compile_as e2 -> success
  arg_rw Expression e e2 ; arg CBool success
  entry_lock addressof:e2
  success := e might_compile_as e2
  if not:success and e2:error_message="" # patch by pom in release 54
    e2 compile 
  e suckup_error e2
  entry_unlock addressof:e2


meta named_expression e
  if e:size<>2 or not e:0:is_pure_ident
    return
  e compile_as (expression immediat (gvar Link:PackedExpression id :> expression immediat body) substitute id e:0 substitute body e:1)


method e add_nested_instructions open close
  arg_rw Expression e ; arg_rw Instruction open close
  var Link:Instruction escape :> null map Instruction
  var Pointer:Arrow a :> e:instructions first
  while a<>addressof:escape
    var Pointer:Instruction instr :> a map Instruction
    if (addressof instr:jump)=(cast -1 Address)
      if addressof:escape=null
        var Link:Instruction last :> instruction (the_function 'do nothing')
        e add (instruction (the_function 'jump anyway') jump last)
        escape :> duplicate close
        e add escape
        e add (instruction (the_function 'jump anyway') jump ((cast -1 Address) map Instruction))
        e add last
      instr jump :> escape
    a :> e:instructions next a
  open nested_with :> close
  e:instructions insert_before e:instructions:first addressof:open
  e add close


export duplicate
export '. ident :=' '. near'
export '. substitute' '. insert' '. remove' '. auto_rename'
export expression ''
export '. might_compile_as' '. compile_as'
export named_expression
export '. add_nested_instructions'

function copy_properties src dst
  arg_rw Expression src dst
  dst properties := src properties
  check src:size=dst:size
  for (var Int i) 0 src:size-1
    copy_properties src:i dst:i

function track_expression template ident expr e -> ok
  arg Expression template; arg Str ident; arg_rw Expression expr; arg_w Link:Expression e; arg CBool ok
  if template:ident=ident
    e :> expr
    return true
  else
    check template:size=expr:size
    for (var Int i) 0 template:size-1
      if (track_expression template:i ident expr:i e)
        return true
    return false
  
export copy_properties
export track_expression