big.c

A very small LISP implementation with several packages and demo programs.

   return Pop(c1);
}

// (+ 'num ..) -> num
any doAdd(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   while (isCell(x = cdr(x))) {
      Push(c2, EVAL(car(x)));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      if (isNeg(data(c1))) {
         if (isNeg(data(c2)))
            bigAdd(data(c1),data(c2));
         else
            bigSub(data(c1),data(c2));
         if (!IsZero(data(c1)))
            neg(data(c1));
      }
      else if (isNeg(data(c2)))
         bigSub(data(c1),data(c2));
      else
         bigAdd(data(c1),data(c2));
      drop(c2);
   }
   return Pop(c1);
}

// (- 'num ..) -> num
any doSub(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   if (!isCell(x = cdr(x)))
      return IsZero(data(c1))?
            data(c1) : consNum(unDig(data(c1)) ^ 1, cdr(numCell(data(c1))));
   Push(c1, bigCopy(data(c1)));
   do {
      Push(c2, EVAL(car(x)));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      if (isNeg(data(c1))) {
         if (isNeg(data(c2)))
            bigSub(data(c1),data(c2));
         else
            bigAdd(data(c1),data(c2));
         if (!IsZero(data(c1)))
            neg(data(c1));
      }
      else if (isNeg(data(c2)))
         bigAdd(data(c1),data(c2));
      else
         bigSub(data(c1),data(c2));
      drop(c2);
   } while (isCell(x = cdr(x)));
   return Pop(c1);
}

// (inc 'num) -> num
// (inc 'var ['num]) -> num
any doInc(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   if (isNum(data(c1))) {
      Push(c1, bigCopy(data(c1)));
      if (!isNeg(data(c1)))
         digAdd(data(c1), 2);
      else {
         pos(data(c1)), digSub1(data(c1)), neg(data(c1));
         if (unDig(data(c1)) == 1  &&  !isNum(cdr(numCell(data(c1)))))
            setDig(data(c1), 0);
      }
      return Pop(c1);
   }
   CheckVar(ex,data(c1));
   if (!isCell(x = cdr(x))) {
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      if (isNil(val(data(c1))))
         return Nil;
      NeedNum(ex,val(data(c1)));
      Save(c1);
      val(data(c1)) = bigCopy(val(data(c1)));
      if (!isNeg(val(data(c1))))
         digAdd(val(data(c1)), 2);
      else {
         digSub1(val(data(c1)));
         if (unDig(val(data(c1))) == 1  &&  !isNum(cdr(numCell(val(data(c1))))))
            setDig(val(data(c1)), 0);
      }
   }
   else {
      Save(c1);
      Push(c2, EVAL(car(x)));
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      if (isNil(val(data(c1))) || isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,val(data(c1)));
      val(data(c1)) = bigCopy(val(data(c1)));
      NeedNum(ex,data(c2));
      if (isNeg(val(data(c1)))) {
         if (isNeg(data(c2)))
            bigAdd(val(data(c1)),data(c2));
         else
            bigSub(val(data(c1)),data(c2));
         if (!IsZero(val(data(c1))))
            neg(val(data(c1)));
      }
      else if (isNeg(data(c2)))
         bigSub(val(data(c1)),data(c2));
      else
         bigAdd(val(data(c1)),data(c2));
   }
   return val(Pop(c1));
}

// (dec 'num) -> num
// (dec 'var ['num]) -> num
any doDec(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   if (isNum(data(c1))) {
      Push(c1, bigCopy(data(c1)));
      if (isNeg(data(c1)))
         digAdd(data(c1), 2);
      else if (IsZero(data(c1)))
         setDig(data(c1), 3);
      else
         digSub1(data(c1));
      return Pop(c1);
   }
   CheckVar(ex,data(c1));
   if (!isCell(x = cdr(x))) {
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      if (isNil(val(data(c1))))
         return Nil;
      NeedNum(ex,val(data(c1)));
      Save(c1);
      val(data(c1)) = bigCopy(val(data(c1)));
      if (isNeg(val(data(c1))))
         digAdd(val(data(c1)), 2);
      else if (IsZero(val(data(c1))))
         setDig(val(data(c1)), 3);
      else
         digSub1(val(data(c1)));
   }
   else {
      Save(c1);
      Push(c2, EVAL(car(x)));
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      if (isNil(val(data(c1))) || isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,val(data(c1)));
      val(data(c1)) = bigCopy(val(data(c1)));
      NeedNum(ex,data(c2));
      if (isNeg(val(data(c1)))) {
         if (isNeg(data(c2)))
            bigSub(val(data(c1)),data(c2));
         else
            bigAdd(val(data(c1)),data(c2));
         if (!IsZero(val(data(c1))))
            neg(val(data(c1)));
      }
      else if (isNeg(data(c2)))
         bigAdd(val(data(c1)),data(c2));
      else
         bigSub(val(data(c1)),data(c2));
   }
   return val(Pop(c1));
}

