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

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


constant please_retry 0FFFFFFFFh
constant read_locks   1FFFFFFFh
constant write_locked 20000000h
constant undefinedn   40000000h
constant positive     80000000h


type Intn
  field Address bits
  field Int size
  field uInt status


#----------------------------------------------------------------------
#  locking and resizing


method i get_status -> status
  arg Intn i ; arg uInt status
  while true
    status := atomic_read_and_set ((addressof i:status) map uInt) please_retry
    if status<>please_retry
      return

method i read_lock -> i_is_positive
  arg Intn i ; arg uInt i_is_positive
  while true
    var uInt status := i get_status
    if (status .and. write_locked)=0
      (addressof i:status) map uInt := status+1
      i_is_positive := status .and. positive
      return
    else
      (addressof i:status) map uInt := status
      os_yield

method i read_unlock
  arg Intn i
  (addressof i:status) map uInt := i:get_status-1

method i write_lock
  arg_rw Intn i
  while true
    var uInt status := i get_status
    if (status .and. read_locks+write_locked)=0
      i status := status+write_locked
      return
    else
      i status := status
      os_yield

method i write_unlock
  arg_rw Intn i
  i status := i:get_status-write_locked


method i extend2 n
  arg_rw Intn i ; arg Int n
  if n*uInt:size>(memory_size i:bits)
    i bits := memory_zresize i:bits n*uInt:size addressof:i

method i extend n
  arg Intn i ; arg Int n
  while n*uInt:size>(memory_size i:bits)
    i read_unlock
    (addressof:i map Intn) write_lock
    (addressof:i map Intn) extend2 n
    (addressof:i map Intn) write_unlock
    i read_lock


method i resize n
  arg_rw Intn i ; arg Int n
  if n<i:size
    memory_clear (i:bits translate uInt n) (i:size-n)*uInt:size
  eif n*uInt:size>(memory_size i:bits)
    i bits := memory_zresize i:bits n*uInt:size addressof:i
  i size := n


method i zresize n
  arg_rw Intn i ; arg Int n
  memory_clear i:bits i:size*uInt:size
  if n*uInt:size>(memory_size i:bits)
    i bits := memory_zresize i:bits n*uInt:size addressof:i
  i size := n


method i shrink
  arg_rw Intn i
  while i:size>0 and ((i:bits translate uInt i:size-1) map uInt)=0
    i size := i:size-1
  if i:size=0
    i status := positive


#----------------------------------------------------------------------
#  basic operations


method i nbbits -> n
  arg uInt i ; arg Int n
  if i<2^4
    n := shunt i=0 0 i<2 1 i<4 2 i<8 3 4
  eif i<2^8
    n := 4+(i\2^4 nbbits)
  eif i<2^16
    n := 8+(i\2^8 nbbits)
  else
    n := 16+(i\2^16 nbbits)

method i nbbits -> n
  arg Intn i ; arg Int n
  if i:size<>0
    n := (i:size-1)*uInt:bitsize + ((i:bits translate uInt i:size-1) map uInt):nbbits
  else
    n := 0


method i set_bit u
  arg_rw Intn i ; arg Int u
  check u>=0 and u<i:size*uInt:bitsize
  var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt
  bloc := bloc .or. 2^(u%uInt:bitsize)


method i test_bit u -> on
  arg Intn i ; arg Int u ; arg CBool on
  check u>=0 and u<i:size*uInt:bitsize
  var Pointer:uInt bloc :> (i:bits translate uInt u\uInt:bitsize) map uInt
  on := (bloc .and. 2^(u%uInt:bitsize))<>0


function unsigned_compare a b -> r
  arg Intn a b ; arg Int r
  if a:size<>b:size
    return (shunt a:size>b:size compare_superior compare_inferior)
  for (var Int i) a:size-1 0 step -1
    var uInt ai := (a:bits translate uInt i) map uInt
    var uInt bi := (b:bits translate uInt i) map uInt
    if ai>bi
      return compare_superior
    eif ai<bi
      return compare_inferior
  return compare_equal


