/pliant/language/compiler/expression/expression2.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # Copyright (C) 1999  Patrice Ossona de Mendez  pom@ehess.fr 
 3  # 
 4  # This program is free software; you can redistribute it and/or 
 5  # modify it under the terms of the GNU General Public License version 2 
 6  # as published by the Free Software Foundation. 
 7  # 
 8  # This program is distributed in the hope that it will be useful, 
 9  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 10  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 11  # GNU General Public License for more details. 
 12  # 
 13  # You should have received a copy of the GNU General Public License 
 14  # version 2 along with this program; if not, write to the Free Software 
 15  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 16   
 17  scope "/pliant/language/" "/pliant/install/" 
 18  module "/pliant/install/ring2.pli" 
 19   
 20   
 21  method e packed_size -> s 
 22    arg Expression e ; arg Int s 
 23    if (entry_type e:value)=Ident and (e:value map Str):len<256 
 24      := Int:size+(e:value map Str):len 
 25    else 
 26      := Address size 
 27    := s+ListingPosition:size 
 28    := s+Int:size 
 29    for (var Int i) e:size-1 
 30      := s+(e:packed_size) 
 31   
 32  function pack e c 
 33    arg Expression e ; arg_rw Address c 
 34    if (entry_type e:value)=Ident and (e:value map Str):len<256 
 35      var Int := (e:value map Str) len 
 36      map Int := l ; := translate Int 1 
 37      memory_copy (e:value map Str):characters l ; := translate Byte l 
 38    else 
 39      map Address := value ; entry_lock e:value ; := translate Address 1 
 40    ListingPosition build_instance c 
 41    map ListingPosition := position ; := translate ListingPosition 1 
 42    map Int := size ; := translate Int 1 
 43    for (var Int i) e:size-1 
 44      pack e:c 
 45    
 46  function unpack c -> e 
 47    arg_rw Address c ; arg Link:Expression e 
 48    :> new Expression 
 49    if (map Int)>=and (map Int)<256 
 50      var Int := map Int ; := translate Int 1 
 51      (var Str s) set false 
 52      value := entry_new Ident 
 53      e:value map Str := s ; := translate Byte l 
 54    else 
 55      value := map Address ; := translate Address 1 
 56    position := map ListingPosition ; := translate ListingPosition 1 
 57    'size :=' (map Int) ; := translate Int 1 
 58    for (var Int i) e:size-1 
 59      e:arguments := addressof unpack: 
 60    
 61  function drop c 
 62    arg_rw Address c 
 63    if (map Int)>=and (map Int)<256 
 64      var Int := map Int ; := (translate Int 1) translate Byte l 
 65    else 
 66      entry_unlock (map Address) ; := translate Address 1 
 67    ListingPosition destroy_instance c ; := translate ListingPosition  
 68    := map Int ; := translate Int 1 
 69    for (var Int i) l-1 
 70      drop c 
 71    
 72  type PackedExpression 
 73    field Address buffer <- null 
 74   
 75  function destroy pe 
 76    arg_w PackedExpression pe 
 77    if pe:buffer<>null 
 78      var Address := pe buffer 
 79      drop c 
 80      memory_free pe:buffer 
 81   
 82  function 'cast (Link PackedExpression)' e -> pe 
 83    arg Expression e ; arg Link:PackedExpression pe 
 84    implicit 
 85    pe :> new PackedExpression 
 86    var Int ps := packed_size 
 87    pe buffer := memory_allocate ps addressof:pe 
 88    var Address := pe buffer ; pack c 
 89    check c=(pe:buffer translate Byte ps) 
 90   
 91  function 'cast (Link Expression)' pe -> e 
 92    arg PackedExpression pe ; arg Link:Expression e 
 93    implicit 
 94    check pe:buffer<>null 
 95    var Address := pe buffer 
 96    :> unpack c 
 97   
 98  export PackedExpression 'cast (Link PackedExpression)' 'cast (Link Expression)' 
 99   
 100   
 101  function duplicate e -> e2 
 102    arg Expression e ; arg_RW Expression e2   
 103    e2 :> new Expression 
 104    e2 module :> module 
 105    e2 position := position 
 106    e2 value := value 
 107    e2 'size :=' e:size 
 108    for (var Int i) e:size-1 
 109      e2:arguments := addressof (duplicate e:i) 
 110   
 111   
 112  method e 'ident :=' id 
 113    arg_rw Expression e ; arg Str id 
 114    value := entry_new Ident 
 115    e:value map Ident := cast id Ident 
 116   
 117   
 118  method e near original 
 119    arg_rw Expression e ; arg Expression original 
 120    if (addressof e:module)=null 
 121      module :> original module 
 122    if e:position="" 
 123      position := original position 
 124    for (var Int i) e:size-1 
 125      e:near original 
 126   
 127  method e near_nothing 
 128    arg_rw Expression e 
 129    module :> null map Module 
 130    position := var ListingPosition empty_position 
 131    for (var Int i) e:size-1 
 132      e:near_nothing 
 133   
 134  function duplicate_near_nothing e -> e2 
 135    arg Expression e ; arg_RW Expression e2   
 136    e2 :> duplicate e 
 137    e2 near_nothing 
 138   
 139   
 140  method e is_linked -> c 
 141    arg Expression e ; arg CBool c 
 142    for (var Int i) e:size-1 
 143      if not e:i:is_linked 
 144        return false 
 145    := (addressof e:module)<>null 
 146   
 147   
 148  type ExpressionRange 
 149    field Link:Expression expr 
 150    field Int base nb 
 151   
 152  method e '' base nb -> range 
 153    arg Expression e ; arg Int base nb ; arg ExpressionRange range 
 154    check base>=and nb>=and base+nb<=e:size 
 155    range expr :> e 
 156    range base := base 
 157    range nb := nb 
 158   
 159   
 160  method e substitute id value -> newone 
 161    arg_rw Expression e ; arg Str id ; arg Expression value ; arg_RW Expression newone 
 162    check value:is_linked error_id_unexpected "The substituted expression must be linked to a module" 
 163    if e:ident=id and (addressof e:module)=null 
 164      if e:size=0 
 165        newone :> duplicate:value 
 166      eif value:size=0 
 167        newone :> duplicate value 
 168        newone 'size :=' e:size 
 169        for (var Int i) e:size-1 
 170          newone:arguments := addressof (e:substitute id value) 
 171      else 
 172        newone :> new Expression 
 173        newone position := position 
 174        newone module :> module 
 175        newone value := addressof entry_new:Ident ; (newone value) map Ident := cast "()" Ident 
 176        newone 'size :=' e:size+1 
 177        newone:arguments := addressof (duplicate value) 
 178        for (var Int i) e:size-1 
 179          e:arguments i+:= addressof (e:substitute id value) 
 180    else 
 181      for (var Int i) e:size-1 
 182        e:arguments := addressof (e:substitute id value) 
 183      newone :> e 
 184   
 185   
 186  method e substitute id values 
 187    arg_rw Expression e ; arg Str id ; arg ExpressionRange values 
 188    if pliant_debugging_level>=2 
 189      for (var Int i) 0 values:nb-1 
 190        check values:expr:(values:base+i):is_linked error_id_unexpected "The substituted expressions must be linked to a module" 
 191    var Int := 0 
 192    while i<e:size 
 193      if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null 
 194        if values:nb>1 
 195          e:arguments 'size :=' e:size+values:nb-1 
 196          for (var Int j) e:size-values:nb step -1 
 197            e:arguments j+(values:nb-1) := e:arguments j 
 198        eif values:nb=0 
 199          for (var Int j) e:size-2 
 200            e:arguments := e:arguments j+1 
 201          e:arguments 'size :=' e:size-1 
 202        for (var Int j) values:nb-1 
 203          e:arguments i+:= addressof (duplicate values:expr:(values:base+j)) 
 204        := i+values:nb 
 205      else 
 206        e:substitute id values 
 207        := i+1 
 208   
 209   
 210  method e insert id value 
 211    arg_rw Expression e ; arg Str id ; arg Expression value 
 212    check value:is_linked error_id_unexpected "The substituted expression must be linked to a module" 
 213    var Int := 0 
 214    while i<e:size 
 215      if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null 
 216        e:arguments 'size :=' e:size+1 
 217        for (var Int j) e:size-step -1 
 218          e:arguments j+:= e:arguments j 
 219        e:arguments := addressof duplicate:value 
 220        := i+2 
 221      else 
 222        e:insert id value 
 223        := i+1 
 224   
 225  method e remove id 
 226    arg_rw Expression e ; arg Str id 
 227    var Int := 0 
 228    while i<e:size 
 229      if e:i:is_pure_ident and e:i:ident=id and (addressof e:i:module)=null 
 230        for (var Int j) e:size-2 
 231          e:arguments := e:arguments j+1 
 232        e:arguments 'size :=' e:size-1 
 233      else 
 234        e:remove id 
 235        := i+1 
 236   
 237   
 238  gvar Int counter := 0 
 239   
 240  method e auto_rename2 dict 
 241    arg_rw Expression e ; arg_rw Dictionary dict 
 242    if e:ident:len>and (e:ident e:ident:len-1 1)="_" and (addressof e:module)=null 
 243      var Link:Ident id 
 244      var Pointer:Arrow :> dict first e:ident 
 245      if a=null 
 246        counter := counter+1 
 247        id :> new Ident 
 248        id := cast "pliant ident "+'convert to string':counter+"("+e:ident+")" Ident 
 249        dict insert e:ident true addressof:id 
 250      else 
 251        id :> map Ident 
 252      value := addressof:id 
 253    for (var Int i) e:size-1 
 254      e:auto_rename2 dict 
 255   
 256  method e auto_rename 
 257    arg_rw Expression e 
 258    var Dictionary dict 
 259    auto_rename2 dict 
 260   
 261   
 262  function new_expression -> e2 
 263    arg_RW Expression e2 
 264    e2 :> new Expression 
 265   
 266  method e set_constant_value type value 
 267    arg_rw Expression e ; arg Type type ; arg Universal value 
 268    value := entry_new type 
 269    type copy_instance addressof:value e:value 
 270   
 271  method e set_mapped_constant_value type value 
 272    arg_rw Expression e ; arg Type type ; arg Universal value 
 273    value := addressof:value 
 274   
 275  method e add_subexpression sub 
 276    arg_rw Expression e ; arg Expression sub 
 277    var Int := size 
 278    'size :=' i+1 
 279    e:arguments := addressof sub 
 280   
 281  method e add_subexpressions range 
 282    arg_rw Expression e ; arg ExpressionRange range 
 283    var Int := size 
 284    'size :=' i+range:nb 
 285    for (var Int j) range:nb-1 
 286      e:arguments i+:= addressof (range:expr range:base+j) 
 287   
 288  meta expression e 
 289    var CBool done := false 
 290    var Link:Argument expr :> argument indirect Expression (argument local Address) 0 
 291    var Int := 0 
 292    while i<e:size 
 293      if e:i:ident="map" and i+1<e:size and (e:(i+1) cast Expression) and not done 
 294        suckup e:(i+1) 
 295        expr :> e:(i+1) result 
 296        done := true ; := i+ 
 297      eif e:i:ident="duplicate" and i+1<e:size and (e:(i+1) cast Expression) and not done 
 298        suckup e:(i+1) 
 299        add (instruction (the_function duplicate Expression -> Expression) e:(i+1):result expr) 
 300        done := true ; := i+ 
 301      eif e:i:ident="immediat" and i+1<e:size and not done 
 302        add (instruction (the_function duplicate Expression -> Expression) (argument mapped_constant Expression (duplicate_near_nothing e:(i+1))) expr) 
 303        done := true ; := i+ 
 304      eif e:i:ident="constant" and i+1<e:size 
 305        if not done 
 306          add (instruction (the_function new_expression -> Expression) expr) 
 307          done := true 
 308        e:(i+1) compile 
 309        var Pointer:Type :>e:(i+1):result:type:real_data_type 
 310        if not (e:(i+1) cast t) return 
 311        suckup e:(i+1) 
 312        add (instruction (the_function '. set_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result) 
 313        := i+2 
 314      eif e:i:ident="mapped_constant" and i+1<e:size 
 315        if not done 
 316          add (instruction (the_function new_expression -> Expression) expr) 
 317          done := true 
 318        e:(i+1) compile 
 319        var Pointer:Type :>e:(i+1):result:type:real_data_type 
 320        if not (e:(i+1) cast t) return 
 321        suckup e:(i+1) 
 322        add (instruction (the_function '. set_mapped_constant_value' Expression Type Universal) expr (argument mapped_constant Type t) e:(i+1):result) 
 323        := i+2 
 324      eif e:i:ident="ident" and i+1<e:size and (e:(i+1) cast Str) 
 325        if not done 
 326          add (instruction (the_function new_expression -> Expression) expr) 
 327          done := true 
 328        suckup e:(i+1) 
 329        add (instruction (the_function '. ident :=' Expression Str) expr e:(i+1):result) 
 330        := i+2 
 331      eif e:i:ident="auto_rename" and done 
 332        add (instruction (the_function '. auto_rename' Expression) expr) 
 333        := i+1 
 334      eif e:i:ident="near" and i+1<e:size and done and (e:(i+1) cast Expression) 
 335        suckup e:(i+1) 
 336        add (instruction (the_function '. near' Expression Expression) expr e:(i+1):result) 
 337        := i+2 
 338      eif e:i:ident="subexpressions" and done 
 339        if not done 
 340          add (instruction (the_function new_expression -> Expression) expr) 
 341          done := true 
 342        add (instruction (the_function '. size :=' Expression Int) expr (argument constant Int 0)) 
 343        for (var Int j) i+e:size-1 
 344          if (e:cast Expression) 
 345            suckup e:j 
 346            add(instruction (the_function '. add_subexpression' Expression Expression) expr e:j:result) 
 347          eif (e:cast ExpressionRange) 
 348            suckup e:j 
 349            add(instruction (the_function '. add_subexpressions' Expression ExpressionRange) expr e:j:result) 
 350          else 
 351            return           
 352        := e:size 
 353      eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done 
 354        suckup e:(i+2) 
 355        add (instruction (the_function '. substitute' Expression Str Expression -> Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result expr) 
 356        := i+3 
 357      eif e:i:ident="substitute" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast ExpressionRange) and done 
 358        suckup e:(i+2) 
 359        add (instruction (the_function '. substitute' Expression Str ExpressionRange) expr (argument constant Str e:(i+1):ident) e:(i+2):result) 
 360        := i+3 
 361      eif e:i:ident="insert" and i+2<e:size and e:(i+1):ident<>"" and (e:(i+2) cast Expression) and done 
 362        suckup e:(i+2) 
 363        add (instruction (the_function '. insert' Expression Str Expression) expr (argument constant Str e:(i+1):ident) e:(i+2):result) 
 364        := i+3 
 365      eif e:i:ident="remove" and i+1<e:size and e:(i+1):ident<>"" and done 
 366        add (instruction (the_function '. remove' Expression Str) expr (argument constant Str e:(i+1):ident)) 
 367        := i+2 
 368      else 
 369        return 
 370    if done 
 371      set_result expr access_read+access_write 
 372   
 373   
 374  method e might_compile_as e2 -> success 
 375    arg_rw Expression e2 ; arg CBool success 
 376    entry_lock addressof:e2 
 377    e2 near e 
 378    e2 compile_step3 
 379    if e2:is_compiled 
 380      if e:is_compiled 
 381        error error_id_compile "ambiguous expression at "+e:position 
 382      if e:instructions:first<>null 
 383        error error_id_corrupted "Expression instructions list is not empty" 
 384      suckup e2 
 385      set_result e2:result e2:access 
 386      success := true 
 387    else 
 388      success := false 
 389    entry_unlock addressof:e2 
 390   
 391  method e compile_as e2 -> success 
 392    arg_rw Expression e2 ; arg CBool success 
 393    entry_lock addressof:e2 
 394    success := might_compile_as e2 
 395    if not:success and e2:error_message="" # patch by pom in release 54 
 396      e2 compile  
 397    suckup_error e2 
 398    entry_unlock addressof:e2 
 399   
 400   
 401  meta named_expression e 
 402    if e:size<>or not e:0:is_pure_ident 
 403      return 
 404    compile_as (expression immediat (gvar Link:PackedExpression id :> expression immediat body) substitute id e:0 substitute body e:1) 
 405   
 406   
 407  method e add_nested_instructions open close 
 408    arg_rw Expression e ; arg_rw Instruction open close 
 409    var Link:Instruction escape :> null map Instruction 
 410    var Pointer:Arrow :> e:instructions first 
 411    while a<>addressof:escape 
 412      var Pointer:Instruction instr :> map Instruction 
 413      if (addressof instr:jump)=(cast -Address) 
 414        if addressof:escape=null 
 415          var Link:Instruction last :> instruction (the_function 'do nothing') 
 416          add (instruction (the_function 'jump anyway') jump last) 
 417          escape :> duplicate close 
 418          add escape 
 419          add (instruction (the_function 'jump anyway') jump ((cast -Address) map Instruction)) 
 420          add last 
 421        instr jump :> escape 
 422      :> e:instructions next a 
 423    open nested_with :> close 
 424    e:instructions insert_before e:instructions:first addressof:open 
 425    add close 
 426   
 427   
 428  export duplicate 
 429  export '. ident :=' '. near' 
 430  export '. substitute' '. insert' '. remove' '. auto_rename' 
 431  export expression '' 
 432  export '. might_compile_as' '. compile_as' 
 433  export named_expression 
 434  export '. add_nested_instructions' 
 435   
 436   
 437  function track_expression template ident expr e -> ok 
 438    arg Expression template; arg Str ident; arg_rw Expression expr; arg_w Link:Expression e; arg CBool ok 
 439    if template:ident=ident 
 440      :> expr 
 441      return true 
 442    else 
 443      check template:size=expr:size 
 444      for (var Int i) template:size-1 
 445        if (track_expression template:ident expr:e) 
 446          return true 
 447      return false 
 448     
 449  export track_expression