// (* 'num ..) -> num
any doMul(any ex) {
   any x;
   bool sign;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   sign = isNeg(data(c1)),  pos(data(c1));
   while (isCell(x = cdr(x))) {
      Push(c2, EVAL(car(x)));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      sign ^= isNeg(data(c2));
      data(c1) = bigMul(data(c1),data(c2));
      drop(c2);
   }
   if (sign && !IsZero(data(c1)))
      neg(data(c1));
   return Pop(c1);
}

// (*/ 'num1 ['num2 ..] 'num3) -> num
any doMulDiv(any ex) {
   any x;
   bool sign;
   cell c1, c2, c3;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   sign = isNeg(data(c1)),  pos(data(c1));
   Push(c2, Nil);
   for (;;) {
      x = cdr(x),  data(c2) = EVAL(car(x));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      sign ^= isNeg(data(c2));
      if (!isCell(cdr(x)))
         break;
      data(c1) = bigMul(data(c1),data(c2));
   }
   if (IsZero(data(c2)))
      divErr(ex);
   Push(c3, bigCopy(data(c2)));
   digDiv2(data(c3));
   bigAdd(data(c1),data(c3));
   data(c2) = bigCopy(data(c2));
   data(c1) = bigDiv(data(c1),data(c2),NO);
   if (sign && !IsZero(data(c1)))
      neg(data(c1));
   return Pop(c1);
}

// (/ 'num ..) -> num
any doDiv(any ex) {
   any x;
   bool sign;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   sign = isNeg(data(c1)),  pos(data(c1));
   while (isCell(x = cdr(x))) {
      Push(c2, EVAL(car(x)));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      sign ^= isNeg(data(c2));
      if (IsZero(data(c2)))
         divErr(ex);
      data(c2) = bigCopy(data(c2));
      data(c1) = bigDiv(data(c1),data(c2),NO);
      drop(c2);
   }
   if (sign && !IsZero(data(c1)))
      neg(data(c1));
   return Pop(c1);
}

// (% 'num ..) -> num
any doRem(any ex) {
   any x;
   bool sign;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   sign = isNeg(data(c1)),  pos(data(c1));
   while (isCell(x = cdr(x))) {
      Push(c2, EVAL(car(x)));
      if (isNil(data(c2))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,data(c2));
      if (IsZero(data(c2)))
         divErr(ex);
      data(c2) = bigCopy(data(c2));
      bigDiv(data(c1),data(c2),YES);
      drop(c2);
   }
   if (sign && !IsZero(data(c1)))
      neg(data(c1));
   return Pop(c1);
}

// (>> 'cnt 'num) -> num
any doShift(any ex) {
   any x;
   long n;
   bool sign;
   cell c1;

   x = cdr(ex),  n = evCnt(ex,x);
   x = cdr(x);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   sign = isNeg(data(c1));
   if (n > 0) {
      do
         digDiv2(data(c1));
      while (--n);
      pos(data(c1));
   }
   else if (n < 0) {
      pos(data(c1));
      do
         digMul2(data(c1));
      while (++n);
   }
   if (sign && !IsZero(data(c1)))
      neg(data(c1));
   return Pop(c1);
}

// (lt0 'any) -> num | NIL
any doLt0(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && isNeg(x)? x : Nil;
}

// (ge0 'any) -> num | NIL
any doGe0(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && !isNeg(x)? x : Nil;
}

// (gt0 'any) -> num | NIL
any doGt0(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && !isNeg(x) && !IsZero(x)? x : Nil;
}

// (abs 'num) -> num
any doAbs(any ex) {
   any x;

   x = cdr(ex);
   if (isNil(x = EVAL(car(x))))
      return Nil;
   NeedNum(ex,x);
   if (!isNeg(x))
      return x;
   return consNum(unDig(x) & ~1, cdr(numCell(x)));
}