if uInt:size=4
  alias Half uInt16 from "/pliant/language/type/number/int_sized.pli"
eif uInt:size=8
  alias Half uInt32 from "/pliant/language/type/number/int_sized.pli"


function add a b r size
  arg Address a b r ; arg Int size
  var uInt carry := 0
  for (var Int i) 0 2*size-1
    carry := carry + ((a translate Half i) map Half) + ((b translate Half i) map Half)
    if carry<2^Half:bitsize
      (r translate Half i) map Half := carry
      carry := 0
    else
      (r translate Half i) map Half := carry - 2^Half:bitsize
      carry := 1
  check carry=0


function sub a b r size
  arg Address a b r ; arg Int size
  var Int carry := 0
  for (var Int i) 0 2*size-1
    carry := carry + ((a translate Half i) map Half) - ((b translate Half i) map Half)
    if carry>=0
      (r translate Half i) map Half := carry
      carry := 0
    else
      (r translate Half i) map Half := carry + 2^Half:bitsize
      carry := -1
  check carry=0


function add_mul src dest size factor
  arg Address src dest ; arg Int size ; arg uInt factor
  var uInt carry := 0
  for (var Int i) 0 size*2-1
    carry := carry + ((dest translate Half i) map Half) + ((src translate Half i) map Half) * factor
    (dest translate Half i) map Half := carry .and. 2^Half:bitsize-1
    carry := carry \ 2^Half:bitsize
  var Int i := size*2
  while carry<>0
    carry := carry + ((dest translate Half i) map Half)
    (dest translate Half i) map Half := carry .and. 2^Half:bitsize-1
    carry := carry \ 2^Half:bitsize
    i := i+1


#----------------------------------------------------------------------
#  shifted


method i bloc u -> r
  arg Intn i ; arg Int u ; arg uInt r
  if u>=0 and u<i:size
    r := (i:bits translate uInt u) map uInt
  else
    r := 0


function do_shift low high shift -> result
  arg uInt low high result ; arg Int shift
  check shift>=0 and shift<uInt:bitsize
  if shift<>0
    result := (low \ 2^(uInt:bitsize-shift)) .or. (high .*. 2^shift)
  else
    result := high


method i size_shifted shift -> r
  arg Intn i ; arg Int shift ; arg Int r
  r := i:size+(shift+uInt:bitsize-1)\uInt:bitsize


method i bloc_shifted u shift -> r
  arg Intn i ; arg Int u shift ; arg uInt r
  var Int t := u.-.shift\uInt:bitsize
  var Int s := shift%uInt:bitsize
  r := do_shift (i bloc t.-.1) (i bloc t) s


function unsigned_compare_shifted1 a b b_shift -> r
  arg Intn a b ; arg Int b_shift ; arg Int r
  for (var Int i) (max a:size (b size_shifted b_shift))-1 0 step -1
    var uInt ai := a bloc i
    var uInt bi := b bloc_shifted i b_shift
    if ai>bi
      return compare_superior
    eif ai<bi
      return compare_inferior
  return compare_equal


constant dl pliant_debugging_level
if dl>=4

  function unsigned_compare_shifted2 a b b_shift -> r
    arg Intn a b ; arg Int b_shift ; arg Int r
    for (var Int i) (max a:nbbits b:nbbits+b_shift) 0 step -1
      var CBool ai := shunt i<a:size*uInt:bitsize (a test_bit i) false
      var CBool bi := shunt i-b_shift>=0 and i-b_shift<b:size*uInt:bitsize (b test_bit i-b_shift) false
      if ai<>bi
        return (shunt ai compare_superior compare_inferior)
    return compare_equal


  function unsigned_compare_shifted a b b_shift -> r
    arg Intn a b ; arg Int b_shift ; arg Int r
    var Int r1 := unsigned_compare_shifted1 a b b_shift
    var Int r2 := unsigned_compare_shifted2 a b b_shift
    check r1=r2
    r := r1

else

   alias unsigned_compare_shifted unsigned_compare_shifted1


