bignums.c

   1 /* file: "bignums.c" */
   2
   3 /*
   4  * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
   5  */
   6
   7 #include "picobit-vm.h"
   8
   9 #ifdef INFINITE_PRECISION_BIGNUMS
  10
  11 integer make_integer (digit lo, integer hi) {
  12   return alloc_ram_cell_init (BIGNUM_FIELD0 | (hi >> 8), hi, lo >> 8, lo);
  13 }
  14
  15 integer integer_hi (integer x) {
  16   if (IN_RAM(x))
  17     return ram_get_car (x);
  18   else if (IN_ROM(x))
  19     return rom_get_car (x);
  20   else if (x < (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
  21     return NEG1; /* negative fixnum */
  22   else
  23     return ZERO; /* nonnegative fixnum */
  24 }
  25
  26 digit integer_lo (integer x) {
  27   uint16 f2;
  28   if (IN_RAM(x)) {
  29     f2 = ram_get_field2 (x);
  30     return (f2 << 8) + ram_get_field3 (x);
  31   }
  32   else if (IN_ROM(x)) {
  33     f2 = rom_get_field2 (x);
  34     return (f2 << 8) + rom_get_field3 (x);
  35   }
  36   else
  37     return DECODE_FIXNUM(x);
  38 }
  39
  40 integer norm (obj prefix, integer n) {
  41   /* norm(prefix,n) returns a normalized integer whose value is the
  42      integer n prefixed with the digits in prefix (a list of digits) */
  43
  44   while (prefix != NIL) {
  45     digit d = integer_lo (prefix);
  46     obj temp = prefix;
  47
  48     prefix = integer_hi (temp);
  49
  50     if (obj_eq (n, ZERO)) {
  51       if (d <= MAX_FIXNUM) {
  52         n = ENCODE_FIXNUM (d & 0xff);
  53         continue;
  54       }
  55     }
  56     else if (obj_eq (n, NEG1)) {
  57       // -1 is an illegal literal in SIXPIC, thus the double negative
  58       if (d >= (1<<digit_width) - (- MIN_FIXNUM)) {
  59         n = ENCODE_FIXNUM (d - (1<<digit_width));
  60         continue;
  61       }
  62     }
  63
  64     integer_hi_set (temp, n);
  65     n = temp;
  66   }
  67
  68   return n;
  69 }
  70
  71 uint8 negp (integer x) {
  72   /* negp(x) returns true iff x is negative */
  73
  74   do {
  75     x = integer_hi (x);
  76     if (obj_eq (x, ZERO)) return false;
  77   } while (!obj_eq (x, NEG1));
  78
  79   return true;
  80 }
  81
  82 uint8 cmp (integer x, integer y) {
  83   /* cmp(x,y) return 0 when x<y, 2 when x>y, and 1 when x=y */
  84
  85   uint8 result = 1;
  86   digit xlo;
  87   digit ylo;
  88
  89   for (;;) {
  90     if (obj_eq (x, ZERO) || obj_eq (x, NEG1)) {
  91       if (!obj_eq (x, y))
  92         { if (negp (y)) result = 2; else result = 0; }
  93       break;
  94     }
  95
  96     if (obj_eq (y, ZERO) || obj_eq (y, NEG1)) {
  97       if (negp (x)) result = 0; else result = 2;
  98       break;
  99     }
 100
 101     xlo = integer_lo (x);
 102     ylo = integer_lo (y);
 103     x = integer_hi (x);
 104     y = integer_hi (y);
 105     if (xlo != ylo)
 106       { if (xlo < ylo) result = 0; else result = 2; }
 107   }
 108   return result;
 109 }
 110
 111 uint16 integer_length (integer x) {
 112   /* integer_length(x) returns the number of bits in the binary
 113      representation of the nonnegative integer x */
 114
 115   uint16 result = 0;
 116   integer next;
 117   digit d;
 118
 119   while (!obj_eq ((next = integer_hi (x)), ZERO)) {
 120     result += digit_width;
 121     x = next;
 122   }
 123
 124   d = integer_lo (x);
 125
 126   while (d > 0) {
 127     result++;
 128     d >>= 1;
 129   }
 130
 131   return result;
 132 }
 133
 134 integer shr (integer x) { // TODO have shift_right
 135   /* shr(x) returns the integer x shifted one bit to the right */
 136
 137   obj result = NIL;
 138   digit d;
 139
 140   for (;;) {
 141     if (obj_eq (x, ZERO) || obj_eq (x, NEG1)) {
 142       result = norm (result, x);
 143       break;
 144     }
 145
 146     d = integer_lo (x);
 147     x = integer_hi (x);
 148     result = make_integer ((d >> 1) |
 149                            ((integer_lo (x) & 1) ? (1 << (digit_width-1)) : 0),
 150                            result);
 151   }
 152
 153   return result;
 154 }
 155
 156 integer negative_carry (integer carry) {
 157   if (carry)
 158     return NEG1;
 159   else
 160     return ZERO;
 161 }
 162
 163 integer shl (integer x) {
 164   /* shl(x) returns the integer x shifted one bit to the left */
 165
 166   integer negc = ZERO; /* negative carry */
 167   integer temp;
 168   obj result = NIL;
 169   digit d;
 170
 171   for (;;) {
 172     if (obj_eq (x, negc)) {
 173       result = norm (result, x);
 174       break;
 175     }
 176
 177     d = integer_lo (x);
 178     x = integer_hi (x);
 179     temp = negc;
 180     negc = negative_carry (d & (1 << (digit_width-1)));
 181     result = make_integer ((d << 1) | obj_eq (temp, NEG1), result);
 182   }
 183
 184   return result;
 185 }
 186
 187 integer shift_left (integer x, uint16 n) {
 188   /* shift_left(x,n) returns the integer x shifted n bits to the left */
 189
 190   if (obj_eq (x, ZERO))
 191     return x;
 192
 193   while (n & (digit_width-1)) {
 194     x = shl (x);
 195     n--;
 196   }
 197
 198   while (n > 0) {
 199     x = make_integer (0, x);
 200     n -= digit_width;
 201   }
 202
 203   return x;
 204 }
 205
 206 integer add (integer x, integer y) {
 207   /* add(x,y) returns the sum of the integers x and y */
 208
 209   integer negc = ZERO; /* negative carry */
 210   obj result = NIL; /* nil terminated for the norm function */
 211   digit dx;
 212   digit dy;
 213
 214   for (;;) {
 215     if (obj_eq (x, negc)) {
 216       result = norm (result, y);
 217       break;
 218     }
 219
 220     if (obj_eq (y, negc)) {
 221       result = norm (result, x);
 222       break;
 223     }
 224
 225     dx = integer_lo (x);
 226     dy = integer_lo (y);
 227     dx = dx + dy; /* may wrap around */
 228
 229     if (obj_eq (negc, ZERO))
 230       negc = negative_carry (dx < dy);
 231     else {
 232       dx++; /* may wrap around */
 233       negc = negative_carry (dx <= dy);
 234     }
 235
 236     x = integer_hi (x);
 237     y = integer_hi (y);
 238
 239     result = make_integer (dx, result);
 240   }
 241
 242   return result;
 243 }
 244
 245 integer invert (integer x) {
 246   if (obj_eq (x, ZERO))
 247     return NEG1;
 248   else
 249     return ZERO;
 250 }
 251
 252 integer sub (integer x, integer y) {
 253   /* sub(x,y) returns the difference of the integers x and y */
 254   integer negc = NEG1; /* negative carry */
 255   obj result = NIL;
 256   digit dx;
 257   digit dy;
 258
 259   for (;;) {
 260     if (obj_eq (x, negc) && (obj_eq (y, ZERO) || obj_eq (y, NEG1))) {
 261       result = norm (result, invert (y));
 262       break;
 263     }
 264
 265     if (obj_eq (y, invert (negc))) {
 266       result = norm (result, x);
 267       break;
 268     }
 269
 270     dx = integer_lo (x);
 271     dy = ~integer_lo (y);
 272     dx = dx + dy; /* may wrap around */
 273
 274     if (obj_eq (negc, ZERO))
 275       negc = negative_carry (dx < dy);
 276     else {
 277       dx++; /* may wrap around */
 278       negc = negative_carry (dx <= dy);
 279     }
 280
 281     x = integer_hi (x);
 282     y = integer_hi (y);
 283
 284     result = make_integer (dx, result);
 285   }
 286
 287   return result;
 288 }
 289
 290 integer scale (digit n, integer x) {
 291   /* scale(n,x) returns the integer n*x */
 292
 293   obj result;
 294   digit carry;
 295   two_digit m;
 296
 297   if ((n == 0) || obj_eq (x, ZERO))
 298     return ZERO;
 299
 300   if (n == 1)
 301     return x;
 302
 303   result = NIL;
 304   carry = 0;
 305
 306   for (;;) {
 307     if (obj_eq (x, ZERO)){
 308       if (carry <= MAX_FIXNUM)
 309         result = norm (result, ENCODE_FIXNUM (carry & 0xff));
 310       else
 311         result = norm (result, make_integer (carry, ZERO));
 312       break;
 313     }
 314
 315     if (obj_eq (x, NEG1)) {
 316       carry = carry - n;
 317       // -1 as a literal is wrong with SIXPIC, thus the double negative
 318       if (carry >= ((1<<digit_width) - (- MIN_FIXNUM)))
 319         result = norm (result, ENCODE_FIXNUM (carry & 0xff));
 320       else
 321         result = norm (result, make_integer (carry, NEG1));
 322       break;
 323     }
 324
 325     m = integer_lo (x);
 326     m = m * n + carry;
 327
 328     x = integer_hi (x);
 329     carry = m >> digit_width;
 330     result = make_integer (m, result);
 331   }
 332
 333   return result;
 334 }
 335
 336 integer mulnonneg (integer x, integer y) {
 337   /* mulnonneg(x,y) returns the product of the integers x and y
 338      where x is nonnegative */
 339
 340   obj result = NIL;
 341   integer s = scale (integer_lo (x), y);
 342
 343   for (;;) {
 344     result = make_integer (integer_lo (s), result);
 345     s = integer_hi (s);
 346     x = integer_hi (x);
 347
 348     if (obj_eq (x, ZERO))
 349       break;
 350
 351     s = add (s, scale (integer_lo (x), y));
 352   }
 353
 354   return norm (result, s);
 355 }
 356
 357 // TODO have functions mul and div that handle negative arguments ? currently, the logic is in prim_mul and prim_div
 358 integer divnonneg (integer x, integer y) {
 359   /* divnonneg(x,y) returns the quotient and remainder of
 360      the integers x and y where x and y are nonnegative */
 361
 362   integer result = ZERO;
 363   uint16 lx = integer_length (x);
 364   uint16 ly = integer_length (y);
 365
 366   if (lx >= ly) {
 367     lx = lx - ly;
 368
 369     y = shift_left (y, lx);
 370
 371     do {
 372       result = shl (result);
 373       if (cmp (x, y) >= 1) {
 374         x = sub (x, y);
 375         result = add (POS1, result);
 376       }
 377       y = shr (y);
 378     } while (lx-- != 0);
 379   }
 380
 381   return result;
 382 }
 383
 384 integer bitwise_ior (integer x, integer y) {
 385   /* returns the bitwise inclusive or of x and y */
 386
 387   obj result = NIL;
 388
 389   for (;;){
 390     if (obj_eq(x, ZERO))
 391       return norm(result, y);
 392     if (obj_eq(x, NEG1))
 393       return norm(result, x);
 394     result = make_integer(integer_lo(x) | integer_lo(y),
 395                           result);
 396     x = integer_hi(x);
 397     y = integer_hi(y);
 398   }
 399 }
 400
 401 integer bitwise_xor (integer x, integer y) { // TODO similar to ior (only diff is the test), abstract ?
 402   /* returns the bitwise inclusive or of x and y */
 403
 404   obj result = NIL;
 405
 406   for (;;){
 407     if (obj_eq(x, ZERO))
 408       return norm(result, y);
 409     if (obj_eq(x, NEG1))
 410       return norm(result, x);
 411     result = make_integer(integer_lo(x) ^ integer_lo(y),
 412                           result);
 413     x = integer_hi(x);
 414     y = integer_hi(y);
 415   }
 416 }
 417
 418 // used only in primitives that use small numbers only
 419 // for example, vector primitives
 420 uint16 decode_int (obj o) {
 421   uint8 result;
 422   if (o < MIN_FIXNUM_ENCODING)
 423     TYPE_ERROR("decode_int.0", "integer");
 424
 425   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 426     return DECODE_FIXNUM(o);
 427
 428   if (IN_RAM(o)) {
 429     if (!RAM_BIGNUM(o))
 430       TYPE_ERROR("decode_int.1", "integer");
 431     return ram_get_field3 (o);
 432   }
 433   else if (IN_ROM(o)) {
 434     if (!ROM_BIGNUM(o))
 435       TYPE_ERROR("decode_int.2", "integer");
 436     return rom_get_field3 (o);
 437   }
 438   else
 439     TYPE_ERROR("decode_int.3", "integer");
 440 }
 441
 442 // same purpose as decode_int
 443 obj encode_int (uint16 n) {
 444   if (n <= MAX_FIXNUM) {
 445     return ENCODE_FIXNUM(n);
 446   }
 447
 448   return alloc_ram_cell_init (BIGNUM_FIELD0, ENCODE_FIXNUM(0), n >> 8, n);
 449 }
 450
 451 #else
 452
 453 // regular (finite, 24 bits) bignums
 454
 455 uint16 decode_int (obj o) {
 456   uint16 u; // TODO should be 32, but is lost anyway since this returns a uint16
 457   uint16 h;
 458   uint8  l;
 459
 460   if (o < MIN_FIXNUM_ENCODING)
 461     TYPE_ERROR("decode_int.0", "integer");
 462
 463   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 464     return DECODE_FIXNUM(o);
 465
 466   if (IN_RAM(o)) {
 467     if (!RAM_BIGNUM(o))
 468       TYPE_ERROR("decode_int.1", "integer");
 469
 470     u = ram_get_field1 (o);
 471     h = ram_get_field2 (o);
 472     l = ram_get_field3 (o);
 473   }
 474   else if (IN_ROM(o)) {
 475     if (!ROM_BIGNUM(o))
 476       TYPE_ERROR("decode_int.2", "integer");
 477
 478     u = rom_get_field1 (o);
 479     h = rom_get_field2 (o);
 480     l = rom_get_field3 (o);
 481   }
 482   else
 483     TYPE_ERROR("decode_int.3", "integer");
 484
 485   if (u >= 128) // negative
 486     return ((((u - 256) << 8) + h) << 8) + l; // TODO ints are all 16 bits, 24 bits won't work
 487
 488   return (((u << 8) + h) << 8) + l;
 489 }
 490
 491 obj encode_int (uint16 n) { // TODO does not use the full 24 bits
 492   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 493     return ENCODE_FIXNUM(n);
 494
 495   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 496 }
 497
 498 #endif
 499
 500 // useful for some primitives
 501 void decode_2_int_args () {
 502   a1 = decode_int (arg1);
 503   a2 = decode_int (arg2);
 504 }