/pliant/language/type/number/int.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19   
 20  operator '.+.' 3*256+1*16 1 1 
 21  operator '.-.' 3*256+1*16 1 1 
 22  operator '.*.' 3*256+2*16 1 1 
 23  operator '.^.' 3*256+3*16 1 1 
 24   
 25   
 26 
 
 27   
 28   
 29  function abs i -> a 
 30    arg Int a 
 31    gcc_inline "$2 = ($1>=0 ? $1 : -$1);" 
 32    if i>=0 
 33      := i 
 34    else 
 35      := -i 
 36   
 37  export abs 
 38   
 39   
 40  type uInt 
 41    field Int value 
 42   
 43   
 44  function cast_uInt_Int i -> j 
 45    arg uInt i ; arg Int j 
 46    extension ; has_no_side_effect ; gcc_nocheck_inline "$2 = $1;" 
 47    check i:value>="The value is too large to fit in an Int" 
 48    := value 
 49  if pliant_debugging_level<2 
 50    (the_function cast_uInt_Int uInt -> Int) flags := '.or.' (the_function cast_uInt_Int uInt -> Int):flags function_flag_copy 
 51    (the_function cast_uInt_Int uInt -> Int) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly 
 52   
 53  function cast_Int_uInt i -> j 
 54    arg Int i ; arg uInt j 
 55    reduction ; has_no_side_effect ; gcc_nocheck_inline "$2 = $1;" 
 56    check i>="The integer is negative" 
 57    value := i 
 58  if pliant_debugging_level<2 
 59    (the_function cast_Int_uInt Int -> uInt) flags := '.or.' (the_function cast_Int_uInt Int -> uInt):flags function_flag_copy 
 60    (the_function cast_Int_uInt Int -> uInt) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly 
 61   
 62   
 63  function cast_uInt_Address i -> a 
 64    arg uInt i ; arg Address a 
 65    has_no_side_effect ; gcc_nocheck_inline "$2 = $1;" 
 66    check uInt:size=Address:size 
 67    memory_copy addressof:addressof:uInt:size 
 68  if pliant_debugging_level<2 
 69    (the_function cast_uInt_Address uInt -> Address) flags := (the_function cast_uInt_Address uInt -> Address):flags+function_flag_copy 
 70    (the_function cast_uInt_Address uInt -> Address) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly 
 71   
 72  function cast_Address_uInt a -> i 
 73    arg Address a ; arg uInt i 
 74    has_no_side_effect ; gcc_nocheck_inline "$2 = $1;" 
 75    check uInt:size=Address:size 
 76    memory_copy addressof:addressof:uInt:size 
 77  if pliant_debugging_level<2 
 78    (the_function cast_Address_uInt Address -> uInt) flags := (the_function cast_Address_uInt Address -> uInt):flags+function_flag_copy 
 79    (the_function cast_Address_uInt Address -> uInt) set_generate_assembly (the_function 'copy atomic' Int Int):generate_assembly 
 80   
 81   
 82  function compare_uInt i j -> c 
 83    arg uInt j ; arg Int c 
 84    gcc_inline "$3 = (unsigned int)$1<(unsigned int)$2 ? "+'convert to string':compare_inferior+" : (unsigned int)$1>(unsigned int)$2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";" 
 85    gcc_inline_compare "$3 = (unsigned int)$1 compare (unsigned int)$2;" 
 86    var Int ii := i:value+(-2)^(Int:bitsize-1) 
 87    var Int jj := j:value-(-2)^(Int:bitsize-1) 
 88    if ii=jj 
 89      := compare_equal 
 90    eif ii<jj 
 91      := compare_inferior 
 92    else 
 93      check ii>jj 
 94      := compare_superior 
 95   
 96  export uInt 
 97  alias 'cast Int' cast_uInt_Int in "/pliant/language/basic/ultrasafe.pli" 
 98  alias 'cast uInt' cast_Int_uInt in "/pliant/language/basic/ultrasafe.pli" 
 99  alias 'cast Address' cast_uInt_Address in "/pliant/language/basic/safe.pli" 
 100  alias 'cast uInt' cast_Address_uInt in "/pliant/language/basic/safe.pli" 
 101  alias compare compare_uInt in "/pliant/language/basic/safe.pli" 
 102   
 103   
 104 
 
 105   
 106   
 107  if processor_name="i386" 
 108   
 109    function arithmetic_overflow 
 110      has_no_side_effect 
 111      error error_id_arithmetic "Arithmetic overflow" 
 112   
 113    function generate_parameter_is_valid i f 
 114      arg_rw Instruction i ; arg_rw Function f 
 115    function parameter_is_valid -> p 
 116      arg Int p 
 117    (the_function parameter_is_valid -> Int) set_generate_binary (the_function generate_parameter_is_valid Instruction Function) 
 118   
 119    function i386_jump_if_not_overflow 
 120      void 
 121    function generate_jump_if_not_overflow i f 
 122      arg_rw Instruction i ; arg_rw Function f 
 123      code_immediat 8*4096+1*256+0*16+15 2 
 124      code_jump i:jump 
 125    (the_function i386_jump_if_not_overflow) set_generate_binary (the_function generate_jump_if_not_overflow Instruction Function) 
 126   
 127    function i386_jump_if_not_carry 
 128      void 
 129    function generate_jump_if_not_carry i f 
 130      arg_rw Instruction i ; arg_rw Function f 
 131      code_immediat 8*4096+3*256+0*16+15 2 
 132      code_jump i:jump 
 133    (the_function i386_jump_if_not_carry) set_generate_binary (the_function generate_jump_if_not_carry Instruction Function) 
 134   
 135    function generate_overflow_checkup cur gc checkup parameter -> cur2 
 136      arg Pointer:Instruction cur cur2 ; arg_rw GeneratorContext gc ; arg Int checkup ; arg_rw Argument parameter 
 137      check checkup>=and checkup<=# 0 = no checkup , 1 = Int checkup , 2 = uInt checkup 
 138      if pliant_debugging_level<or checkup=0 
 139        return cur 
 140      var Link:Instruction back :> instruction (the_function parameter_is_valid -> Int) parameter 
 141      if checkup=1 
 142        cur2 :> gc insert_after_instruction cur (instruction (the_function i386_jump_if_not_overflow) jump back) 
 143      else 
 144        cur2 :> gc insert_after_instruction cur (instruction (the_function i386_jump_if_not_carry) jump back) 
 145      cur2 :> gc insert_after_instruction cur2 (instruction (the_function arithmetic_overflow)) 
 146      cur2 :> gc insert_after_instruction cur2 back 
 147   
 148   
 149    function rename_function fun newname 
 150      arg_rw Function fun ; arg Str newname 
 151      pliant_general_dictionary insert2 newname true addressof:fun the_module:"/pliant/language/basic/safe.pli" 
 152      pliant_general_dictionary remove fun:name addressof:fun 
 153      fun name := newname 
 154   
 155    function assemble_simple i gc fun checkup 
 156      arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Function fun ; arg Int checkup 
 157      var Pointer:Instruction cur :> i 
 158      var Link:Argument :> argument a_register 
 159      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:r) 
 160      cur :> gc insert_after_instruction cur (instruction fun i:r) 
 161      cur :> generate_overflow_checkup cur gc checkup r 
 162      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:2) 
 163      gc remove i 
 164   
 165   
 166    rename_function (the_function '+' Int Int -> Int) ".+." 
 167   
 168    function '.+.' a b -> r 
 169      arg uInt r ; gcc_inline "$3 = $1 + $2;" 
 170    (the_function '.+.' uInt uInt -> uInt) set_generate_assembly (the_function '+' Int Int -> Int):generate_assembly 
 171   
 172    function plus a b -> r 
 173      arg Int r ; gcc_nocheck_inline "$3 = $1 + $2;" 
 174    function assemble_add_checkup_int i gc 
 175      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 176      assemble_simple gc (the_function i386_add Int Int) 1 
 177    (the_function plus Int Int -> Int) set_generate_assembly (the_function assemble_add_checkup_int Instruction GeneratorContext) 
 178    rename_function (the_function plus Int Int -> Int) "+" 
 179   
 180    function '+' a b -> r 
 181      arg uInt r ; gcc_nocheck_inline "$3 = $1 + $2;" 
 182    function assemble_add_checkup_uint i gc 
 183      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 184      assemble_simple gc (the_function i386_add Int Int) 2 
 185    (the_function '+' uInt uInt -> uInt) set_generate_assembly (the_function assemble_add_checkup_uint Instruction GeneratorContext) 
 186   
 187   
 188    rename_function (the_function '-' Int Int -> Int) ".-." 
 189   
 190    function '.-.' a b -> r 
 191      arg uInt r ; gcc_inline "$3 = $1 - $2;" 
 192    (the_function '.-.' uInt uInt -> uInt) set_generate_assembly (the_function '-' Int Int -> Int):generate_assembly 
 193   
 194    function minus a b -> r 
 195      arg Int r ; gcc_nocheck_inline "$3 = $1 - $2;" 
 196    function assemble_sub_checkup_int i gc 
 197      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 198      assemble_simple gc (the_function i386_sub Int Int) 1 
 199    (the_function minus Int Int -> Int) set_generate_assembly (the_function assemble_sub_checkup_int Instruction GeneratorContext) 
 200    rename_function (the_function minus Int Int -> Int) "-" 
 201   
 202    function '-' a b -> r 
 203      arg uInt r ; gcc_nocheck_inline "$3 = $1 - $2;" 
 204    function assemble_sub_checkup_uint i gc 
 205      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 206      assemble_simple gc (the_function i386_sub Int Int) 2 
 207    (the_function '-' uInt uInt -> uInt) set_generate_assembly (the_function assemble_sub_checkup_uint Instruction GeneratorContext) 
 208   
 209   
 210    function i386_imul x eax edx 
 211      arg Int x ; arg_rw Int eax ; arg_w Int edx 
 212    function generate_i386_imul i f 
 213      arg_rw Instruction i ; arg_rw Function f 
 214      check i:1:where=argument_register and i:1:register=i386_eax 
 215      check i:2:where=argument_register and i:2:register=i386_edx 
 216      i386_regmem 15*16+7 1 5 i:0 
 217    (the_function i386_imul Int Int Int) set_generate_binary (the_function generate_i386_imul Instruction Function) 
 218    ((the_function i386_imul Int Int Int) arg 1) access := access_read+access_write+access_byvalue 
 219    ((the_function i386_imul Int Int Int) arg 2) access := access_write+access_byvalue 
 220   
 221    function i386_mul x eax edx 
 222      arg Int x ; arg_rw Int eax ; arg_w Int edx 
 223    function generate_i386_mul i f 
 224      arg_rw Instruction i ; arg_rw Function f 
 225      check i:1:where=argument_register and i:1:register=i386_eax 
 226      check i:2:where=argument_register and i:2:register=i386_edx 
 227      i386_regmem 15*16+7 1 4 i:0 
 228    (the_function i386_mul Int Int Int) set_generate_binary (the_function generate_i386_mul Instruction Function) 
 229    ((the_function i386_mul Int Int Int) arg 1) access := access_read+access_write+access_byvalue 
 230    ((the_function i386_mul Int Int Int) arg 2) access := access_write+access_byvalue 
 231   
 232    function assemble_mul i gc checkup imul_mul 
 233      arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Int checkup imul_mul 
 234      var Pointer:Instruction cur :> i 
 235      var Pointer:Argument eax :> gc register i386_eax 
 236      var Pointer:Argument edx :> gc register i386_edx 
 237      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:eax) 
 238      if imul_mul=1 
 239        cur :> gc insert_after_instruction cur (instruction (the_function i386_imul Int Int Int) i:eax edx) 
 240      else 
 241        cur :> gc insert_after_instruction cur (instruction (the_function i386_mul Int Int Int) i:eax edx) 
 242      cur :> generate_overflow_checkup cur gc checkup eax 
 243      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) eax i:2) 
 244      gc remove i 
 245   
 246   
 247    rename_function (the_function '*' Int Int -> Int) ".*." 
 248   
 249    function '.*.' a b -> r 
 250      arg uInt r; gcc_inline "$3 = (unsigned int)$1 * (unsigned int)$2;" 
 251    function assemble_mul_nocheckup_uint i gc 
 252      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 253      assemble_mul gc 0 2 
 254    (the_function '.*.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mul_nocheckup_uint Instruction GeneratorContext) 
 255   
 256    function multiply a b -> r 
 257      arg Int r ; gcc_nocheck_inline "$3 = $1 * $2;" 
 258    function assemble_mul_checkup_int i gc 
 259      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 260      assemble_mul gc 1 1 
 261    (the_function multiply Int Int -> Int) set_generate_assembly (the_function assemble_mul_checkup_int Instruction GeneratorContext) 
 262    rename_function (the_function multiply Int Int -> Int) "*" 
 263   
 264    function '*' a b -> r 
 265      arg uInt r; gcc_nocheck_inline "$3 = (unsigned int)$1 * (unsigned int)$2;" 
 266    function assemble_mul_checkup_uint i gc 
 267      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 268      assemble_mul gc 2 2 
 269    (the_function '*' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mul_checkup_uint Instruction GeneratorContext) 
 270   
 271   
 272    function i386_cdq eax edx 
 273      arg Int eax ; arg_w Int edx 
 274    function generate_i386_cdq i f 
 275      arg_rw Instruction i ; arg_rw Function f 
 276      check i:0:where=argument_register and i:0:register=i386_eax 
 277      check i:1:where=argument_register and i:1:register=i386_edx 
 278      code_immediat 9*16+9 1 
 279    (the_function i386_cdq Int Int) set_generate_binary (the_function generate_i386_cdq Instruction Function) 
 280    ((the_function i386_cdq Int Int) arg 1) access := access_write+access_byvalue 
 281   
 282    function i386_idiv eax edx x 
 283      arg_rw Int eax edx ; arg Int x 
 284    function generate_i386_idiv i f 
 285      arg_rw Instruction i ; arg_rw Function f 
 286      check i:0:where=argument_register and i:0:register=i386_eax 
 287      check i:1:where=argument_register and i:1:register=i386_edx 
 288      i386_regmem 15*16+7 1 7 i:2 
 289    (the_function i386_idiv Int Int Int) set_generate_binary (the_function generate_i386_idiv Instruction Function) 
 290    ((the_function i386_idiv Int Int Int) arg 0) access := access_read+access_write+access_byvalue 
 291    ((the_function i386_idiv Int Int Int) arg 1) access := access_read+access_write+access_byvalue 
 292   
 293    function i386_div eax edx x 
 294      arg_rw Int eax edx ; arg Int x 
 295    function generate_i386_div i f 
 296      arg_rw Instruction i ; arg_rw Function f 
 297      check i:0:where=argument_register and i:0:register=i386_eax 
 298      check i:1:where=argument_register and i:1:register=i386_edx 
 299      i386_regmem 15*16+7 1 6 i:2 
 300    (the_function i386_div Int Int Int) set_generate_binary (the_function generate_i386_div Instruction Function) 
 301    ((the_function i386_div Int Int Int) arg 0) access := access_read+access_write+access_byvalue 
 302    ((the_function i386_div Int Int Int) arg 1) access := access_read+access_write+access_byvalue 
 303   
 304   
 305    function assemble_divide i gc signed reg 
 306      arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg CBool signed ; arg Int reg 
 307      var Pointer:Instruction cur :> i 
 308      var Link:Argument eax :> gc register i386_eax 
 309      var Link:Argument edx :> gc register i386_edx 
 310      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:eax) 
 311      if signed 
 312        cur :> gc insert_after_instruction cur (instruction (the_function i386_cdq Int Int) eax edx) 
 313        cur :> gc insert_after_instruction cur (instruction (the_function i386_idiv Int Int Int) eax edx i:1) 
 314      else 
 315        cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (argument constant Int 0) edx) 
 316        cur :> gc insert_after_instruction cur (instruction (the_function i386_div Int Int Int) eax edx i:1) 
 317      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register reg) i:2) 
 318      gc remove i 
 319   
 320    function assemble_idiv i gc 
 321      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 322      assemble_divide gc true i386_eax 
 323    (the_function '\' Int Int -> Int) set_generate_assembly (the_function assemble_idiv Instruction GeneratorContext) 
 324   
 325    function '\' a b -> r 
 326      arg uInt r ; gcc_inline "$3 = (unsigned int)$1 / (unsigned int)$2;" 
 327    function assemble_div i gc 
 328      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 329      assemble_divide gc false i386_eax 
 330    (the_function '\' uInt uInt -> uInt) set_generate_assembly (the_function assemble_div Instruction GeneratorContext) 
 331   
 332    function assemble_imod i gc 
 333      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 334      assemble_divide gc true i386_edx 
 335    (the_function '%' Int Int -> Int) set_generate_assembly (the_function assemble_imod Instruction GeneratorContext) 
 336   
 337    function '%' a b -> r 
 338      arg uInt r ; gcc_inline "$3 = (unsigned int)$1 % (unsigned int)$2;" 
 339    function assemble_mod i gc 
 340      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 341      assemble_divide gc false i386_edx 
 342    (the_function '%' uInt uInt -> uInt) set_generate_assembly (the_function assemble_mod Instruction GeneratorContext) 
 343   
 344   
 345  meta '-' e 
 346    strong_definition 
 347    if e:size<>2 
 348      return 
 349    var Pointer:uInt :> (e:constant uInt) map uInt 
 350    if addressof:a=null 
 351      return 
 352    var Pointer:uInt :> (e:constant uInt) map uInt 
 353    if addressof:b=null 
 354      return 
 355    if b>a 
 356      set_result (argument constant Int (cast Int)-(cast Int)) access_read 
 357   
 358   
 359  export '+' '-' '*' '\' '%' 
 360  export '.+.' '.-.' '.*.' 
 361   
 362   
 363 
 
 364   
 365  module "/pliant/language/type/text/char.pli" 
 366   
 367   
 368  function parse_bin context line parameter 
 369    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 370    var uInt value := 0 
 371    for (var Int i) line:len-1 
 372      var Char := line i 
 373      if c="0" or c="1" 
 374        var uInt value2 := value .*. (cast uInt) .+. (cast c:number-"0":0:number uInt) 
 375        if value2\(cast uInt)<>value 
 376          return 
 377        value := value2 
 378      eif c="b" and i<>0 
 379        if i+1<line:len and (line i+1):isidentcharacter 
 380          return 
 381        var Link:uInt :> new uInt 
 382        := value 
 383        context add_token addressof:t 
 384        context forward i+1 
 385        return 
 386      else 
 387        return 
 388   
 389  gvar ParserFilter bin_filter 
 390  bin_filter function :> the_function parse_bin ParserContext Str Address 
 391  constant 'pliant parser basic types' bin_filter 
 392  export 'pliant parser basic types' 
 393   
 394   
 395  function parse_dec context line parameter 
 396    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 397    var uInt value := 0 
 398    var Int := 0 
 399    while i<line:len and line:i:number>="0":0:number and line:i:number<="9":0:number 
 400      var uInt value2 := value .*. (cast 10 uInt) .+. (cast line:i:number-"0":0:number uInt) 
 401      if value2\(cast 10 uInt)<>value 
 402        return 
 403      := i+1 
 404      value := value2 
 405    if i=or (i<line:len and line:i:isidentcharacter) 
 406      return 
 407    var Link:uInt :> new uInt 
 408    := value 
 409    context add_token addressof:t 
 410    context forward i 
 411   
 412  gvar ParserFilter dec_filter 
 413  dec_filter function :> the_function parse_dec ParserContext Str Address 
 414  constant 'pliant parser basic types' dec_filter 
 415  export 'pliant parser basic types' 
 416   
 417   
 418  function parse_hex context line parameter 
 419    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 420    var uInt value :=  
 421    for (var Int i) line:len-1 
 422      var Char := line i 
 423      var uInt value2 
 424      if c:number>="0":0:number and c:number<="9":0:number 
 425        value2 := value .*. (cast 16 uInt) .+. (cast c:number-"0":0:number uInt) 
 426        if value2\(cast 16 uInt)<>value 
 427          return 
 428        value := value2 
 429      eif c:number>="A":0:number and c:number<="F":0:number 
 430        value2 := value .*. (cast 16 uInt) .+. (cast 10+c:number-"A":0:number uInt) 
 431        if value2\(cast 16 uInt)<>value 
 432          return 
 433        value := value2 
 434      eif c="h" and i<>0 
 435        if i+1<line:len and (line i+1):isidentcharacter 
 436          return 
 437        var Link:uInt :> new uInt 
 438        := value 
 439        context add_token addressof:t 
 440        context forward i+1 
 441        return 
 442      else 
 443        return 
 444   
 445  gvar ParserFilter hex_filter 
 446  hex_filter function :> the_function parse_hex ParserContext Str Address 
 447  constant 'pliant parser basic types' hex_filter 
 448  export 'pliant parser basic types' 
 449   
 450   
 451 
 
 452   
 453   
 454  if processor_name="i386" 
 455   
 456    function i386_or a b 
 457      arg Int a ; arg_rw Int b 
 458   
 459    function generate_i386_or i f 
 460      arg_rw Instruction i ; arg_rw Function f 
 461      if i:0:where=argument_register 
 462        i386_regmem 00001001b 1 i:0:register i:1 
 463      eif i:1:where=argument_register 
 464        i386_regmem 00001011b 1 i:1:register i:0 
 465      else 
 466        error error_id_unexpected "i386 code generation: Invalid or arguments" 
 467   
 468    (the_function i386_or Int Int) set_generate_binary (the_function generate_i386_or Instruction Function) 
 469    ((the_function i386_or Int Int) arg 1) access := access_read+access_write+access_byvalue 
 470   
 471    function '.or.' a b -> r 
 472      arg uInt r 
 473      gcc_inline "$3 = $1 | $2;" 
 474   
 475    function assemble_bit_or i gc 
 476      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 477      var Pointer:Instruction cur :> i 
 478      var Link:Argument reg :> argument a_register 
 479      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:reg) 
 480      cur :> gc insert_after_instruction cur (instruction (the_function i386_or Int Int) i:reg) 
 481      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2) 
 482      gc remove i 
 483   
 484    (the_function '.or.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_or Instruction GeneratorContext) 
 485    (the_function '.or.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_or Instruction GeneratorContext) 
 486   
 487    operator '.or.' 290h 1 1 
 488    export '.or.' 
 489   
 490   
 491    function i386_and a b 
 492      arg Int a ; arg_rw Int b 
 493   
 494    function generate_i386_and i f 
 495      arg_rw Instruction i ; arg_rw Function f 
 496      if i:0:where=argument_register 
 497        i386_regmem 00100001b 1 i:0:register i:1 
 498      eif i:1:where=argument_register 
 499        i386_regmem 00100011b 1 i:1:register i:0 
 500      else 
 501        error error_id_unexpected "i386 code generation: Invalid and arguments" 
 502   
 503    (the_function i386_and Int Int) set_generate_binary (the_function generate_i386_and Instruction Function) 
 504    ((the_function i386_and Int Int) arg 1) access := access_read+access_write+access_byvalue 
 505   
 506    function '.and.' a b -> r 
 507      arg uInt r 
 508      gcc_inline "$3 = $1 & $2;" 
 509   
 510    function assemble_bit_and i gc 
 511      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 512      var Pointer:Instruction cur :> i 
 513      var Link:Argument reg :> argument a_register 
 514      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:reg) 
 515      cur :> gc insert_after_instruction cur (instruction (the_function i386_and Int Int) i:reg) 
 516      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2) 
 517      gc remove i 
 518   
 519    (the_function '.and.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_and Instruction GeneratorContext) 
 520    (the_function '.and.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_and Instruction GeneratorContext) 
 521   
 522    operator '.and.' 290h 1 1 
 523    export '.and.' 
 524   
 525   
 526    function i386_xor a b 
 527      arg Int a ; arg_rw Int b 
 528   
 529    function generate_i386_xor i f 
 530      arg_rw Instruction i ; arg_rw Function f 
 531      if i:0:where=argument_register 
 532        i386_regmem 00110001b 1 i:0:register i:1 
 533      eif i:1:where=argument_register 
 534        i386_regmem 00110011b 1 i:1:register i:0 
 535      else 
 536        error error_id_unexpected "i386 code generation: Invalid and arguments" 
 537   
 538    (the_function i386_xor Int Int) set_generate_binary (the_function generate_i386_xor Instruction Function) 
 539    ((the_function i386_xor Int Int) arg 1) access := access_read+access_write+access_byvalue 
 540   
 541    function '.xor.' a b -> r 
 542      arg Int r 
 543      gcc_inline "$3 = $1 ^ $2;" 
 544   
 545    function '.xor.' a b -> r 
 546      arg uInt r 
 547      gcc_inline "$3 = $1 ^ $2;" 
 548   
 549    function assemble_bit_xor i gc 
 550      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 551      var Pointer:Instruction cur :> i 
 552      var Link:Argument reg :> argument a_register 
 553      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:reg) 
 554      cur :> gc insert_after_instruction cur (instruction (the_function i386_xor Int Int) i:reg) 
 555      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:2) 
 556      gc remove i 
 557   
 558    (the_function '.xor.' Int Int -> Int) set_generate_assembly (the_function assemble_bit_xor Instruction GeneratorContext) 
 559    (the_function '.xor.' uInt uInt -> uInt) set_generate_assembly (the_function assemble_bit_xor Instruction GeneratorContext) 
 560   
 561    operator '.xor.' 290h 1 1 
 562    export '.xor.' 
 563   
 564   
 565    function i386_not a 
 566      arg_rw Int a 
 567   
 568    function generate_i386_not i f 
 569      arg_rw Instruction i ; arg_rw Function f 
 570      i386_regmem 11110111b 1 010b i:0 
 571   
 572    (the_function i386_not Int) set_generate_binary (the_function generate_i386_not Instruction Function) 
 573    ((the_function i386_not Int) arg 0) access := access_read+access_write+access_byvalue 
 574   
 575   
 576    function '.not.' a -> r 
 577      arg uInt r 
 578      gcc_inline "$2 = ~ $1;" 
 579   
 580    function assemble_bit_not i gc 
 581      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 582      var Pointer:Instruction cur :> i 
 583      var Link:Argument reg :> argument a_register 
 584      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:reg) 
 585      cur :> gc insert_after_instruction cur (instruction (the_function i386_not Int) reg) 
 586      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) reg i:1) 
 587      gc remove i 
 588   
 589    (the_function '.not.' Int -> Int) set_generate_assembly (the_function assemble_bit_not Instruction GeneratorContext) 
 590    (the_function '.not.' uInt -> uInt) set_generate_assembly (the_function assemble_bit_not Instruction GeneratorContext) 
 591   
 592    operator '.not.' 2A0h 0 1 
 593    export '.not.' 
 594   
 595   
 596  function '.andnot.' a b -> r 
 597    arg Int r 
 598    := .and. .not. b 
 599   
 600  function '.andnot.' a b -> r 
 601    arg uInt r 
 602    := .and. .not. b 
 603   
 604  operator '.andnot.' 260h 1 1 
 605  export '.andnot.' 
 606   
 607   
 608 
 
 609   
 610   
 611  rename_function (the_function '^' Int Int -> Int) ".^." 
 612   
 613  function '^' a b -> r 
 614    arg Int r 
 615    check b>="^ second argument must be positive" 
 616    := 1 ; var Int := a ; var Int := b 
 617    while true 
 618      if (.and. 1)=1 
 619        := r*p 
 620      if e<2 
 621        return 
 622      := p*p 
 623      := e\2 
 624   
 625  function '.^.' a b -> r 
 626    arg uInt r ; arg Int b 
 627    check b>="^ second argument must be positive" 
 628    := 1 ; var uInt := a ; var Int := b 
 629    while true 
 630      if (.and. 1)=1 
 631        := .*. p 
 632      if e<2 
 633        return 
 634      := .*. p 
 635      := e\2 
 636   
 637  function '^' a b -> r 
 638    arg uInt r ; arg Int b 
 639    check b>="^ second argument must be positive" 
 640    := 1 ; var uInt := a ; var Int := b 
 641    while true 
 642      if (.and. 1)=1 
 643        := r*p 
 644      if e<2 
 645        return 
 646      := p*p 
 647      := e\2 
 648   
 649  export '^' '.^.' 
 650   
 651   
 652 
 
 653   
 654   
 655  function min a b -> m 
 656    arg Int m 
 657    gcc_inline "$3 = ($1 <= $2 ? $1 : $2);" 
 658    if a<=b 
 659      return a 
 660    else 
 661      return b 
 662   
 663   
 664  function max a b -> m 
 665    arg Int m 
 666    gcc_inline "$3 = ($1 >= $2 ? $1 : $2);" 
 667    if a>=b 
 668      return a 
 669    else 
 670      return b 
 671   
 672   
 673  export min max 
 674   
 675   
 676 
 
 677   
 678   
 679  function 'cast Status' i -> s 
 680    arg Int i ; arg Status s 
 681    explicit 
 682    if i=(-2)^(Int:bitsize-1) 
 683      := undefined 
 684    else 
 685      := defined 
 686   
 687  function 'cast Int' s -> i 
 688    arg Status s ; arg Int i 
 689    extension 
 690    if pliant_debugging_level>=2 
 691      if s<>undefined 
 692        error error_id_unexpected "Unexpected Status value" 
 693    := (-2)^(Int:bitsize-1) 
 694   
 695   
 696 
 
 697   
 698   
 699  doc 
 700    [These functions have been removed because you should use 'parse' or 'eparse' instead] 
 701   
 702   
 703  # function 'cast Int' s -> i 
 704  #   arg Str s ; arg Int i 
 705  #   i := 0 ; var CBool some := false 
 706  #   var Int start := 0 
 707  #   if s:len>0 and s:0="-" 
 708  #     start := 1 
 709  #   for (var Int u) start s:len-1 
 710  #     if s:u:number>="0":0:number and s:u:number<="9":0:number 
 711  #       i := 10*i + (s:u:number - "0":0:number) ; some := true 
 712  #     else 
 713  #       return undefined 
 714  #   if not some 
 715  #     return undefined 
 716  #   if start=1 
 717  #     i := -i 
 718   
 719   
 720  # function 'cast uInt' s -> ui 
 721  #   arg Str s ; arg uInt ui 
 722  #   ui := 0 ; var CBool some := false 
 723  #   for (var Int u) 0 s:len-1 
 724  #     if s:u:number>="0":0:number and s:u:number<="9":0:number 
 725  #       ui := 10*ui + (cast s:u:number - "0":0:number uInt) ; some := true 
 726  #     else 
 727  #       return 0 
 728  #   if not some 
 729  #     return 0 
 730   
 731   
 732 
 
 733   
 734   
 735  method data 'to string' options -> s 
 736    arg uInt data ; arg Str options s 
 737    if data<2^(uInt:bitsize-1) 
 738      := 'convert to string' (cast data Int) 
 739    else 
 740      := ('convert to string' data\10)+('convert to string' data%10) 
 741    # this method is redefined in int_extra.pli 
 742   
 743  method data 'from string' string options may_skip skiped offset -> status 
 744    arg_w uInt data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 745    var Int stop := string:len-1 
 746    if not may_skip and stop<>(-1) 
 747      stop := 0 
 748    for (var Int i) stop 
 749      var Int c0 := string:number 
 750      if c0>="0":0:number and c0<="9":0:number 
 751        skiped := i 
 752        data := 0 
 753        while i<string:len and { var Int := string:number ; c>="0":0:number and c<="9":0:number } 
 754          var uInt data2 := 10*data + ("0":0:number) 
 755          if data2\(cast 10 uInt)<>data 
 756            data := 0 
 757            return failure 
 758          data := data2 
 759          := i+1 
 760        offset := i 
 761        return success 
 762    data := 0 
 763    status := failure 
 764   
 765  method data 'to string' options -> s 
 766    arg Int data ; arg Str options ; arg Str s 
 767    := 'convert to string' data 
 768    # this method is redefined in int_extra.pli 
 769   
 770  method data 'from string' string options may_skip skiped offset -> status 
 771    arg_w Int data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 772    var Int stop := string:len-1 
 773    if not may_skip and stop<>(-1) 
 774      stop := 0 
 775    for (var Int i) stop 
 776      var Int c0 := string:number 
 777      if c0>="0":0:number and c0<="9":0:number 
 778        skiped := i 
 779        data := 0 
 780        while i<string:len and { var Int := string:number ; c>="0":0:number and c<="9":0:number } 
 781          var Int data2 := 10*data + ("0":0:number) 
 782          if data2\(cast 10 Int)<>data 
 783            data := undefined 
 784            return failure 
 785          data := data2 
 786          := i+1 
 787        offset := i 
 788        return success 
 789      eif c0="-":0:number and i+1<>string:len and string:(i+1):number>="0":0:number and string:(i+1):number<="9":0:number 
 790        skiped := i 
 791        := i+1 
 792        data := 0 
 793        while i<string:len and { var Int := string:number ; c>="0":0:number and c<="9":0:number } 
 794          var Int data2 := 10*data + ("0":0:number) 
 795          if data2\(cast 10 Int)<>data 
 796            data := undefined 
 797            return failure 
 798          data := data2 
 799          := i+1 
 800        data := -data 
 801        offset := i 
 802        return success 
 803      eif c0="?":0:number 
 804        data := undefined 
 805        skiped := i 
 806        offset := i+1 
 807        return success 
 808    data := undefined 
 809    if string="" and (options="db" or options="raw") 
 810      status := success 
 811    else 
 812      status := failure 
 813   
 814   
 815  export 'cast Status' 'cast Int' 
 816   
 817   
 818 
 
 819   
 820   
 821  if processor_name="i386" 
 822   
 823    function assemble_shift i gc fun 
 824      arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg Function fun 
 825      var Pointer:Instruction cur :> i 
 826      var Link:Argument :> argument a_register 
 827      var Link:Argument ecx :> gc register i386_ecx 
 828      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:r) 
 829      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:ecx) 
 830      cur :> gc insert_after_instruction cur (instruction fun ecx) 
 831      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) i:2) 
 832      gc remove i 
 833   
 834   
 835    function i386_shl i ecx 
 836      arg Int ecx 
 837    function i386_shl_generate_binary instr function 
 838      arg Instruction instr ; arg_rw Function function 
 839      check instr:1:where=argument_register and instr:1:register=i386_ecx 
 840      i386_regmem function 0D3h 1 4h instr:0 
 841    (the_function i386_shl Int Int) set_generate_binary (the_function i386_shl_generate_binary Instruction Function)  
 842    ((the_function i386_shl Int Int) arg 0) access := access_read+access_write+access_byvalue 
 843           
 844    function shift_left a n -> r 
 845      arg Int r ; gcc_nocheck_inline "$3 = $1 << $2;" 
 846    function assemble_shift_left i gc 
 847      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 848      assemble_shift gc (the_function i386_shl Int Int) 
 849    (the_function shift_left Int Int -> Int) set_generate_assembly (the_function assemble_shift_left Instruction GeneratorContext)  
 850   
 851    
 852    function i386_sar i ecx 
 853      arg Int ecx 
 854    function i386_sar_generate_binary instr function 
 855      arg Instruction instr ; arg_rw Function function 
 856      check instr:1:where=argument_register and instr:1:register=i386_ecx 
 857      i386_regmem function 0D3h 1 7h instr:0 
 858    (the_function i386_sar Int Int) set_generate_binary (the_function i386_sar_generate_binary Instruction Function)  
 859    ((the_function i386_sar Int Int) arg 0) access := access_read+access_write+access_byvalue 
 860           
 861    function shift_right a n -> r 
 862      arg Int r ; gcc_nocheck_inline "$3 = $1 >> $2;" 
 863    function assemble_shift_right2 i gc 
 864      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 865      assemble_shift gc (the_function i386_sar Int Int) 
 866    (the_function shift_right Int Int -> Int) set_generate_assembly (the_function assemble_shift_right2 Instruction GeneratorContext)  
 867   
 868   
 869    function i386_shr i ecx 
 870      arg Int ecx 
 871    function i386_shr_generate_binary instr function 
 872      arg Instruction instr ; arg_rw Function function 
 873      check instr:1:where=argument_register and instr:1:register=i386_ecx 
 874      i386_regmem function 0D3h 1 5h instr:0 
 875    (the_function i386_shr Int Int) set_generate_binary (the_function i386_shr_generate_binary Instruction Function)  
 876    ((the_function i386_shr Int Int) arg 0) access := access_read+access_write+access_byvalue 
 877           
 878    function shift_right a n -> r 
 879      arg uInt r ; arg Int n ; gcc_nocheck_inline "$3 = (unsigned int)$1 >> $2;" 
 880    function assemble_shift_right1 i gc 
 881      arg_rw Instruction i ; arg_rw GeneratorContext gc 
 882      assemble_shift gc (the_function i386_shr Int Int) 
 883    (the_function shift_right uInt Int -> uInt) set_generate_assembly (the_function assemble_shift_right1 Instruction GeneratorContext)  
 884   
 885   
 886  function optimize_add gc 
 887    arg_rw GeneratorContext gc 
 888    var Link:Instruction :> gc first_instruction 
 889    while addressof:i<>null 
 890      var Link:Instruction i2 :> null map Instruction 
 891      var Pointer:Function :> function 
 892      if pliant_debugging_level<2 
 893        if f=(the_function '+' Int Int -> Int) 
 894          function :> the_function '.+.' Int Int -> Int 
 895        if f=(the_function '+' uInt uInt -> uInt) 
 896          function :> the_function '.+.' uInt uInt -> uInt 
 897        if f=(the_function '-' Int Int -> Int) 
 898          function :> the_function '.-.' Int Int -> Int 
 899        if f=(the_function '-' uInt uInt -> uInt) 
 900          function :> the_function '.-.' uInt uInt -> uInt 
 901        :> function 
 902      if f=(the_function '.+.' Int Int -> Int) or f=(the_function '.+.' uInt uInt -> uInt) or f=(the_function '.-.' Int Int -> Int) or f=(the_function '.-.' uInt uInt -> uInt) 
 903        for (var Int p) 0 1 
 904          if i:p:where=argument_constant 
 905            var uInt cst := i:p:constant map uInt 
 906            if cst=0 
 907              if f=(the_function '.+.' Int Int -> Int) or f=(the_function '.+.' uInt uInt -> uInt) 
 908                i2 :> instruction (the_function 'copy atomic' Int Int) i:(1-p) i:2 
 909              if f=(the_function '.-.' Int Int -> Int) or f=(the_function '.-.' uInt uInt -> uInt) 
 910                if p=1 
 911                  i2 :> instruction (the_function 'copy atomic' Int Int) i:i:2 
 912      if addressof:i2<>null 
 913        gc insert_after_instruction i2 
 914        gc remove i 
 915        :> i2 
 916      :> next_instruction 
 917   
 918  function optimize_shift i gc -> i2 
 919    arg_rw Instruction i ; arg_rw GeneratorContext gc ; arg_C Instruction i2 
 920    i2 :> null map Instruction 
 921    var Pointer:Function :> function 
 922    if f=(the_function '^' uInt Int -> uInt) 
 923      if i:0:where=argument_constant and (i:0:constant map uInt)=2 
 924        return (instruction (the_function shift_left Int Int -> Int) (argument constant uInt 1) i:i:2) 
 925    if pliant_debugging_level<2 
 926      if f=(the_function '*' Int Int -> Int) 
 927        function :> the_function '.*.' Int Int -> Int 
 928      if f=(the_function '*' uInt uInt -> uInt) 
 929        function :> the_function '.*.' uInt uInt -> uInt 
 930      :> function 
 931    if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) or f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt) or f=(the_function '%' uInt uInt -> uInt) 
 932      for (var Int p) 0 1 
 933        if i:p:where=argument_constant 
 934          var uInt cst := i:p:constant map uInt 
 935          if cst=1 
 936            if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) 
 937              return (instruction (the_function 'copy atomic' Int Int) i:(1-p) i:2) 
 938            if f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt) 
 939              if p=1 
 940                return (instruction (the_function 'copy atomic' Int Int) i:0  i:2) 
 941          for (var Int b) 0 Int:bitsize-2 
 942            if cst=2^b 
 943              if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) 
 944                return (instruction (the_function shift_left Int Int -> Int) i:(1-p) (argument constant Int b) i:2) 
 945              eif f=(the_function '\' Int Int -> Int) 
 946                if p=1 
 947                  return (instruction (the_function shift_right Int Int -> Int) i:0 (argument constant Int b) i:2) 
 948              eif f=(the_function '\' uInt uInt -> uInt) 
 949                if p=1 
 950                  return (instruction (the_function shift_right uInt Int -> uInt) i:0 (argument constant Int b) i:2) 
 951              eif f=(the_function '%' uInt uInt -> uInt) 
 952                if p=1 
 953                  return (instruction (the_function '.and.' Int Int -> Int) i:0 (argument constant Int 2^b-1) i:2) 
 954    if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) or f=(the_function '\' Int Int -> Int) or f=(the_function '\' uInt uInt -> uInt)  
 955      var Pointer:Argument :> 1 
 956      if a:first_instruction:function=(the_function shift_left Int Int -> Int) and a:last_instruction=i 
 957        if a:is_temporary 
 958          var Pointer:Argument :> a:first_instruction:0 
 959          if c:where=argument_constant and (c:constant map uInt)=1 
 960            if (a:first_instruction:is_stable a:first_instruction i) 
 961              var Link:Argument :> a:first_instruction 1 
 962              gc remove a:first_instruction 
 963              if f=(the_function '.*.' Int Int -> Int) or f=(the_function '.*.' uInt uInt -> uInt) 
 964                return (instruction (the_function shift_left Int Int -> Int) i:i:2) 
 965              eif f=(the_function '\' Int Int -> Int) 
 966                return (instruction (the_function shift_right Int Int -> Int) i:i:2) 
 967              eif f=(the_function '\' uInt uInt -> uInt) 
 968                return (instruction (the_function shift_right uInt Int -> uInt) i:i:2) 
 969   
 970  function optimize_shift gc 
 971    arg_rw GeneratorContext gc 
 972    var Link:Instruction :> gc first_instruction 
 973    while addressof:i<>null 
 974      var Link:Instruction i2 :> optimize_shift gc 
 975      if addressof:i2<>null 
 976        gc insert_after_instruction i2 
 977        gc remove i 
 978        :> i2 
 979      :> next_instruction 
 980   
 981  record_optimizer_function optimize_add "pliant optimizer rewrite instructions" 
 982  record_optimizer_function optimize_shift "pliant optimizer rewrite instructions"