big.c - picolisp - Unnamed repository; edit this file to name it for gitweb.

big.c (27268B)
      1 /* 08sep11abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 #define MAX    MASK           // Max digit size    0xFFFF....
      8 #define OVFL   ((1<<BITS-1))  // Carry/Overflow    0x8000....
      9 
     10 
     11 static void divErr(any ex) {err(ex,NULL,"Div/0");}
     12 
     13 /* Box double word */
     14 any boxWord2(word2 t) {
     15    cell c1;
     16 
     17    Push(c1, hi(t)? consNum(num(t), box(hi(t))) : box(num(t)));
     18    digMul2(data(c1));
     19    return Pop(c1);
     20 }
     21 
     22 word2 unBoxWord2(any x) {
     23    word2 n = unDig(x);
     24 
     25    if (isNum(x = cdr(numCell(x))))
     26       n = n << BITS + unDig(x);
     27    return n / 2;
     28 }
     29 
     30 /* Bignum copy */
     31 any bigCopy(any x) {
     32    any y;
     33    cell c1, c2;
     34 
     35    Push(c1, x);
     36    Push(c2, y = box(unDig(x)));
     37    while (isNum(x = cdr(numCell(x))))
     38       y = cdr(numCell(y)) = box(unDig(x));
     39    drop(c1);
     40    return data(c2);
     41 }
     42 
     43 /* Remove leading zero words */
     44 void zapZero(any x) {
     45    any r = x;
     46 
     47    while (isNum(x = cdr(numCell(x))))
     48       if (unDig(x))
     49          r = x;
     50    cdr(numCell(r)) = x;
     51 }
     52 
     53 /* Multiply a (positive) bignum by 2 */
     54 void digMul2(any x) {
     55    any y;
     56    word n, carry;
     57 
     58    n = unDig(x),  setDig(x, n + n),  carry = n & OVFL;
     59    while (isNum(x = cdr(numCell(y = x)))) {
     60       n = unDig(x);
     61       setDig(x, n + n + (carry? 1 : 0));
     62       carry = n & OVFL;
     63    }
     64    if (carry)
     65       cdr(numCell(y)) = box(1);
     66 }
     67 
     68 /* Shift right by one bit */
     69 void digDiv2(any x) {
     70    any r, y;
     71 
     72    r = NULL;
     73    setDig(x, unDig(x) / 2);
     74    while (isNum(x = cdr(numCell(y = x)))) {
     75       if (unDig(x) & 1)
     76          setDig(y, unDig(y) | OVFL);
     77       setDig(x, unDig(x) / 2);
     78       r = y;
     79    }
     80    if (r  &&  unDig(y) == 0)
     81       cdr(numCell(r)) = x;
     82 }
     83 
     84 /* Add two (positive) bignums */
     85 void bigAdd(any dst, any src) {
     86    any x;
     87    word n, carry;
     88 
     89    carry = (unDig(src) & ~1) > num(setDig(dst, (unDig(src) & ~1) + (unDig(dst) & ~1)));
     90    src = cdr(numCell(src));
     91    dst = cdr(numCell(x = dst));
     92    for (;;) {
     93       if (!isNum(src)) {
     94          while (isNum(dst)) {
     95             if (!carry)
     96                return;
     97             carry = 0 == num(setDig(dst, 1 + unDig(dst)));
     98             dst = cdr(numCell(x = dst));
     99          }
    100          break;
    101       }
    102       if (!isNum(dst)) {
    103          do {
    104             carry = unDig(src) > (n = carry + unDig(src));
    105             x = cdr(numCell(x)) = box(n);
    106          } while (isNum(src = cdr(numCell(src))));
    107          break;
    108       }
    109       if ((n = carry + unDig(src)) >= carry) {
    110          carry = unDig(dst) > (n += unDig(dst));
    111          setDig(dst,n);
    112       }
    113       src = cdr(numCell(src));
    114       dst = cdr(numCell(x = dst));
    115    }
    116    if (carry)
    117       cdr(numCell(x)) = box(1);
    118 }
    119 
    120 /* Add digit to a (positive) bignum */
    121 void digAdd(any x, word n) {
    122    any y;
    123    word carry;
    124 
    125    carry = n > num(setDig(x, n + unDig(x)));
    126    while (carry) {
    127       if (isNum(x = cdr(numCell(y = x))))
    128          carry = 0 == num(setDig(x, 1 + unDig(x)));
    129       else {
    130          cdr(numCell(y)) = box(1);
    131          break;
    132       }
    133    }
    134 }
    135 
    136 /* Subtract two (positive) bignums */
    137 void bigSub(any dst, any src) {
    138    any x, y;
    139    word n, borrow;
    140 
    141    borrow = MAX - (unDig(src) & ~1) < num(setDig(dst, (unDig(dst) & ~1) - (unDig(src) & ~1)));
    142    y = dst;
    143    for (;;) {
    144       src = cdr(numCell(src));
    145       dst = cdr(numCell(x = dst));
    146       if (!isNum(src)) {
    147          while (isNum(dst)) {
    148             if (!borrow)
    149                return;
    150             borrow = MAX == num(setDig(dst, unDig(dst) - 1));
    151             dst = cdr(numCell(x = dst));
    152          }
    153          break;
    154       }
    155       if (!isNum(dst)) {
    156          do {
    157             if (borrow)
    158                n = MAX - unDig(src);
    159             else
    160                borrow = 0 != (n = -unDig(src));
    161             x = cdr(numCell(x)) = box(n);
    162          } while (isNum(src = cdr(numCell(src))));
    163          break;
    164       }
    165       if ((n = unDig(dst) - borrow) > MAX - borrow)
    166          setDig(dst, MAX - unDig(src));
    167       else
    168          borrow = num(setDig(dst, n - unDig(src))) > MAX - unDig(src);
    169    }
    170    if (borrow) {
    171       dst = y;
    172       borrow = 0 != (n = -unDig(dst));
    173       setDig(dst, n | 1);  /* Negate */
    174       while (dst != x) {
    175          dst = cdr(numCell(dst));
    176          if (borrow)
    177             setDig(dst, MAX - unDig(dst));
    178          else
    179             borrow = 0 != num(setDig(dst, -unDig(dst)));
    180       }
    181    }
    182    if (unDig(x) == 0)
    183       zapZero(y);
    184 }
    185 
    186 /* Subtract 1 from a (positive) bignum */
    187 void digSub1(any x) {
    188    any r, y;
    189    word borrow;
    190 
    191    r = NULL;
    192    borrow = MAX-1 == num(setDig(x, unDig(x) - 2));
    193    while (isNum(x = cdr(numCell(y = x)))) {
    194       if (!borrow)
    195          return;
    196       borrow = MAX == num(setDig(x, unDig(x) - 1));
    197       r = y;
    198    }
    199    if (r  &&  unDig(y) == 0)
    200       cdr(numCell(r)) = x;
    201 }
    202 
    203 /* Multiply two (positive) bignums */
    204 static any bigMul(any x1, any x2) {
    205    any x, y, z;
    206    word n, carry;
    207    word2 t;
    208    cell c1;
    209 
    210    Push(c1, x = y = box(0));
    211    for (;;) {
    212       n = unDig(x2) / 2;
    213       if (isNum(x2 = cdr(numCell(x2)))  &&  unDig(x2) & 1)
    214          n |= OVFL;
    215       t = (word2)n * unDig(z = x1);  // x += n * x1
    216       carry = (lo(t) > num(setDig(y, unDig(y) + lo(t)))) + hi(t);
    217       while (isNum(z = cdr(numCell(z)))) {
    218          if (!isNum(cdr(numCell(y))))
    219             cdr(numCell(y)) = box(0);
    220          y = cdr(numCell(y));
    221          t = (word2)n * unDig(z);
    222          carry = carry > num(setDig(y, carry + unDig(y)));
    223          if (lo(t) > num(setDig(y, unDig(y) + lo(t))))
    224             ++carry;
    225          carry += hi(t);
    226       }
    227       if (carry)
    228          cdr(numCell(y)) = box(carry);
    229       if (!isNum(x2))
    230          break;
    231       if (!isNum(y = cdr(numCell(x))))
    232          y = cdr(numCell(x)) = box(0);
    233       x = y;
    234    } while (isNum(x2));
    235    zapZero(data(c1));
    236    return Pop(c1);
    237 }
    238 
    239 /* Multiply digit with a (positive) bignum */
    240 void digMul(any x, word n) {
    241    word2 t;
    242    any y;
    243 
    244    t = (word2)n * unDig(x);
    245    for (;;) {
    246       setDig(x, num(t));
    247       t = hi(t);
    248       if (!isNum(x = cdr(numCell(y = x))))
    249          break;
    250       t += (word2)n * unDig(x);
    251    }
    252    if (t)
    253       cdr(numCell(y)) = box(num(t));
    254 }
    255 
    256 /* (Positive) Bignum comparison */
    257 static int bigCmp(any x, any y) {
    258    int res;
    259    any x1, y1, x2, y2;
    260 
    261    x1 = y1 = Nil;
    262    for (;;) {
    263       if ((x2 = cdr(numCell(x))) == (y2 = cdr(numCell(y)))) {
    264          for (;;) {
    265             if (unDig(x) < unDig(y)) {
    266                res = -1;
    267                break;
    268             }
    269             if (unDig(x) > unDig(y)) {
    270                res = +1;
    271                break;
    272             }
    273             if (!isNum(x1))
    274                return 0;
    275             x2 = cdr(numCell(x1)),  cdr(numCell(x1)) = x,  x = x1,  x1 = x2;
    276             y2 = cdr(numCell(y1)),  cdr(numCell(y1)) = y,  y = y1,  y1 = y2;
    277          }
    278          break;
    279       }
    280       if (!isNum(x2)) {
    281          res = -1;
    282          break;
    283       }
    284       if (!isNum(y2)) {
    285          res = +1;
    286          break;
    287       }
    288       cdr(numCell(x)) = x1,  x1 = x,  x = x2;
    289       cdr(numCell(y)) = y1,  y1 = y,  y = y2;
    290    }
    291    while (isNum(x1)) {
    292       x2 = cdr(numCell(x1)),  cdr(numCell(x1)) = x,  x = x1,  x1 = x2;
    293       y2 = cdr(numCell(y1)),  cdr(numCell(y1)) = y,  y = y1,  y1 = y2;
    294    }
    295    return res;
    296 }
    297 
    298 /* Divide two (positive) bignums (Knuth Vol.2, p.257) */
    299 static any bigDiv(any u, any v, bool rem) {
    300    int m, n, d, i;
    301    word q, v1, v2, u1, u2, u3, borrow;
    302    word2 t, r;
    303    any x, y, z;
    304    cell c1;
    305 
    306    digDiv2(u),  digDiv2(v);                                 // Normalize
    307    for (m = 0, z = u;  isNum(y = cdr(numCell(z)));  ++m, z = y);
    308    x = v,  y = NULL,  n = 1;
    309    while (isNum(cdr(numCell(x))))
    310       y = x,  x = cdr(numCell(x)),  ++n,  --m;
    311    if (m < 0) {
    312       if (rem)
    313          digMul2(u);
    314       return box(0);
    315    }
    316    cdr(numCell(z)) = box(0);
    317    for (d = 0;  (unDig(x) & OVFL) == 0;  ++d)
    318       digMul2(u),  digMul2(v);
    319    v1 = unDig(x);
    320    v2 = y? unDig(y) : 0;
    321    Push(c1, Nil);
    322    do {
    323       for (i = m, x = u;  --i >= 0;  x = cdr(numCell(x)));  // Index x -> u
    324       i = n;
    325       y = x;
    326       u1 = u2 = 0;
    327       do
    328          u3 = u2,  u2 = u1,  u1 = unDig(y),  y = cdr(numCell(y));
    329       while (--i >= 0);
    330 
    331       t = ((word2)u1 << BITS) + u2;                         // Calculate q
    332       q = u1 == v1? MAX : t / v1;
    333       r = t - (word2)q*v1;
    334       while (r <= MAX  &&  (word2)q*v2 > (r << BITS) + u3)
    335          --q,  r += v1;
    336 
    337       z = x;                                                // x -= q*v
    338       t = (word2)q * unDig(y = v);
    339       borrow = (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t)))) + hi(t);
    340       while (isNum(y = cdr(numCell(y)))) {
    341          z = cdr(numCell(z));
    342          t = (word2)q * unDig(y);
    343          borrow = MAX - borrow < num(setDig(z, unDig(z) - borrow));
    344          if (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t))))
    345             ++borrow;
    346          borrow += hi(t);
    347       }
    348       if (borrow) {
    349          z = cdr(numCell(z));
    350          if (MAX - borrow < num(setDig(z, unDig(z) - borrow))) {
    351             word n, carry;                                  // x += v
    352 
    353             --q;
    354             if (m || rem) {
    355                y = v;
    356                carry = unDig(y) > num(setDig(x, unDig(y) + unDig(x)));
    357                while (x = cdr(numCell(x)),  isNum(y = cdr(numCell(y)))) {
    358                   if ((n = carry + unDig(y)) >= carry) {
    359                      carry = unDig(x) > (n += unDig(x));
    360                      setDig(x,n);
    361                   }
    362                }
    363                setDig(x, carry + unDig(x));
    364             }
    365          }
    366       }
    367       data(c1) = consNum(q, data(c1));                      // Store result
    368    } while (--m >= 0);
    369    if (!rem)
    370       zapZero(data(c1)),  digMul2(data(c1));
    371    else {
    372       zapZero(u);
    373       if (!d)
    374          digMul2(u);
    375       else
    376          while (--d)
    377             digDiv2(u);
    378    }
    379    return Pop(c1);
    380 }
    381 
    382 /* Compare two numbers */
    383 int bigCompare(any x, any y) {
    384    if (isNeg(x)) {
    385       if (!isNeg(y))
    386          return -1;
    387       return bigCmp(y,x);
    388    }
    389    if (isNeg(y))
    390       return +1;
    391    return bigCmp(x,y);
    392 }
    393 
    394 /* Make number from symbol */
    395 any symToNum(any s, int scl, int sep, int ign) {
    396    unsigned c;
    397    bool sign, frac;
    398    cell c1, c2;
    399 
    400    if (!(c = symByte(s)))
    401       return NULL;
    402    while (c <= ' ')  /* Skip white space */
    403       if (!(c = symByte(NULL)))
    404          return NULL;
    405    sign = NO;
    406    if (c == '+'  ||  c == '-' && (sign = YES))
    407       if (!(c = symByte(NULL)))
    408          return NULL;
    409    if ((c -= '0') > 9)
    410       return NULL;
    411    frac = NO;
    412    Push(c1, s);
    413    Push(c2, box(c+c));
    414    while ((c = symChar(NULL))  &&  (!frac || scl)) {
    415       if ((int)c == sep) {
    416          if (frac) {
    417             drop(c1);
    418             return NULL;
    419          }
    420          frac = YES;
    421       }
    422       else if ((int)c != ign) {
    423          if ((c -= '0') > 9) {
    424             drop(c1);
    425             return NULL;
    426          }
    427          digMul(data(c2), 10);
    428          digAdd(data(c2), c+c);
    429          if (frac)
    430             --scl;
    431       }
    432    }
    433    if (c) {
    434       if ((c -= '0') > 9) {
    435          drop(c1);
    436          return NULL;
    437       }
    438       if (c >= 5)
    439          digAdd(data(c2), 1+1);
    440       while (c = symByte(NULL)) {
    441          if ((c -= '0') > 9) {
    442             drop(c1);
    443             return NULL;
    444          }
    445       }
    446    }
    447    if (frac)
    448       while (--scl >= 0)
    449          digMul(data(c2), 10);
    450    if (sign && !IsZero(data(c2)))
    451       neg(data(c2));
    452    drop(c1);
    453    return data(c2);
    454 }
    455 
    456 /* Buffer size calculation */
    457 static inline int numlen(any x) {
    458    int n = 10;
    459    while (isNum(x = cdr(numCell(x))))
    460       n += 10;
    461    return (n + 8) / 9;
    462 }
    463 
    464 /* Make symbol from number */
    465 any numToSym(any x, int scl, int sep, int ign) {
    466    int i;
    467    bool sign;
    468    cell c1;
    469    word n = numlen(x);
    470    word c, *p, *q, *ta, *ti, acc[n], inc[n];
    471    char *b, buf[10];
    472 
    473    sign = isNeg(x);
    474    *(ta = acc) = 0;
    475    *(ti = inc) = 1;
    476    n = 2;
    477    for (;;) {
    478       do {
    479          if (unDig(x) & n) {
    480             c = 0,  p = acc,  q = inc;
    481             do {
    482                if (ta < p)
    483                   *++ta = 0;
    484                if (c = (*p += *q + c) > 999999999)
    485                   *p -= 1000000000;
    486             } while (++p, ++q <= ti);
    487             if (c)
    488                *p = 1,  ++ta;
    489          }
    490          c = 0,  q = inc;
    491          do
    492             if (c = (*q += *q + c) > 999999999)
    493                *q -= 1000000000;
    494          while (++q <= ti);
    495          if (c)
    496             *q = 1,  ++ti;
    497       } while (n <<= 1);
    498       if (!isNum(x = cdr(numCell(x))))
    499          break;
    500       n = 1;
    501    }
    502    n = (ta - acc) * 9;
    503    n += sprintf(b = buf, "%ld", *ta--);
    504    if (sep < 0)
    505       return boxCnt(n + sign);
    506    i = -8,  Push(c1, x = box(0));
    507    if (sign)
    508       byteSym('-', &i, &x);
    509    if ((scl = n - scl - 1) < 0) {
    510       byteSym('0', &i, &x);
    511       charSym(sep, &i, &x);
    512       while (scl < -1)
    513          byteSym('0', &i, &x),  ++scl;
    514    }
    515    for (;;) {
    516       byteSym(*b++, &i, &x);
    517       if (!*b) {
    518          if (ta < acc)
    519             return consStr(Pop(c1));
    520          sprintf(b = buf, "%09ld", *ta--);
    521       }
    522       if (scl == 0)
    523          charSym(sep, &i, &x);
    524       else if (ign  &&  scl > 0  &&  scl % 3 == 0)
    525          charSym(ign, &i, &x);
    526       --scl;
    527    }
    528 }
    529 
    530 #define DMAX ((double)((word2)MASK+1))
    531 
    532 /* Make number from double */
    533 any doubleToNum(double d) {
    534    bool sign;
    535    any x;
    536    cell c1;
    537 
    538    if (isnan(d) || isinf(d) < 0)
    539       return Nil;
    540    if (isinf(d) > 0)
    541       return T;
    542    sign = NO;
    543    if (d < 0.0)
    544       sign = YES,  d = -d;
    545    d += 0.5;
    546    Push(c1, x = box((word)fmod(d,DMAX)));
    547    while (d > DMAX)
    548       x = cdr(numCell(x)) = box((word)fmod(d /= DMAX, DMAX));
    549    digMul2(data(c1));
    550    if (sign && !IsZero(data(c1)))
    551       neg(data(c1));
    552    return Pop(c1);
    553 }
    554 
    555 /* Make double from number */
    556 double numToDouble(any x) {
    557    double d, m;
    558    bool sign;
    559 
    560    sign = isNeg(x);
    561    d = (double)(unDig(x) / 2),  m = DMAX/2.0;
    562    while (isNum(x = cdr(numCell(x))))
    563       d += m * (double)unDig(x),  m *= DMAX;
    564    return sign? -d : d;
    565 }
    566 
    567 // (format 'num ['cnt ['sym1 ['sym2]]]) -> sym
    568 // (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num
    569 any doFormat(any ex) {
    570    int scl, sep, ign;
    571    any x, y;
    572    cell c1;
    573 
    574    x = cdr(ex),  Push(c1, EVAL(car(x)));
    575    x = cdr(x),  y = EVAL(car(x));
    576    scl = isNil(y)? 0 : xCnt(ex, y);
    577    sep = '.';
    578    ign = 0;
    579    if (isCell(x = cdr(x))) {
    580       y = EVAL(car(x));
    581       NeedSym(ex,y);
    582       sep = symChar(name(y));
    583       if (isCell(x = cdr(x))) {
    584          y = EVAL(car(x));
    585          NeedSym(ex,y);
    586          ign = symChar(name(y));
    587       }
    588    }
    589    if (isNum(data(c1)))
    590       data(c1) = numToSym(data(c1), scl, sep, ign);
    591    else {
    592       int i;
    593       any nm;
    594       cell c2;
    595 
    596       if (isSym(data(c1)))
    597          nm = name(data(c1));
    598       else {
    599          nm = NULL,  pack(data(c1), &i, &nm, &c2);
    600          nm = nm? data(c2) : Nil;
    601       }
    602       data(c1) = symToNum(nm, scl, sep, ign) ?: Nil;
    603    }
    604    return Pop(c1);
    605 }
    606 
    607 // (+ 'num ..) -> num
    608 any doAdd(any ex) {
    609    any x;
    610    cell c1, c2;
    611 
    612    x = cdr(ex);
    613    if (isNil(data(c1) = EVAL(car(x))))
    614       return Nil;
    615    NeedNum(ex,data(c1));
    616    Push(c1, bigCopy(data(c1)));
    617    while (isCell(x = cdr(x))) {
    618       Push(c2, EVAL(car(x)));
    619       if (isNil(data(c2))) {
    620          drop(c1);
    621          return Nil;
    622       }
    623       NeedNum(ex,data(c2));
    624       if (isNeg(data(c1))) {
    625          if (isNeg(data(c2)))
    626             bigAdd(data(c1),data(c2));
    627          else
    628             bigSub(data(c1),data(c2));
    629          if (!IsZero(data(c1)))
    630             neg(data(c1));
    631       }
    632       else if (isNeg(data(c2)))
    633          bigSub(data(c1),data(c2));
    634       else
    635          bigAdd(data(c1),data(c2));
    636       drop(c2);
    637    }
    638    return Pop(c1);
    639 }
    640 
    641 // (- 'num ..) -> num
    642 any doSub(any ex) {
    643    any x;
    644    cell c1, c2;
    645 
    646    x = cdr(ex);
    647    if (isNil(data(c1) = EVAL(car(x))))
    648       return Nil;
    649    NeedNum(ex,data(c1));
    650    if (!isCell(x = cdr(x)))
    651       return IsZero(data(c1))?
    652             data(c1) : consNum(unDig(data(c1)) ^ 1, cdr(numCell(data(c1))));
    653    Push(c1, bigCopy(data(c1)));
    654    do {
    655       Push(c2, EVAL(car(x)));
    656       if (isNil(data(c2))) {
    657          drop(c1);
    658          return Nil;
    659       }
    660       NeedNum(ex,data(c2));
    661       if (isNeg(data(c1))) {
    662          if (isNeg(data(c2)))
    663             bigSub(data(c1),data(c2));
    664          else
    665             bigAdd(data(c1),data(c2));
    666          if (!IsZero(data(c1)))
    667             neg(data(c1));
    668       }
    669       else if (isNeg(data(c2)))
    670          bigAdd(data(c1),data(c2));
    671       else
    672          bigSub(data(c1),data(c2));
    673       drop(c2);
    674    } while (isCell(x = cdr(x)));
    675    return Pop(c1);
    676 }
    677 
    678 // (inc 'num) -> num
    679 // (inc 'var ['num]) -> num
    680 any doInc(any ex) {
    681    any x;
    682    cell c1, c2;
    683 
    684    x = cdr(ex);
    685    if (isNil(data(c1) = EVAL(car(x))))
    686       return Nil;
    687    if (isNum(data(c1))) {
    688       Push(c1, bigCopy(data(c1)));
    689       if (!isNeg(data(c1)))
    690          digAdd(data(c1), 2);
    691       else {
    692          pos(data(c1)), digSub1(data(c1)), neg(data(c1));
    693          if (unDig(data(c1)) == 1  &&  !isNum(cdr(numCell(data(c1)))))
    694             setDig(data(c1), 0);
    695       }
    696       return Pop(c1);
    697    }
    698    CheckVar(ex,data(c1));
    699    if (isSym(data(c1)))
    700       Touch(ex,data(c1));
    701    if (!isCell(x = cdr(x))) {
    702       if (isNil(val(data(c1))))
    703          return Nil;
    704       NeedNum(ex,val(data(c1)));
    705       Save(c1);
    706       val(data(c1)) = bigCopy(val(data(c1)));
    707       if (!isNeg(val(data(c1))))
    708          digAdd(val(data(c1)), 2);
    709       else {
    710          pos(val(data(c1))), digSub1(val(data(c1))), neg(val(data(c1)));
    711          if (unDig(val(data(c1))) == 1  &&  !isNum(cdr(numCell(val(data(c1))))))
    712             setDig(val(data(c1)), 0);
    713       }
    714    }
    715    else {
    716       Save(c1);
    717       Push(c2, EVAL(car(x)));
    718       if (isNil(val(data(c1))) || isNil(data(c2))) {
    719          drop(c1);
    720          return Nil;
    721       }
    722       NeedNum(ex,val(data(c1)));
    723       val(data(c1)) = bigCopy(val(data(c1)));
    724       NeedNum(ex,data(c2));
    725       if (isNeg(val(data(c1)))) {
    726          if (isNeg(data(c2)))
    727             bigAdd(val(data(c1)),data(c2));
    728          else
    729             bigSub(val(data(c1)),data(c2));
    730          if (!IsZero(val(data(c1))))
    731             neg(val(data(c1)));
    732       }
    733       else if (isNeg(data(c2)))
    734          bigSub(val(data(c1)),data(c2));
    735       else
    736          bigAdd(val(data(c1)),data(c2));
    737    }
    738    return val(Pop(c1));
    739 }
    740 
    741 // (dec 'num) -> num
    742 // (dec 'var ['num]) -> num
    743 any doDec(any ex) {
    744    any x;
    745    cell c1, c2;
    746 
    747    x = cdr(ex);
    748    if (isNil(data(c1) = EVAL(car(x))))
    749       return Nil;
    750    if (isNum(data(c1))) {
    751       Push(c1, bigCopy(data(c1)));
    752       if (isNeg(data(c1)))
    753          digAdd(data(c1), 2);
    754       else if (IsZero(data(c1)))
    755          setDig(data(c1), 3);
    756       else
    757          digSub1(data(c1));
    758       return Pop(c1);
    759    }
    760    CheckVar(ex,data(c1));
    761    if (isSym(data(c1)))
    762       Touch(ex,data(c1));
    763    if (!isCell(x = cdr(x))) {
    764       if (isNil(val(data(c1))))
    765          return Nil;
    766       NeedNum(ex,val(data(c1)));
    767       Save(c1);
    768       val(data(c1)) = bigCopy(val(data(c1)));
    769       if (isNeg(val(data(c1))))
    770          digAdd(val(data(c1)), 2);
    771       else if (IsZero(val(data(c1))))
    772          setDig(val(data(c1)), 3);
    773       else
    774          digSub1(val(data(c1)));
    775    }
    776    else {
    777       Save(c1);
    778       Push(c2, EVAL(car(x)));
    779       if (isNil(val(data(c1))) || isNil(data(c2))) {
    780          drop(c1);
    781          return Nil;
    782       }
    783       NeedNum(ex,val(data(c1)));
    784       val(data(c1)) = bigCopy(val(data(c1)));
    785       NeedNum(ex,data(c2));
    786       if (isNeg(val(data(c1)))) {
    787          if (isNeg(data(c2)))
    788             bigSub(val(data(c1)),data(c2));
    789          else
    790             bigAdd(val(data(c1)),data(c2));
    791          if (!IsZero(val(data(c1))))
    792             neg(val(data(c1)));
    793       }
    794       else if (isNeg(data(c2)))
    795          bigAdd(val(data(c1)),data(c2));
    796       else
    797          bigSub(val(data(c1)),data(c2));
    798    }
    799    return val(Pop(c1));
    800 }
    801 
    802 // (* 'num ..) -> num
    803 any doMul(any ex) {
    804    any x;
    805    bool sign;
    806    cell c1, c2;
    807 
    808    x = cdr(ex);
    809    if (isNil(data(c1) = EVAL(car(x))))
    810       return Nil;
    811    NeedNum(ex,data(c1));
    812    Push(c1, bigCopy(data(c1)));
    813    sign = isNeg(data(c1)),  pos(data(c1));
    814    while (isCell(x = cdr(x))) {
    815       Push(c2, EVAL(car(x)));
    816       if (isNil(data(c2))) {
    817          drop(c1);
    818          return Nil;
    819       }
    820       NeedNum(ex,data(c2));
    821       sign ^= isNeg(data(c2));
    822       data(c1) = bigMul(data(c1),data(c2));
    823       drop(c2);
    824    }
    825    if (sign && !IsZero(data(c1)))
    826       neg(data(c1));
    827    return Pop(c1);
    828 }
    829 
    830 // (*/ 'num1 ['num2 ..] 'num3) -> num
    831 any doMulDiv(any ex) {
    832    any x;
    833    bool sign;
    834    cell c1, c2, c3;
    835 
    836    x = cdr(ex);
    837    if (isNil(data(c1) = EVAL(car(x))))
    838       return Nil;
    839    NeedNum(ex,data(c1));
    840    Push(c1, bigCopy(data(c1)));
    841    sign = isNeg(data(c1)),  pos(data(c1));
    842    Push(c2, Nil);
    843    for (;;) {
    844       x = cdr(x),  data(c2) = EVAL(car(x));
    845       if (isNil(data(c2))) {
    846          drop(c1);
    847          return Nil;
    848       }
    849       NeedNum(ex,data(c2));
    850       sign ^= isNeg(data(c2));
    851       if (!isCell(cdr(x)))
    852          break;
    853       data(c1) = bigMul(data(c1),data(c2));
    854    }
    855    if (IsZero(data(c2)))
    856       divErr(ex);
    857    Push(c3, bigCopy(data(c2)));
    858    digDiv2(data(c3));
    859    bigAdd(data(c1),data(c3));
    860    data(c2) = bigCopy(data(c2));
    861    data(c1) = bigDiv(data(c1),data(c2),NO);
    862    if (sign && !IsZero(data(c1)))
    863       neg(data(c1));
    864    return Pop(c1);
    865 }
    866 
    867 // (/ 'num ..) -> num
    868 any doDiv(any ex) {
    869    any x;
    870    bool sign;
    871    cell c1, c2;
    872 
    873    x = cdr(ex);
    874    if (isNil(data(c1) = EVAL(car(x))))
    875       return Nil;
    876    NeedNum(ex,data(c1));
    877    Push(c1, bigCopy(data(c1)));
    878    sign = isNeg(data(c1)),  pos(data(c1));
    879    while (isCell(x = cdr(x))) {
    880       Push(c2, EVAL(car(x)));
    881       if (isNil(data(c2))) {
    882          drop(c1);
    883          return Nil;
    884       }
    885       NeedNum(ex,data(c2));
    886       sign ^= isNeg(data(c2));
    887       if (IsZero(data(c2)))
    888          divErr(ex);
    889       data(c2) = bigCopy(data(c2));
    890       data(c1) = bigDiv(data(c1),data(c2),NO);
    891       drop(c2);
    892    }
    893    if (sign && !IsZero(data(c1)))
    894       neg(data(c1));
    895    return Pop(c1);
    896 }
    897 
    898 // (% 'num ..) -> num
    899 any doRem(any ex) {
    900    any x;
    901    bool sign;
    902    cell c1, c2;
    903 
    904    x = cdr(ex);
    905    if (isNil(data(c1) = EVAL(car(x))))
    906       return Nil;
    907    NeedNum(ex,data(c1));
    908    Push(c1, bigCopy(data(c1)));
    909    sign = isNeg(data(c1)),  pos(data(c1));
    910    while (isCell(x = cdr(x))) {
    911       Push(c2, EVAL(car(x)));
    912       if (isNil(data(c2))) {
    913          drop(c1);
    914          return Nil;
    915       }
    916       NeedNum(ex,data(c2));
    917       if (IsZero(data(c2)))
    918          divErr(ex);
    919       data(c2) = bigCopy(data(c2));
    920       bigDiv(data(c1),data(c2),YES);
    921       drop(c2);
    922    }
    923    if (sign && !IsZero(data(c1)))
    924       neg(data(c1));
    925    return Pop(c1);
    926 }
    927 
    928 // (>> 'cnt 'num) -> num
    929 any doShift(any ex) {
    930    any x;
    931    long n;
    932    bool sign;
    933    cell c1;
    934 
    935    x = cdr(ex),  n = evCnt(ex,x);
    936    x = cdr(x);
    937    if (isNil(data(c1) = EVAL(car(x))))
    938       return Nil;
    939    NeedNum(ex,data(c1));
    940    Push(c1, bigCopy(data(c1)));
    941    sign = isNeg(data(c1));
    942    if (n > 0) {
    943       do
    944          digDiv2(data(c1));
    945       while (--n);
    946       pos(data(c1));
    947    }
    948    else if (n < 0) {
    949       pos(data(c1));
    950       do
    951          digMul2(data(c1));
    952       while (++n);
    953    }
    954    if (sign && !IsZero(data(c1)))
    955       neg(data(c1));
    956    return Pop(c1);
    957 }
    958 
    959 // (lt0 'any) -> num | NIL
    960 any doLt0(any x) {
    961    x = cdr(x);
    962    return isNum(x = EVAL(car(x))) && isNeg(x)? x : Nil;
    963 }
    964 
    965 // (le0 'any) -> num | NIL
    966 any doLe0(any x) {
    967    x = cdr(x);
    968    return isNum(x = EVAL(car(x))) && (isNeg(x) || IsZero(x))? x : Nil;
    969 }
    970 
    971 // (ge0 'any) -> num | NIL
    972 any doGe0(any x) {
    973    x = cdr(x);
    974    return isNum(x = EVAL(car(x))) && !isNeg(x)? x : Nil;
    975 }
    976 
    977 // (gt0 'any) -> num | NIL
    978 any doGt0(any x) {
    979    x = cdr(x);
    980    return isNum(x = EVAL(car(x))) && !isNeg(x) && !IsZero(x)? x : Nil;
    981 }
    982 
    983 // (abs 'num) -> num
    984 any doAbs(any ex) {
    985    any x;
    986 
    987    x = cdr(ex);
    988    if (isNil(x = EVAL(car(x))))
    989       return Nil;
    990    NeedNum(ex,x);
    991    if (!isNeg(x))
    992       return x;
    993    return consNum(unDig(x) & ~1, cdr(numCell(x)));
    994 }
    995 
    996 // (bit? 'num ..) -> num | NIL
    997 any doBitQ(any ex) {
    998    any x, y, z;
    999    cell c1;
   1000 
   1001    x = cdr(ex),  Push(c1, EVAL(car(x)));
   1002    NeedNum(ex,data(c1));
   1003    while (isCell(x = cdr(x))) {
   1004       if (isNil(z = EVAL(car(x)))) {
   1005          drop(c1);
   1006          return Nil;
   1007       }
   1008       NeedNum(ex,z);
   1009       y = data(c1);
   1010       for (;;) {
   1011          if ((unDig(y) & unDig(z)) != unDig(y)) {
   1012             drop(c1);
   1013             return Nil;
   1014          }
   1015          if (!isNum(y = cdr(numCell(y))))
   1016             break;
   1017          if (!isNum(z = cdr(numCell(z)))) {
   1018             drop(c1);
   1019             return Nil;
   1020          }
   1021       }
   1022    }
   1023    return Pop(c1);
   1024 }
   1025 
   1026 // (& 'num ..) -> num
   1027 any doBitAnd(any ex) {
   1028    any x, y, z;
   1029    cell c1;
   1030 
   1031    x = cdr(ex);
   1032    if (isNil(data(c1) = EVAL(car(x))))
   1033       return Nil;
   1034    NeedNum(ex,data(c1));
   1035    Push(c1, bigCopy(data(c1)));
   1036    while (isCell(x = cdr(x))) {
   1037       if (isNil(z = EVAL(car(x)))) {
   1038          drop(c1);
   1039          return Nil;
   1040       }
   1041       NeedNum(ex,z);
   1042       y = data(c1);
   1043       for (;;) {
   1044          setDig(y, unDig(y) & unDig(z));
   1045          if (!isNum(z = cdr(numCell(z)))) {
   1046             cdr(numCell(y)) = Nil;
   1047             break;
   1048          }
   1049          if (!isNum(y = cdr(numCell(y))))
   1050             break;
   1051       }
   1052    }
   1053    zapZero(data(c1));
   1054    return Pop(c1);
   1055 }
   1056 
   1057 // (| 'num ..) -> num
   1058 any doBitOr(any ex) {
   1059    any x, y;
   1060    cell c1, c2;
   1061 
   1062    x = cdr(ex);
   1063    if (isNil(data(c1) = EVAL(car(x))))
   1064       return Nil;
   1065    NeedNum(ex,data(c1));
   1066    Push(c1, bigCopy(data(c1)));
   1067    while (isCell(x = cdr(x))) {
   1068       if (isNil(data(c2) = EVAL(car(x)))) {
   1069          drop(c1);
   1070          return Nil;
   1071       }
   1072       NeedNum(ex,data(c2));
   1073       y = data(c1);
   1074       Save(c2);
   1075       for (;;) {
   1076          setDig(y, unDig(y) | unDig(data(c2)));
   1077          if (!isNum(data(c2) = cdr(numCell(data(c2)))))
   1078             break;
   1079          if (!isNum(cdr(numCell(y))))
   1080             cdr(numCell(y)) = box(0);
   1081          y = cdr(numCell(y));
   1082       }
   1083       drop(c2);
   1084    }
   1085    return Pop(c1);
   1086 }
   1087 
   1088 // (x| 'num ..) -> num
   1089 any doBitXor(any ex) {
   1090    any x, y;
   1091    cell c1, c2;
   1092 
   1093    x = cdr(ex);
   1094    if (isNil(data(c1) = EVAL(car(x))))
   1095       return Nil;
   1096    NeedNum(ex,data(c1));
   1097    Push(c1, bigCopy(data(c1)));
   1098    while (isCell(x = cdr(x))) {
   1099       if (isNil(data(c2) = EVAL(car(x)))) {
   1100          drop(c1);
   1101          return Nil;
   1102       }
   1103       NeedNum(ex,data(c2));
   1104       y = data(c1);
   1105       Save(c2);
   1106       for (;;) {
   1107          setDig(y, unDig(y) ^ unDig(data(c2)));
   1108          if (!isNum(data(c2) = cdr(numCell(data(c2)))))
   1109             break;
   1110          if (!isNum(cdr(numCell(y))))
   1111             cdr(numCell(y)) = box(0);
   1112          y = cdr(numCell(y));
   1113       }
   1114       drop(c2);
   1115    }
   1116    zapZero(data(c1));
   1117    return Pop(c1);
   1118 }
   1119 
   1120 /* Random numbers */
   1121 static uint64_t Seed;
   1122 
   1123 static uint64_t initSeed(any x) {
   1124    uint64_t n;
   1125 
   1126    for (n = 0; isCell(x); x = cdr(x))
   1127       n += initSeed(car(x));
   1128    if (!isNil(x)) {
   1129       if (isSym(x))
   1130          x = name(x);
   1131       do
   1132          n += unDig(x);
   1133       while (isNum(x = cdr(numCell(x))));
   1134    }
   1135    return n;
   1136 }
   1137 
   1138 // (seed 'any) -> cnt
   1139 any doSeed(any ex) {
   1140    return box(hi(Seed = initSeed(EVAL(cadr(ex))) * 6364136223846793005LL));
   1141 }
   1142 
   1143 // (hash 'any) -> cnt
   1144 any doHash(any ex) {
   1145    word2 n = initSeed(EVAL(cadr(ex)));
   1146    int i = 64;
   1147    int j = 0;
   1148 
   1149    do {
   1150       if (((int)n ^ j) & 1)
   1151          j ^= 0x14002;  /* CRC Polynom x**16 + x**15 + x**2 + 1 */
   1152       n >>= 1,  j >>= 1;
   1153    } while (--i);
   1154    return box(2 * (j + 1));
   1155 }
   1156 
   1157 // (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg
   1158 any doRand(any ex) {
   1159    any x;
   1160    long n;
   1161 
   1162    x = cdr(ex);
   1163    Seed = Seed * 6364136223846793005LL + 1;
   1164    if (isNil(x = EVAL(car(x))))
   1165       return box(hi(Seed));
   1166    if (x == T)
   1167       return hi(Seed) & 1 ? T : Nil;
   1168    n = xCnt(ex,x);
   1169    return boxCnt(n + hi(Seed) % (evCnt(ex, cddr(ex)) + 1 - n));
   1170 }
	picolisp Unnamed repository; edit this file to name it for gitweb.
	git clone https://logand.com/git/picolisp.git/
	Log \| Files \| Refs \| README \| LICENSE