/pliant/language/type/number/intn.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/ring3.pli" 
 18   
 19   
 20  constant please_retry 0FFFFFFFFh 
 21  constant read_locks   1FFFFFFFh 
 22  constant write_locked 20000000h 
 23  constant undefinedn   40000000h 
 24  constant positive     80000000h 
 25   
 26   
 27  type Intn 
 28    field Address bits 
 29    field Int size 
 30    field uInt status 
 31   
 32   
 33 
 
 34  #  locking and resizing 
 35   
 36   
 37  method i get_status -> status 
 38    arg Intn i ; arg uInt status 
 39    while true 
 40      status := atomic_read_and_set ((addressof i:status) map uInt) please_retry 
 41      if status<>please_retry 
 42        return 
 43   
 44  method i read_lock -> i_is_positive 
 45    arg Intn i ; arg uInt i_is_positive 
 46    while true 
 47      var uInt status := get_status 
 48      if (status .and. write_locked)=0 
 49        (addressof i:status) map uInt := status+1 
 50        i_is_positive := status .and. positive 
 51        return 
 52      else 
 53        (addressof i:status) map uInt := status 
 54        os_yield 
 55   
 56  method i read_unlock 
 57    arg Intn i 
 58    (addressof i:status) map uInt := i:get_status-1 
 59   
 60  method i write_lock 
 61    arg_rw Intn i 
 62    while true 
 63      var uInt status := get_status 
 64      if (status .and. read_locks+write_locked)=0 
 65        status := status+write_locked 
 66        return 
 67      else 
 68        status := status 
 69        os_yield 
 70   
 71  method i write_unlock 
 72    arg_rw Intn i 
 73    status := i:get_status-write_locked 
 74   
 75   
 76  method i extend2 n 
 77    arg_rw Intn i ; arg Int n 
 78    if n*uInt:size>(memory_size i:bits) 
 79      bits := memory_zresize i:bits n*uInt:size addressof:i 
 80   
 81  method i extend n 
 82    arg Intn i ; arg Int n 
 83    while n*uInt:size>(memory_size i:bits) 
 84      read_unlock 
 85      (addressof:map Intn) write_lock 
 86      (addressof:map Intn) extend2 n 
 87      (addressof:map Intn) write_unlock 
 88      read_lock 
 89   
 90   
 91  method i resize n 
 92    arg_rw Intn i ; arg Int n 
 93    if n<i:size 
 94      memory_clear (i:bits translate uInt n) (i:size-n)*uInt:size 
 95    eif n*uInt:size>(memory_size i:bits) 
 96      bits := memory_zresize i:bits n*uInt:size addressof:i 
 97    size := n 
 98   
 99   
 100  method i zresize n 
 101    arg_rw Intn i ; arg Int n 
 102    memory_clear i:bits i:size*uInt:size 
 103    if n*uInt:size>(memory_size i:bits) 
 104      bits := memory_zresize i:bits n*uInt:size addressof:i 
 105    size := n 
 106   
 107   
 108  method i shrink 
 109    arg_rw Intn i 
 110    while i:size>and ((i:bits translate uInt i:size-1) map uInt)=0 
 111      size := i:size-1 
 112    if i:size=0 
 113      status := positive 
 114   
 115   
 116 
 
 117  #  basic operations 
 118   
 119   
 120  method i nbbits -> n 
 121    arg uInt i ; arg Int n 
 122    if i<2^4 
 123      := shunt i=0 0 i<2 1 i<4 2 i<8 3 4 
 124    eif i<2^8 
 125      := 4+(i\2^nbbits) 
 126    eif i<2^16 
 127      := 8+(i\2^nbbits) 
 128    else 
 129      := 16+(i\2^16 nbbits) 
 130   
 131  method i nbbits -> n 
 132    arg Intn i ; arg Int n 
 133    if i:size<>0 
 134      := (i:size-1)*uInt:bitsize + ((i:bits translate uInt i:size-1) map uInt):nbbits 
 135    else 
 136      := 0 
 137   
 138   
 139  method i set_bit u 
 140    arg_rw Intn i ; arg Int u 
 141    check u>=and u<i:size*uInt:bitsize 
 142    var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt 
 143    bloc := bloc .or. 2^(u%uInt:bitsize) 
 144   
 145   
 146  method i test_bit u -> on 
 147    arg Intn i ; arg Int u ; arg CBool on 
 148    check u>=and u<i:size*uInt:bitsize 
 149    var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt 
 150    on := (bloc .and. 2^(u%uInt:bitsize))<>0 
 151   
 152   
 153  function unsigned_compare a b -> r 
 154    arg Intn b ; arg Int r 
 155    if a:size<>b:size 
 156      return (shunt a:size>b:size compare_superior compare_inferior) 
 157    for (var Int i) a:size-1 0 step -1 
 158      var uInt ai := (a:bits translate uInt i) map uInt 
 159      var uInt bi := (b:bits translate uInt i) map uInt 
 160      if ai>bi 
 161        return compare_superior 
 162      eif ai<bi 
 163        return compare_inferior 
 164    return compare_equal 
 165   
 166   
 167  if uInt:size=4 
 168    alias Half uInt16 from "/pliant/language/type/number/int_sized.pli" 
 169  eif uInt:size=8 
 170    alias Half uInt32 from "/pliant/language/type/number/int_sized.pli" 
 171   
 172   
 173  function add a b r size 
 174    arg Address r ; arg Int size 
 175    var uInt carry := 0 
 176    for (var Int i) 0 2*size-1 
 177      carry := carry + ((translate Half i) map Half) + ((translate Half i) map Half) 
 178      if carry<2^Half:bitsize 
 179        (translate Half i) map Half := carry 
 180        carry := 0 
 181      else 
 182        (translate Half i) map Half := carry 2^Half:bitsize 
 183        carry := 1 
 184    check carry=0 
 185   
 186   
 187  function sub a b r size 
 188    arg Address r ; arg Int size 
 189    var Int carry := 0 
 190    for (var Int i) 0 2*size-1 
 191      carry := carry + ((translate Half i) map Half) - ((translate Half i) map Half) 
 192      if carry>=0 
 193        (translate Half i) map Half := carry 
 194        carry := 0 
 195      else 
 196        (translate Half i) map Half := carry 2^Half:bitsize 
 197        carry := -1 
 198    check carry=0 
 199   
 200   
 201  function add_mul src dest size factor 
 202    arg Address src dest ; arg Int size ; arg uInt factor 
 203    var uInt carry := 0 
 204    for (var Int i) size*2-1 
 205      carry := carry + ((dest translate Half i) map Half) + ((src translate Half i) map Half) factor 
 206      (dest translate Half i) map Half := carry .and. 2^Half:bitsize-1 
 207      carry := carry 2^Half:bitsize 
 208    var Int := size*2 
 209    while carry<>0 
 210      carry := carry + ((dest translate Half i) map Half) 
 211      (dest translate Half i) map Half := carry .and. 2^Half:bitsize-1 
 212      carry := carry 2^Half:bitsize 
 213      := i+1 
 214   
 215   
 216 
 
 217  #  shifted 
 218   
 219   
 220  method i bloc u -> r 
 221    arg Intn i ; arg Int u ; arg uInt r 
 222    if u>=and u<i:size 
 223      := (i:bits translate uInt u) map uInt 
 224    else 
 225      := 0 
 226   
 227   
 228  function do_shift low high shift -> result 
 229    arg uInt low high result ; arg Int shift 
 230    check shift>=and shift<uInt:bitsize 
 231    if shift<>0 
 232      result := (low 2^(uInt:bitsize-shift)) .or. (high .*. 2^shift) 
 233    else 
 234      result := high 
 235   
 236   
 237  method i size_shifted shift -> r 
 238    arg Intn i ; arg Int shift ; arg Int r 
 239    := i:size+(shift+uInt:bitsize-1)\uInt:bitsize 
 240   
 241   
 242  method i bloc_shifted u shift -> r 
 243    arg Intn i ; arg Int shift ; arg uInt r 
 244    var Int := u.-.shift\uInt:bitsize 
 245    var Int := shift%uInt:bitsize 
 246    := do_shift (bloc t.-.1) (bloc t) s 
 247   
 248   
 249  function unsigned_compare_shifted1 a b b_shift -> r 
 250    arg Intn b ; arg Int b_shift ; arg Int r 
 251    for (var Int i) (max a:size (size_shifted b_shift))-1 0 step -1 
 252      var uInt ai := bloc i 
 253      var uInt bi := bloc_shifted b_shift 
 254      if ai>bi 
 255        return compare_superior 
 256      eif ai<bi 
 257        return compare_inferior 
 258    return compare_equal 
 259   
 260   
 261  constant dl pliant_debugging_level 
 262  if dl>=4 
 263   
 264    function unsigned_compare_shifted2 a b b_shift -> r 
 265      arg Intn a b ; arg Int b_shift ; arg Int r 
 266      for (var Int i) (max a:nbbits b:nbbits+b_shift) 0 step -1 
 267        var CBool ai := shunt i<a:size*uInt:bitsize (a test_bit i) false 
 268        var CBool bi := shunt i-b_shift>=0 and i-b_shift<b:size*uInt:bitsize (b test_bit i-b_shift) false 
 269        if ai<>bi 
 270          return (shunt ai compare_superior compare_inferior) 
 271      return compare_equal 
 272   
 273   
 274    function unsigned_compare_shifted a b b_shift -> r 
 275      arg Intn a b ; arg Int b_shift ; arg Int r 
 276      var Int r1 := unsigned_compare_shifted1 a b b_shift 
 277      var Int r2 := unsigned_compare_shifted2 a b b_shift 
 278      check r1=r2 
 279      r := r1 
 280   
 281  else 
 282   
 283     alias unsigned_compare_shifted unsigned_compare_shifted1 
 284   
 285   
 286  function sub1 src dest carry 
 287    arg Half src ; arg_rw Half dest ; arg_rw Int carry 
 288    carry := carry + (addressof:dest map Half) - (addressof:src map Half) 
 289    if carry>=0 
 290      addressof:dest map Half := carry 
 291      carry := 0 
 292    else 
 293      addressof:dest map Half := carry 2^Half:bitsize 
 294      carry := -1 
 295   
 296   
 297  function sub2 src dest carry 
 298    arg uInt src ; arg_rw uInt dest ; arg_rw Int carry 
 299    sub1 (addressof:src map Half) (addressof:dest map Half) carry 
 300    sub1 ((addressof:src translate Half 1) map Half) ((addressof:dest translate Half 1) map Half) carry 
 301   
 302   
 303  function sub_shifted src dest size src_shift 
 304    arg Address src dest ; arg Int size src_shift 
 305    var Int := src_shift\uInt:bitsize 
 306    var Int := src_shift%uInt:bitsize 
 307    var Int carry := 0 
 308    for (var Int i) size 
 309      var uInt32 shifted := do_shift (shunt i>0 ((src translate uInt i-1) map uInt) 0) ((src translate uInt i) map uInt) s 
 310      sub2 shifted ((dest translate uInt i+t) map uInt) carry 
 311    var Int := t+size*2 
 312    while carry<>0 
 313      carry := carry + ((dest translate Half i) map Half) 
 314      if carry>=0 
 315        (dest translate Half i) map Half := carry 
 316        carry := 0 
 317      else 
 318        (dest translate Half i) map Half := carry 2^Half:bitsize 
 319        carry := -1 
 320      := i+1 
 321   
 322   
 323 
 
 324  #  generic operations 
 325    
 326   
 327  function build  i 
 328    arg_w Intn i 
 329    bits := null 
 330    size := 0 
 331    status := positive 
 332   
 333   
 334  function destroy i 
 335    arg_w Intn i 
 336    memory_free i:bits 
 337   
 338   
 339  function copy src dest 
 340    arg Intn src ; arg_w Intn dest 
 341    src read_lock 
 342    dest resize src:size 
 343    memory_copy src:bits dest:bits src:size*uInt:size 
 344    src read_unlock 
 345    dest status := src:status .and. (positive .or. undefinedn) 
 346   
 347   
 348  function compare a b -> r 
 349    arg Intn b ; arg Int r 
 350    if (a:status .and. undefinedn)<>or (b:status .and. undefinedn)<>0 
 351      return (shunt (a:status .and. undefinedn)=(b:status .and. undefinedn) compare_equal (a:status .and. undefinedn)<>0 compare_inferior compare_superior) 
 352    var uInt pa := read_lock ; var uInt pb := read_lock 
 353    if pa<>pb 
 354      := shunt pa<>0 compare_superior compare_inferior 
 355    else 
 356      := (unsigned_compare b) .xor. (shunt pa=positive 0 compare_inferior+compare_superior) 
 357    read_unlock ; read_unlock 
 358   
 359   
 360 
 
 361  #  + - * 
 362   
 363   
 364  function '+' a b -> r 
 365    arg Intn r 
 366    has_no_side_effect 
 367    var uInt pa := read_lock ; var uInt pb := read_lock 
 368    if pa=pb 
 369      status := pa 
 370      var Int := (max a:size b:size)+1 
 371      extend n ; extend n ; resize n 
 372      add a:bits b:bits r:bits n 
 373    eif (unsigned_compare b)<>compare_inferior 
 374      status := pa 
 375      var Int := size 
 376      extend n ; resize n 
 377      sub a:bits b:bits r:bits n 
 378    else 
 379      status := pb 
 380      var Int := size 
 381      extend n ; resize n 
 382      sub b:bits a:bits r:bits n 
 383    read_unlock ; read_unlock 
 384    shrink 
 385   
 386   
 387  function '-' a b -> r 
 388    arg Intn r 
 389    has_no_side_effect 
 390    var uInt pa := read_lock ; var uInt pb := read_lock 
 391    if pa<>pb 
 392      status := pa 
 393      var Int := (max a:size b:size)+1 
 394      extend n ; extend n ; resize n 
 395      add a:bits b:bits r:bits n 
 396    eif (unsigned_compare b)<>compare_inferior 
 397      status := pa 
 398      var Int := size 
 399      extend n ; resize n 
 400      sub a:bits b:bits r:bits n 
 401    else 
 402      status := positive-pb 
 403      var Int := size 
 404      extend n ; resize n 
 405      sub b:bits a:bits r:bits n 
 406    read_unlock ; read_unlock 
 407    shrink 
 408   
 409   
 410  function '*' a b -> r 
 411    arg Intn r 
 412    has_no_side_effect 
 413    var uInt pa := read_lock ; var uInt pb := read_lock 
 414    zresize a:size+b:size 
 415    status := shunt pa=pb positive 0 
 416    for (var Int i) 0 2*b:size-1 
 417      add_mul a:bits (r:bits translate Half i) a:size ((b:bits translate Half i) map Half) 
 418    read_unlock ; read_unlock 
 419    shrink 
 420   
 421   
 422  function divide a b q r 
 423    arg Intn b ; arg_w Intn r 
 424    has_no_side_effect 
 425    check b:size<>"Attempted to divide by 0" 
 426    var uInt pa := read_lock ; var uInt pb := read_lock 
 427    if b:size<>or (b:bits map uInt)>=2^Half:bitsize 
 428      var Int := a:nbbits-b:nbbits 
 429      := a 
 430      if s>=0 
 431        extend b:size+1 
 432        zresize s\uInt:bitsize+1 ; status := shunt pa=pb positive 0 
 433        extend2 r:size+1 
 434        for (var Int i) 0 step -1 
 435          if (unsigned_compare_shifted i)<>compare_inferior 
 436            set_bit i 
 437            sub_shifted b:bits r:bits b:size i 
 438            # check (unsigned_compare_shifted r b i)=compare_inferior 
 439        shrink 
 440      else 
 441        resize 0 
 442      shrink 
 443    else 
 444      var uInt := b:bits map uInt 
 445      var uInt carry := 0 
 446      resize a:size ; status := shunt pa=pb positive 0 
 447      for (var Int i) 2*a:size-1 0 step -1 
 448        carry := carry*2^Half:bitsize + ((a:bits translate Half i) map Half) 
 449        (q:bits translate Half i) map Half := carry\d 
 450        carry := carry%d 
 451      shrink 
 452      if carry=0 
 453        resize 0 ; status := positive 
 454      else 
 455        resize 1 ; r:bits map uInt := carry ; status := pa 
 456    check (unsigned_compare b)=compare_inferior 
 457    read_unlock ; read_unlock 
 458   
 459   
 460  function '\' a b -> q 
 461    arg Intn q 
 462    has_no_side_effect 
 463    var Intn t 
 464    if addressof:q<>addressof:and addressof:q<>addressof:b 
 465      divide r 
 466    else 
 467      := a\b 
 468      := t 
 469   
 470   
 471  function '%' a b -> r ## section "remain" 
 472    arg Intn r 
 473    has_no_side_effect 
 474    var Intn t 
 475    if addressof:r<>addressof:and addressof:r<>addressof:b 
 476      divide r 
 477    else 
 478      := a%b 
 479      := t 
 480   
 481   
 482 
 
 483  #  casting 
 484   
 485   
 486  function 'cast Intn' i -> j 
 487    arg Int i ; arg Intn j 
 488    extension ; has_no_side_effect 
 489    if i=undefined 
 490      resize 0 ; status := undefinedn 
 491    eif i=0 
 492      resize 0 ; status := positive 
 493    eif i>0 
 494      resize 1 ; j:bits map uInt := cast uInt ; status := positive 
 495    else 
 496      resize 1 ; j:bits map uInt := cast -uInt ; status := 0 
 497   
 498   
 499  function 'cast Int' i -> j 
 500    arg Intn i ; arg Int j 
 501    reduction ; has_no_side_effect 
 502    if i:size=0 
 503      if (i:status .and. undefinedn)<>0 
 504        := undefined 
 505      else 
 506        := 0 
 507    eif i:size=and ((i:bits map uInt) .and. 2^(uInt:bitsize-1))=0 
 508      var uInt := read_lock 
 509      := shunt p=positive (i:bits map uInt) -(i:bits map uInt) 
 510      read_unlock 
 511    else 
 512      error error_id_arithmetic "The value is too large to fit in an integer" 
 513   
 514   
 515  function 'cast Intn' i -> j 
 516    arg uInt i ; arg Intn j 
 517    extension ; has_no_side_effect 
 518    if i=0 
 519      resize 0 ; status := positive 
 520    else 
 521      resize 1 ; j:bits map uInt := i ; status := positive 
 522   
 523   
 524  function 'cast uInt' i -> j 
 525    arg Intn i ; arg uInt j 
 526    reduction ; has_no_side_effect 
 527    if i:size=0 
 528      := 0 
 529    eif i:size=1 
 530      var uInt := read_lock 
 531      if p<>positive 
 532        error error_id_unexpected "The integer is negative" 
 533      := i:bits map uInt 
 534      read_unlock 
 535    else 
 536      error error_id_arithmetic "The value is too large to fit in an integer" 
 537   
 538   
 539  function 'cast Float' n -> f 
 540    arg Intn n ; arg Float f 
 541    explicit 
 542    := 0 
 543    var Intn := n ; var Float := 1 
 544    while r<(-(2^30)) or r>2^30 
 545      += (cast r%2^15 Int)*d 
 546      \= 2^15 ; *= 2^15 
 547    += (cast Int)*d 
 548       
 549   
 550 
 
 551  #  ^ 
 552   
 553   
 554  method x apply_modulus m 
 555    arg_rw Intn x ; arg Intn m 
 556    check m>"Modulus value must be positive" 
 557    read_lock 
 558    var Int := x:nbbits m:nbbits 
 559    if s>=0 
 560      extend2 x:size+1 
 561      extend m:size+1 
 562      for (var Int i) 0 step -1 
 563        if (unsigned_compare_shifted i)<>compare_inferior 
 564          sub_shifted m:bits x:bits m:size i 
 565          shrink 
 566          # check (unsigned_compare_shifted x m i)=compare_inferior 
 567    check (unsigned_compare m)=compare_inferior 
 568    read_unlock 
 569   
 570   
 571  function power_modulus a b m -> r 
 572    arg Intn r 
 573    has_no_side_effect 
 574    check addressof:m=null or m>"Modulus value must be positive" 
 575    := 1 ; var Intn := a 
 576    var Int := nbbits 
 577    for (var Int i) n-1 
 578      if (test_bit i) 
 579        := r*p 
 580        if addressof:m<>null 
 581          apply_modulus m 
 582      if i=n-1 
 583        return 
 584      := p*p 
 585      if addressof:m<>null 
 586        apply_modulus m 
 587   
 588   
 589  function '^' a b -> r 
 590    arg Intn r 
 591    has_no_side_effect 
 592    := power_modulus b (null map Intn) 
 593   
 594   
 595  meta '%' e 
 596    strong_definition 
 597    if e:size<>2 
 598      return 
 599    e:compile ? 
 600    e:compile ? 
 601    var Link:Instruction :> e:0:instructions:last map Instruction 
 602    if addressof:i=null or (addressof i:function)<>addressof:(the_function '^' Intn Intn -> Intn) 
 603      return 
 604    if (addressof e:0:result)<>(addressof i:2) 
 605      return 
 606    if not (e:cast Intn) 
 607      return 
 608    # console "found x^y%n at "+e:position+"[lf]" 
 609    size := 4 
 610    :> 2 
 611    :> e:1:result 
 612    function :> the_function power_modulus Intn Intn Intn -> Intn 
 613    suckup e:1 ; suckup e:0 
 614    set_result e:0:result access_read 
 615   
 616   
 617 
 
 618   
 619   
 620  function 'cast Status' i -> s 
 621    arg Intn i ; arg Status s 
 622    explicit 
 623    if (i:status .and. undefinedn)<>0 
 624      := undefined 
 625    else 
 626      := defined 
 627   
 628  function 'cast Intn' s -> i 
 629    arg Status s ; arg Intn i 
 630    extension 
 631    if pliant_debugging_level>=2 
 632      if s<>undefined 
 633        error error_id_unexpected "Unexpected Status value" 
 634    resize 0 
 635    status := undefinedn 
 636   
 637   
 638 
 
 639   
 640   
 641  function to_string i -> s 
 642    arg Intn i ; arg Str s 
 643    has_no_side_effect 
 644    if i:size=0 
 645      := "0" 
 646    eif i:size=and (i:bits map uInt)<2^(Int:bitsize-1) 
 647      := 'convert to string' (cast Int) 
 648    eif false # faster, but does not worse the extra complexity 
 649      var Int reserved := i:nbbits\3+2 
 650      var Address buffer := memory_allocate reserved null 
 651      var Address cursor := buffer translate Byte reserved 
 652      var Intn cur := i 
 653      while cur:size>1 or (cur:bits map uInt)>=2^(Int:bitsize-1) 
 654        divide cur 10000 (var Intn remain) (var Intn r) 
 655        var Str temp := right ('convert to string' (cast r Int)) 4 "0" 
 656        cursor := cursor translate Byte -4 
 657        memory_copy temp:characters cursor 4 
 658        cur := remain 
 659      temp := 'convert to string' (cast cur Int) 
 660      cursor := cursor translate Byte -(temp:len) 
 661      memory_copy temp:characters cursor temp:len 
 662      if p=0 
 663        cursor := cursor translate uInt8 -1 
 664        cursor map uInt8 := "-":number 
 665      var Int length := (cast buffer Int) .+. reserved .-. (cast cursor Int) 
 666      check length<=reserved 
 667      var Address final := memory_allocate length addressof:s 
 668      memory_copy cursor final length 
 669      s set final length true 
 670      memory_free buffer 
 671    else 
 672      := "" 
 673      var Intn cur := i 
 674      while cur:size>or (cur:bits map uInt)>=2^(Int:bitsize-1) 
 675        divide cur 10000 (var Intn remain) (var Intn r) 
 676        := (right ('convert to string' (cast Int)) "0")+s 
 677        cur := remain 
 678      := ('convert to string' (cast cur Int))+s 
 679       
 680   
 681  method data 'to string' options -> string 
 682    arg Intn data ; arg Str options ; arg Str string 
 683    if (data:status .and. undefinedn)<>0 
 684      return (shunt options="db" or options="raw" "" "?") 
 685    string := to_string data 
 686    if options:len<>and { var Str sep := options option "separated" Str ; sep:len=1 } 
 687      var Int newlen := string:len+(string:len-1)\3 
 688      var Address buf := memory_allocate newlen null 
 689      var Address stop := string:characters translate Char -1 
 690      var Address src := stop translate Char string:len 
 691      var Address dest := buf translate Char newlen-1 
 692      var Int := 3 
 693      while src<>stop 
 694        if r=0 
 695          dest map Char := sep 0 
 696          dest := dest translate Byte -1 
 697          := 3 
 698        dest map Char := src map Char 
 699        src := src translate Byte -1 
 700        dest := dest translate Byte -1 
 701        := r-1 
 702      string set buf newlen true 
 703   
 704  method data 'from string' string options may_skip skiped offset -> status 
 705    arg_w Intn data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 706    var Int stop := string:len-1 
 707    if not may_skip and stop<>(-1) 
 708      stop := 0 
 709    for (var Int i) stop 
 710      var Int c0 := string:number 
 711      if c0>="0":0:number and c0<="9":0:number or c0="?":0:number or (c0="-":0:number and i+1<>string:len and string:(i+1):number>="0":0:number and string:(i+1):number<="9":0:number) 
 712        skiped := i 
 713        if c0="?":0:number 
 714          data := undefined 
 715          offset := i+1 
 716          return success 
 717        data := 0 ; var Int sign := 1 
 718        if c0="-":0:number 
 719          sign := -1 
 720          := i+1 
 721        while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number 
 722          data := data*10 string:i:number-"0":0:number 
 723          := i+1 
 724        data := data sign 
 725        offset := i 
 726        return success 
 727      eif c0="?":0:number 
 728        data := undefined 
 729        skiped := i 
 730        offset := i+1 
 731        return success 
 732    data := undefined 
 733    status := shunt string="" and (options="db" or options="raw") success failure 
 734   
 735   
 736  function parse_intn context line parameter 
 737    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 738    if (from_string addressof:(var Intn data) Intn line "" false (var Int skip) (var Int offset))=failure 
 739      return 
 740    if line:0:number="-":0:number or line:0:number="?":0:number 
 741      return 
 742    if offset=line:len or line:offset:number<>"n":0:number 
 743      return 
 744    if offset+1<>line:len and line:(offset+1):isidentcharacter 
 745      return 
 746    var Link:Intn :> new Intn 
 747    := data 
 748    context add_token addressof:i 
 749    context forward offset+1 
 750   
 751  gvar ParserFilter intn_filter 
 752  intn_filter function :> the_function parse_intn ParserContext Str Address 
 753  constant 'pliant parser basic types' intn_filter 
 754  export 'pliant parser basic types' 
 755   
 756   
 757 
 
 758   
 759   
 760  method i binary_encode -> s 
 761    arg Intn i ; arg Str s 
 762    var Int sign := shunt i:read_lock=positive 0 1 
 763    var Int := (i:nbbits+7)\8 
 764    set (memory_allocate l+sign addressof:s) l+sign true 
 765    memory_copy i:bits s:characters l 
 766    if sign<>0 
 767      := character 0 
 768    read_unlock 
 769   
 770  method i binary_decode s always_positive 
 771    arg_w Intn i ; arg Str s ; arg CBool always_positive 
 772    var Int := len ; var uInt stat := positive 
 773    if not always_positive and l>and (l-1):number=0 
 774      stat := 0 ; -= 1 
 775    resize (l+uInt:size-1)\uInt:size ; status := stat 
 776    if i:size>0 
 777      (i:bits translate uInt i:size-1) map uInt := 0 
 778    memory_copy s:characters i:bits s:len 
 779    shrink 
 780   
 781   
 782 
 
 783   
 784   
 785  export Intn '. nbbits' '+' '-' '*' '\' '%' '^' 
 786  export 'cast Intn' 'cast Int' 'cast uInt' 'cast Float' compare 
 787  export '. apply_modulus' '. binary_encode' '. binary_decode' 
 788   
 789  alias '. please read_lock' '. read_lock' 
 790  export '. please read_lock' 
 791   
 792  alias '. please read_unlock' '. read_unlock' 
 793  export '. please read_unlock' 
 794   
 795  alias '. please resize' '. resize' 
 796  export '. please resize' 
 797   
 798  alias '. please shrink' '. shrink' 
 799  export '. please shrink' 
 800   
 801  alias '. please bits' '. bits' 
 802  export '. please bits' 
 803   
 804  alias '. please size' '. size' 
 805  export '. please size' 
 806   
 807  alias '. please status' '. status' 
 808  export '. please status' 
 809   
 810  alias 'please positive' positive 
 811  export 'please positive'