function sub1 src dest carry
  arg Half src ; arg_rw Half dest ; arg_rw Int carry
  carry := carry + (addressof:dest map Half) - (addressof:src map Half)
  if carry>=0
    addressof:dest map Half := carry
    carry := 0
  else
    addressof:dest map Half := carry + 2^Half:bitsize
    carry := -1


function sub2 src dest carry
  arg uInt src ; arg_rw uInt dest ; arg_rw Int carry
  sub1 (addressof:src map Half) (addressof:dest map Half) carry
  sub1 ((addressof:src translate Half 1) map Half) ((addressof:dest translate Half 1) map Half) carry


function sub_shifted src dest size src_shift
  arg Address src dest ; arg Int size src_shift
  var Int t := src_shift\uInt:bitsize
  var Int s := src_shift%uInt:bitsize
  var Int carry := 0
  for (var Int i) 0 size
    var uInt32 shifted := do_shift (shunt i>0 ((src translate uInt i-1) map uInt) 0) ((src translate uInt i) map uInt) s
    sub2 shifted ((dest translate uInt i+t) map uInt) carry
  var Int i := t+size*2
  while carry<>0
    carry := carry + ((dest translate Half i) map Half)
    if carry>=0
      (dest translate Half i) map Half := carry
      carry := 0
    else
      (dest translate Half i) map Half := carry + 2^Half:bitsize
      carry := -1
    i := i+1


#----------------------------------------------------------------------
#  generic operations
 

function build  i
  arg_w Intn i
  i bits := null
  i size := 0
  i status := positive


function destroy i
  arg_w Intn i
  memory_free i:bits


function copy src dest
  arg Intn src ; arg_w Intn dest
  src read_lock
  dest resize src:size
  memory_copy src:bits dest:bits src:size*uInt:size
  src read_unlock
  dest status := src:status .and. (positive .or. undefinedn)


function compare a b -> r
  arg Intn a b ; arg Int r
  if (a:status .and. undefinedn)<>0 or (b:status .and. undefinedn)<>0
    return (shunt (a:status .and. undefinedn)=(b:status .and. undefinedn) compare_equal (a:status .and. undefinedn)<>0 compare_inferior compare_superior)
  var uInt pa := a read_lock ; var uInt pb := b read_lock
  if pa<>pb
    r := shunt pa<>0 compare_superior compare_inferior
  else
    r := (unsigned_compare a b) .xor. (shunt pa=positive 0 compare_inferior+compare_superior)
  a read_unlock ; b read_unlock


#----------------------------------------------------------------------
#  + - *


function '+' a b -> r
  arg Intn a b r
  has_no_side_effect
  var uInt pa := a read_lock ; var uInt pb := b read_lock
  if pa=pb
    r status := pa
    var Int n := (max a:size b:size)+1
    a extend n ; b extend n ; r resize n
    add a:bits b:bits r:bits n
  eif (unsigned_compare a b)<>compare_inferior
    r status := pa
    var Int n := a size
    b extend n ; r resize n
    sub a:bits b:bits r:bits n
  else
    r status := pb
    var Int n := b size
    a extend n ; r resize n
    sub b:bits a:bits r:bits n
  a read_unlock ; b read_unlock
  r shrink


function '-' a b -> r
  arg Intn a b r
  has_no_side_effect
  var uInt pa := a read_lock ; var uInt pb := b read_lock
  if pa<>pb
    r status := pa
    var Int n := (max a:size b:size)+1
    a extend n ; b extend n ; r resize n
    add a:bits b:bits r:bits n
  eif (unsigned_compare a b)<>compare_inferior
    r status := pa
    var Int n := a size
    b extend n ; r resize n
    sub a:bits b:bits r:bits n
  else
    r status := positive-pb
    var Int n := b size
    a extend n ; r resize n
    sub b:bits a:bits r:bits n
  a read_unlock ; b read_unlock
  r shrink


