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 neg (integer x) {
 291   /* neg(x) returns the integer -x */
 292
 293   return sub (ZERO, x);
 294 }
 295
 296 integer scale (digit n, integer x) {
 297   /* scale(n,x) returns the integer n*x */
 298
 299   obj result;
 300   digit carry;
 301   two_digit m;
 302
 303   if ((n == 0) || obj_eq (x, ZERO))
 304     return ZERO;
 305
 306   if (n == 1)
 307     return x;
 308
 309   result = NIL;
 310   carry = 0;
 311
 312   for (;;) {
 313     if (obj_eq (x, ZERO)){
 314       if (carry <= MAX_FIXNUM)
 315         result = norm (result, ENCODE_FIXNUM (carry & 0xff));
 316       else
 317         result = norm (result, make_integer (carry, ZERO));
 318       break;
 319     }
 320
 321     if (obj_eq (x, NEG1)) {
 322       carry = carry - n;
 323       // -1 as a literal is wrong with SIXPIC, thus the double negative
 324       if (carry >= ((1<<digit_width) - (- MIN_FIXNUM)))
 325         result = norm (result, ENCODE_FIXNUM (carry & 0xff));
 326       else
 327         result = norm (result, make_integer (carry, NEG1));
 328       break;
 329     }
 330
 331     m = integer_lo (x);
 332     m = m * n + carry;
 333
 334     x = integer_hi (x);
 335     carry = m >> digit_width;
 336     result = make_integer (m, result);
 337   }
 338
 339   return result;
 340 }
 341
 342 integer mulnonneg (integer x, integer y) {
 343   /* mulnonneg(x,y) returns the product of the integers x and y
 344      where x is nonnegative */
 345
 346   obj result = NIL;
 347   integer s = scale (integer_lo (x), y);
 348
 349   for (;;) {
 350     result = make_integer (integer_lo (s), result);
 351     s = integer_hi (s);
 352     x = integer_hi (x);
 353
 354     if (obj_eq (x, ZERO))
 355       break;
 356
 357     s = add (s, scale (integer_lo (x), y));
 358   }
 359
 360   return norm (result, s);
 361 }
 362
 363 // TODO have functions mul and div that handle negative arguments ? currently, the logic is in prim_mul and prim_div
 364 integer divnonneg (integer x, integer y) {
 365   /* divnonneg(x,y) returns the quotient and remainder of
 366      the integers x and y where x and y are nonnegative */
 367
 368   integer result = ZERO;
 369   uint16 lx = integer_length (x);
 370   uint16 ly = integer_length (y);
 371
 372   if (lx >= ly) {
 373     lx = lx - ly;
 374
 375     y = shift_left (y, lx);
 376
 377     do {
 378       result = shl (result);
 379       if (cmp (x, y) >= 1) {
 380         x = sub (x, y);
 381         result = add (POS1, result);
 382       }
 383       y = shr (y);
 384     } while (lx-- != 0);
 385   }
 386
 387   return result;
 388 }
 389
 390 integer bitwise_ior (integer x, integer y) {
 391   /* returns the bitwise inclusive or of x and y */
 392
 393   obj result = NIL;
 394
 395   for (;;){
 396     if (obj_eq(x, ZERO))
 397       return norm(result, y);
 398     if (obj_eq(x, NEG1))
 399       return norm(result, x);
 400     result = make_integer(integer_lo(x) | integer_lo(y),
 401                           result);
 402     x = integer_hi(x);
 403     y = integer_hi(y);
 404   }
 405 }
 406
 407 integer bitwise_xor (integer x, integer y) { // TODO similar to ior (only diff is the test), abstract ?
 408   /* returns the bitwise inclusive or of x and y */
 409
 410   obj result = NIL;
 411
 412   for (;;){
 413     if (obj_eq(x, ZERO))
 414       return norm(result, y);
 415     if (obj_eq(x, NEG1))
 416       return norm(result, x);
 417     result = make_integer(integer_lo(x) ^ integer_lo(y),
 418                           result);
 419     x = integer_hi(x);
 420     y = integer_hi(y);
 421   }
 422 }
 423
 424 // used only in primitives that use small numbers only
 425 // for example, vector primitives
 426 uint16 decode_int (obj o) {
 427   uint8 result;
 428   if (o < MIN_FIXNUM_ENCODING)
 429     TYPE_ERROR("decode_int.0", "integer");
 430
 431   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 432     return DECODE_FIXNUM(o);
 433
 434   if (IN_RAM(o)) {
 435     if (!RAM_BIGNUM(o))
 436       TYPE_ERROR("decode_int.1", "integer");
 437     return ram_get_field3 (o);
 438   }
 439   else if (IN_ROM(o)) {
 440     if (!ROM_BIGNUM(o))
 441       TYPE_ERROR("decode_int.2", "integer");
 442     return rom_get_field3 (o);
 443   }
 444   else
 445     TYPE_ERROR("decode_int.3", "integer");
 446 }
 447
 448 // same purpose as decode_int
 449 obj encode_int (uint16 n) {
 450   if (n <= MAX_FIXNUM) {
 451     return ENCODE_FIXNUM(n);
 452   }
 453
 454   return alloc_ram_cell_init (BIGNUM_FIELD0, ENCODE_FIXNUM(0), n >> 8, n);
 455 }
 456
 457 #else
 458
 459 // regular (finite, 24 bits) bignums
 460
 461 uint16 decode_int (obj o) {
 462   uint16 u; // TODO should be 32, but is lost anyway since this returns a uint16
 463   uint16 h;
 464   uint8  l;
 465
 466   if (o < MIN_FIXNUM_ENCODING)
 467     TYPE_ERROR("decode_int.0", "integer");
 468
 469   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 470     return DECODE_FIXNUM(o);
 471
 472   if (IN_RAM(o)) {
 473     if (!RAM_BIGNUM(o))
 474       TYPE_ERROR("decode_int.1", "integer");
 475
 476     u = ram_get_field1 (o);
 477     h = ram_get_field2 (o);
 478     l = ram_get_field3 (o);
 479   }
 480   else if (IN_ROM(o)) {
 481     if (!ROM_BIGNUM(o))
 482       TYPE_ERROR("decode_int.2", "integer");
 483
 484     u = rom_get_field1 (o);
 485     h = rom_get_field2 (o);
 486     l = rom_get_field3 (o);
 487   }
 488   else
 489     TYPE_ERROR("decode_int.3", "integer");
 490
 491   if (u >= 128) // negative
 492     return ((((u - 256) << 8) + h) << 8) + l; // TODO ints are all 16 bits, 24 bits won't work
 493
 494   return (((u << 8) + h) << 8) + l;
 495 }
 496
 497 obj encode_int (uint16 n) { // TODO does not use the full 24 bits
 498   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 499     return ENCODE_FIXNUM(n);
 500
 501   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 502 }
 503
 504 #endif
 505
 506 // useful for some primitives
 507 void decode_2_int_args () {
 508   a1 = decode_int (arg1);
 509   a2 = decode_int (arg2);
 510 }