// (bit? 'num ..) -> num | NIL
any doBitQ(any ex) {
   any x, y, z;
   cell c1;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   NeedNum(ex,data(c1));
   while (isCell(x = cdr(x))) {
      if (isNil(z = EVAL(car(x)))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,z);
      y = data(c1);
      for (;;) {
         if ((unDig(y) & unDig(z)) != unDig(y)) {
            drop(c1);
            return Nil;
         }
         if (!isNum(y = cdr(numCell(y))))
            break;
         if (!isNum(z = cdr(numCell(z)))) {
            drop(c1);
            return Nil;
         }
      }
   }
   return Pop(c1);
}

// (& 'num ..) -> num
any doBitAnd(any ex) {
   any x, y, z;
   cell c1;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   while (isCell(x = cdr(x))) {
      if (isNil(z = EVAL(car(x)))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,z);
      y = data(c1);
      for (;;) {
         setDig(y, unDig(y) & unDig(z));
         if (!isNum(z = cdr(numCell(z)))) {
            cdr(numCell(y)) = Nil;
            break;
         }
         if (!isNum(y = cdr(numCell(y))))
            break;
      }
   }
   zapZero(data(c1));
   return Pop(c1);
}

// (| 'num ..) -> num
any doBitOr(any ex) {
   any x, y, z;
   cell c1;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   while (isCell(x = cdr(x))) {
      if (isNil(z = EVAL(car(x)))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,z);
      y = data(c1);
      for (;;) {
         setDig(y, unDig(y) | unDig(z));
         if (!isNum(z = cdr(numCell(z))))
            break;
         if (!isNum(cdr(numCell(y))))
            cdr(numCell(y)) = box(0);
         y = cdr(numCell(y));
      }
   }
   return Pop(c1);
}

// (x| 'num ..) -> num
any doBitXor(any ex) {
   any x, y, z;
   cell c1;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   NeedNum(ex,data(c1));
   Push(c1, bigCopy(data(c1)));
   while (isCell(x = cdr(x))) {
      if (isNil(z = EVAL(car(x)))) {
         drop(c1);
         return Nil;
      }
      NeedNum(ex,z);
      y = data(c1);
      for (;;) {
         setDig(y, unDig(y) ^ unDig(z));
         if (!isNum(z = cdr(numCell(z))))
            break;
         if (!isNum(cdr(numCell(y))))
            cdr(numCell(y)) = box(0);
         y = cdr(numCell(y));
      }
   }
   zapZero(data(c1));
   return Pop(c1);
}

// Needs to be optimized!
// (sqrt 'num) -> num
any doSqrt(any ex) {
   any x;
   cell c1, c2, c3;

   x = cdr(ex);
   if (isNil(x = EVAL(car(x))))
      return Nil;
   NeedNum(ex,x);
   if (isNeg(x))
      err(ex, x, "Bad argument");
   Push(c1, bigCopy(x));
   Push(c2, box(2));
   for (x = data(c1);  isNum(cdr(numCell(x)));  x = cdr(numCell(x)))
      data(c2) = consNum(0, data(c2));
   while (bigCmp(data(c2),data(c1)) <= 0)
      digMul2(data(c2)),  digMul2(data(c2));
   Push(c3, box(0));
   do {
      bigAdd(data(c3),data(c2));
      if (bigCmp(data(c3),data(c1)) > 0)
         bigSub(data(c3),data(c2));
      else
         bigSub(data(c1),data(c3)),  bigAdd(data(c3),data(c2));
      digDiv2(data(c3));
      digDiv2(data(c2)),  digDiv2(data(c2));
   } while (!IsZero(data(c2)));
   drop(c1);
   return data(c3);
}

static u_int64_t Seed;

static u_int64_t initSeed(any x) {
   u_int64_t n;

   for (n = 0; isCell(x); x = cdr(x))
      n += initSeed(car(x));
   if (!isNil(x)) {
      if (isSym(x))
         x = name(x);
      do
         n += unDig(x);
      while (isNum(x = cdr(numCell(x))));
   }
   return n;
}

// (seed 'any) -> cnt
any doSeed(any ex) {
   return boxCnt(
         hi(Seed = initSeed(EVAL(cadr(ex))) * 6364136223846793005LL + 1) );
}

// (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg
any doRand(any ex) {
   any x;
   long n;

   x = cdr(ex);
   Seed = Seed * 6364136223846793005LL + 1;
   if (isNil(x = EVAL(car(x))))
      return boxCnt(hi(Seed));
   if (x == T)
      return hi(Seed) & 1 ? T : Nil;
   n = xCnt(ex,x);
   return boxCnt(n + hi(Seed) % (evCnt(ex, cddr(ex)) + 1 - n));
}