function '*' a b -> r
  arg Intn a b r
  has_no_side_effect
  var uInt pa := a read_lock ; var uInt pb := b read_lock
  r zresize a:size+b:size
  r status := shunt pa=pb positive 0
  for (var Int i) 0 2*b:size-1
    add_mul a:bits (r:bits translate Half i) a:size ((b:bits translate Half i) map Half)
  a read_unlock ; b read_unlock
  r shrink


function divide a b q r
  arg Intn a b ; arg_w Intn q r
  has_no_side_effect
  check b:size<>0 "Attempted to divide by 0"
  var uInt pa := a read_lock ; var uInt pb := b read_lock
  if b:size<>1 or (b:bits map uInt)>=2^Half:bitsize
    var Int s := a:nbbits-b:nbbits
    r := a
    if s>=0
      b extend b:size+1
      q zresize s\uInt:bitsize+1 ; q status := shunt pa=pb positive 0
      r extend2 r:size+1
      for (var Int i) s 0 step -1
        if (unsigned_compare_shifted r b i)<>compare_inferior
          q set_bit i
          sub_shifted b:bits r:bits b:size i
          # check (unsigned_compare_shifted r b i)=compare_inferior
      r shrink
    else
      q resize 0
    q shrink
  else
    var uInt d := b:bits map uInt
    var uInt carry := 0
    q resize a:size ; q status := shunt pa=pb positive 0
    for (var Int i) 2*a:size-1 0 step -1
      carry := carry*2^Half:bitsize + ((a:bits translate Half i) map Half)
      (q:bits translate Half i) map Half := carry\d
      carry := carry%d
    q shrink
    if carry=0
      r resize 0 ; r status := positive
    else
      r resize 1 ; r:bits map uInt := carry ; r status := pa
  check (unsigned_compare r b)=compare_inferior
  a read_unlock ; b read_unlock


function '\' a b -> q
  arg Intn a b q
  has_no_side_effect
  var Intn r t
  if addressof:q<>addressof:a and addressof:q<>addressof:b
    divide a b q r
  else
    t := a\b
    q := t


function '%' a b -> r ## section "remain"
  arg Intn a b r
  has_no_side_effect
  var Intn q t
  if addressof:r<>addressof:a and addressof:r<>addressof:b
    divide a b q r
  else
    t := a%b
    r := t


#----------------------------------------------------------------------
#  casting


function 'cast Intn' i -> j
  arg Int i ; arg Intn j
  extension ; has_no_side_effect
  if i=undefined
    j resize 0 ; j status := undefinedn
  eif i=0
    j resize 0 ; j status := positive
  eif i>0
    j resize 1 ; j:bits map uInt := cast i uInt ; j status := positive
  else
    j resize 1 ; j:bits map uInt := cast -i uInt ; j status := 0


function 'cast Int' i -> j
  arg Intn i ; arg Int j
  reduction ; has_no_side_effect
  if i:size=0
    if (i:status .and. undefinedn)<>0
      j := undefined
    else
      j := 0
  eif i:size=1 and ((i:bits map uInt) .and. 2^(uInt:bitsize-1))=0
    var uInt p := i read_lock
    j := shunt p=positive (i:bits map uInt) -(i:bits map uInt)
    i read_unlock
  else
    error error_id_arithmetic "The value is too large to fit in an integer"


function 'cast Intn' i -> j
  arg uInt i ; arg Intn j
  extension ; has_no_side_effect
  if i=0
    j resize 0 ; j status := positive
  else
    j resize 1 ; j:bits map uInt := i ; j status := positive


function 'cast uInt' i -> j
  arg Intn i ; arg uInt j
  reduction ; has_no_side_effect
  if i:size=0
    j := 0
  eif i:size=1
    var uInt p := i read_lock
    if p<>positive
      error error_id_unexpected "The integer is negative"
    j := i:bits map uInt
    i read_unlock
  else
    error error_id_arithmetic "The value is too large to fit in an integer"


function 'cast Float' n -> f
  arg Intn n ; arg Float f
  explicit
  f := 0
  var Intn r := n ; var Float d := 1
  while r<(-(2^30)) or r>2^30
    f += (cast r%2^15 Int)*d
    r \= 2^15 ; d *= 2^15
  f += (cast r Int)*d
    

