| |
| /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 := i 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 := i get_status | |
| 64 |
if (status .and. read_locks+write_locked)=0 | |
| 65 |
i status := status+write_locked | |
| 66 |
return | |
| 67 |
else | |
| 68 |
i status := status | |
| 69 |
os_yield | |
| 70 |
| |
| 71 |
method i write_unlock | |
| 72 |
arg_rw Intn i | |
| 73 |
i 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 |
i 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 |
i read_unlock | |
| 85 |
(addressof:i map Intn) write_lock | |
| 86 |
(addressof:i map Intn) extend2 n | |
| 87 |
(addressof:i map Intn) write_unlock | |
| 88 |
i 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 |
i bits := memory_zresize i:bits n*uInt:size addressof:i | |
| 97 |
i 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 |
i bits := memory_zresize i:bits n*uInt:size addressof:i | |
| 105 |
i size := n | |
| 106 |
| |
| 107 |
| |
| 108 |
method i shrink | |
| 109 |
arg_rw Intn i | |
| 110 |
while i:size>0 and ((i:bits translate uInt i:size-1) map uInt)=0 | |
| 111 |
i size := i:size-1 | |
| 112 |
if i:size=0 | |
| 113 |
i 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 |
n := shunt i=0 0 i<2 1 i<4 2 i<8 3 4 | |
| 124 |
eif i<2^8 | |
| 125 |
n := 4+(i\2^4 nbbits) | |
| 126 |
eif i<2^16 | |
| 127 |
n := 8+(i\2^8 nbbits) | |
| 128 |
else | |
| 129 |
n := 16+(i\2^16 nbbits) | |
| 130 |
| |
| 131 |
method i nbbits -> n | |
| 132 |
arg Intn i ; arg Int n | |
| 133 |
if i:size<>0 | |
| 134 |
n := (i:size-1)*uInt:bitsize + ((i:bits translate uInt i:size-1) map uInt):nbbits | |
| 135 |
else | |
| 136 |
n := 0 | |
| 137 |
| |
| 138 |
| |
| 139 |
method i set_bit u | |
| 140 |
arg_rw Intn i ; arg Int u | |
| 141 |
check u>=0 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>=0 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 a 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 a b r ; arg Int size | |
| 175 |
var uInt carry := 0 | |
| 176 |
for (var Int i) 0 2*size-1 | |
| 177 |
carry := carry + ((a translate Half i) map Half) + ((b translate Half i) map Half) | |
| 178 |
if carry<2^Half:bitsize | |
| 179 |
(r translate Half i) map Half := carry | |
| 180 |
carry := 0 | |
| 181 |
else | |
| 182 |
(r 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 a b r ; arg Int size | |
| 189 |
var Int carry := 0 | |
| 190 |
for (var Int i) 0 2*size-1 | |
| 191 |
carry := carry + ((a translate Half i) map Half) - ((b translate Half i) map Half) | |
| 192 |
if carry>=0 | |
| 193 |
(r translate Half i) map Half := carry | |
| 194 |
carry := 0 | |
| 195 |
else | |
| 196 |
(r 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) 0 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 i := 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 := 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>=0 and u<i:size | |
| 223 |
r := (i:bits translate uInt u) map uInt | |
| 224 |
else | |
| 225 |
r := 0 | |
| 226 |
| |
| 227 |
| |
| 228 |
function do_shift low high shift -> result | |
| 229 |
arg uInt low high result ; arg Int shift | |
| 230 |
check shift>=0 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 |
r := i:size+(shift+uInt:bitsize-1)\uInt:bitsize | |
| 240 |
| |
| 241 |
| |
| 242 |
method i bloc_shifted u shift -> r | |
| 243 |
arg Intn i ; arg Int u shift ; arg uInt r | |
| 244 |
var Int t := u.-.shift\uInt:bitsize | |
| 245 |
var Int s := shift%uInt:bitsize | |
| 246 |
r := do_shift (i bloc t.-.1) (i bloc t) s | |
| 247 |
| |
| 248 |
| |
| 249 |
function unsigned_compare_shifted1 a b b_shift -> r | |
| 250 |
arg Intn a b ; arg Int b_shift ; arg Int r | |
| 251 |
for (var Int i) (max a:size (b size_shifted b_shift))-1 0 step -1 | |
| 252 |
var uInt ai := a bloc i | |
| 253 |
var uInt bi := b bloc_shifted i 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 t := src_shift\uInt:bitsize | |
| 306 |
var Int s := src_shift%uInt:bitsize | |
| 307 |
var Int carry := 0 | |
| 308 |
for (var Int i) 0 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 i := 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 := i+1 | |
| 321 |
| |
| 322 |
| |
| 323 |
| |
| 324 |
# generic operations | |
| 325 |
| |
| 326 |
| |
| 327 |
function build i | |
| 328 |
arg_w Intn i | |
| 329 |
i bits := null | |
| 330 |
i size := 0 | |
| 331 |
i 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 a b ; arg Int r | |
| 350 |
if (a:status .and. undefinedn)<>0 or (b:status .and. undefinedn)<>0 | |
| 351 |
return ( |