#----------------------------------------------------------------------
#  ^


method x apply_modulus m
  arg_rw Intn x ; arg Intn m
  check m>0 "Modulus value must be positive"
  m read_lock
  var Int s := x:nbbits - m:nbbits
  if s>=0
    x extend2 x:size+1
    m extend m:size+1
    for (var Int i) s 0 step -1
      if (unsigned_compare_shifted x m i)<>compare_inferior
        sub_shifted m:bits x:bits m:size i
        x shrink
        # check (unsigned_compare_shifted x m i)=compare_inferior
  check (unsigned_compare x m)=compare_inferior
  m read_unlock


function power_modulus a b m -> r
  arg Intn a b m r
  has_no_side_effect
  check addressof:m=null or m>0 "Modulus value must be positive"
  r := 1 ; var Intn p := a
  var Int n := b nbbits
  for (var Int i) 0 n-1
    if (b test_bit i)
      r := r*p
      if addressof:m<>null
        r apply_modulus m
    if i=n-1
      return
    p := p*p
    if addressof:m<>null
      p apply_modulus m


function '^' a b -> r
  arg Intn a b r
  has_no_side_effect
  r := power_modulus a b (null map Intn)


meta '%' e
  strong_definition
  if e:size<>2
    return
  e:0 compile ?
  e:1 compile ?
  var Link:Instruction i :> e:0:instructions:last map Instruction
  if addressof:i=null or (addressof i:function)<>addressof:(the_function '^' Intn Intn -> Intn)
    return
  if (addressof e:0:result)<>(addressof i:2)
    return
  if not (e:1 cast Intn)
    return
  # console "found x^y%n at "+e:position+"[lf]"
  i size := 4
  i 3 :> i 2
  i 2 :> e:1:result
  i function :> the_function power_modulus Intn Intn Intn -> Intn
  e suckup e:1 ; e suckup e:0
  e set_result e:0:result access_read


#--------------------------------------------------------------------


function 'cast Status' i -> s
  arg Intn i ; arg Status s
  explicit
  if (i:status .and. undefinedn)<>0
    s := undefined
  else
    s := defined

function 'cast Intn' s -> i
  arg Status s ; arg Intn i
  extension
  if pliant_debugging_level>=2
    if s<>undefined
      error error_id_unexpected "Unexpected Status value"
  i resize 0
  i status := undefinedn


#----------------------------------------------------------------------


function to_string i -> s
  arg Intn i ; arg Str s
  has_no_side_effect
  if i:size=0
    s := "0"
  eif i:size=1 and (i:bits map uInt)<2^(Int:bitsize-1)
    s := 'convert to string' (cast i Int)
  eif false # faster, but does not worse the extra complexity
    var Int reserved := i:nbbits\3+2
    var Address buffer := memory_allocate reserved null
    var Address cursor := buffer translate Byte reserved
    var Intn cur := i
    while cur:size>1 or (cur:bits map uInt)>=2^(Int:bitsize-1)
      divide cur 10000 (var Intn remain) (var Intn r)
      var Str temp := right ('convert to string' (cast r Int)) 4 "0"
      cursor := cursor translate Byte -4
      memory_copy temp:characters cursor 4
      cur := remain
    temp := 'convert to string' (cast cur Int)
    cursor := cursor translate Byte -(temp:len)
    memory_copy temp:characters cursor temp:len
    if p=0
      cursor := cursor translate uInt8 -1
      cursor map uInt8 := "-":number
    var Int length := (cast buffer Int) .+. reserved .-. (cast cursor Int)
    check length<=reserved
    var Address final := memory_allocate length addressof:s
    memory_copy cursor final length
    s set final length true
    memory_free buffer
  else
    s := ""
    var Intn cur := i
    while cur:size>1 or (cur:bits map uInt)>=2^(Int:bitsize-1)
      divide cur 10000 (var Intn remain) (var Intn r)
      s := (right ('convert to string' (cast r Int)) 4 "0")+s
      cur := remain
    s := ('convert to string' (cast cur Int))+s
    

method data 'to string' options -> string
  arg Intn data ; arg Str options ; arg Str string
  if (data:status .and. undefinedn)<>0
    return (shunt options="db" "" "?")
    return (shunt options="db" or options="raw" "" "?")
  string := to_string data
  if options:len<>0 and { var Str sep := options option "separated" Str ; sep:len=1 }
    var Int newlen := string:len+(string:len-1)\3
    var Address buf := memory_allocate newlen null
    var Address stop := string:characters translate Char -1
    var Address src := stop translate Char string:len
    var Address dest := buf translate Char newlen-1
    var Int r := 3
    while src<>stop
      if r=0
        dest map Char := sep 0
        dest := dest translate Byte -1
        r := 3
      dest map Char := src map Char
      src := src translate Byte -1
      dest := dest translate Byte -1
      r := r-1
    string set buf newlen true

method data 'from string' string options may_skip skiped offset -> status
  arg_w Intn data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
  var Int stop := string:len-1
  if not may_skip and stop<>(-1)
    stop := 0
  for (var Int i) 0 stop
    var Int c0 := string:i number
    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)
      skiped := i
      if c0="?":0:number
        data := undefined
        offset := i+1
        return success
      data := 0 ; var Int sign := 1
      if c0="-":0:number
        sign := -1
        i := i+1
      while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number
        data := data*10 + string:i:number-"0":0:number
        i := i+1
      data := data * sign
      offset := i
      return success
    eif c0="?":0:number
      data := undefined
      skiped := i
      offset := i+1
      return success
  data := undefined
  status := failure
  status := shunt string="" and (options="db" or options="raw") success failure


function parse_intn context line parameter
  arg_rw ParserContext context ; arg Str line ; arg Address parameter
  if (from_string addressof:(var Intn data) Intn line "" false (var Int skip) (var Int offset))=failure
    return
  if line:0:number="-":0:number or line:0:number="?":0:number
    return
  if offset=line:len or line:offset:number<>"n":0:number
    return
  if offset+1<>line:len and line:(offset+1):isidentcharacter
    return
  var Link:Intn i :> new Intn
  i := data
  context add_token addressof:i
  context forward offset+1

gvar ParserFilter intn_filter
intn_filter function :> the_function parse_intn ParserContext Str Address
constant 'pliant parser basic types' intn_filter
export 'pliant parser basic types'


#----------------------------------------------------------------------


method i binary_encode -> s
  arg Intn i ; arg Str s
  var Int sign := shunt i:read_lock=positive 0 1
  var Int l := (i:nbbits+7)\8
  s set (memory_allocate l+sign addressof:s) l+sign true
  memory_copy i:bits s:characters l
  if sign<>0
    s l := character 0
  i read_unlock

method i binary_decode s always_positive
  arg_w Intn i ; arg Str s ; arg CBool always_positive
  var Int l := s len ; var uInt stat := positive
  if not always_positive and l>0 and (s l-1):number=0
    stat := 0 ; l -= 1
  i resize (l+uInt:size-1)\uInt:size ; i status := stat
  if i:size>0
    (i:bits translate uInt i:size-1) map uInt := 0
  memory_copy s:characters i:bits s:len
  i shrink


#----------------------------------------------------------------------


export Intn '. nbbits' '+' '-' '*' '\' '%' '^'
export 'cast Intn' 'cast Int' 'cast uInt' 'cast Float' compare
export '. apply_modulus' '. binary_encode' '. binary_decode'

alias '. please read_lock' '. read_lock'
export '. please read_lock'

alias '. please read_unlock' '. read_unlock'
export '. please read_unlock'

alias '. please resize' '. resize'
export '. please resize'

alias '. please shrink' '. shrink'
export '. please shrink'

alias '. please bits' '. bits'
export '. please bits'

alias '. please size' '. size'
export '. please size'

alias '. please status' '. status'
export '. please status'

alias 'please positive' positive
export 'please positive'