subr.c

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

   while (isCell(x)  &&  car(x) == Quote  && x != cdr(x))
      x = cdr(x);
   return x;
}

// (split 'lst 'any ..) -> lst
any doSplit(any x) {
   any y;
   int i, n = length(cdr(x = cdr(x)));
   cell c1, c[n], res, sub;

   if (!isCell(data(c1) = EVAL(car(x))))
      return data(c1);
   Save(c1);
   for (i = 0; i < n; ++i)
      x = cdr(x),  Push(c[i], EVAL(car(x)));
   Push(res, x = Nil);
   Push(sub, y = Nil);
   do {
      for (i = 0;  i < n;  ++i) {
         if (equal(car(data(c1)), data(c[i]))) {
            if (isNil(x))
               x = data(res) = cons(data(sub), Nil);
            else
               x = cdr(x) = cons(data(sub), Nil);
            y = data(sub) = Nil;
            goto spl1;
         }
      }
      if (isNil(y))
         y = data(sub) = cons(car(data(c1)), Nil);
      else
         y = cdr(y) = cons(car(data(c1)), Nil);
   spl1: ;
   } while (isCell(data(c1) = cdr(data(c1))));
   y = cons(data(sub), Nil);
   drop(c1);
   if (isNil(x))
      return y;
   cdr(x) = y;
   return data(res);
}

// (reverse 'lst) -> lst
any doReverse(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, x = EVAL(car(x)));
   for (y = Nil; isCell(x); x = cdr(x))
      y = cons(car(x), y);
   drop(c1);
   return y;
}

// (flip 'lst) -> lst
any doFlip(any x) {
   any y, z;

   x = cdr(x);
   if (!isCell(x = EVAL(car(x))) ||  !isCell(y = cdr(x)))
      return x;
   cdr(x) = Nil;
   for (;;) {
      z = cdr(y),  cdr(y) = x;
      if (!isCell(z))
         return y;
      x = y,  y = z;
   }
}

static any trim(any x) {
   any y;

   if (!isCell(x))
      return x;
   if (isNil(y = trim(cdr(x))) && isBlank(car(x)))
      return Nil;
   return cons(car(x),y);
}

// (trim 'lst) -> lst
any doTrim(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = trim(data(c1));
   drop(c1);
   return x;
}

// (clip 'lst) -> lst
any doClip(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(data(c1)) && isBlank(car(data(c1))))
      data(c1) = cdr(data(c1));
   x = trim(data(c1));
   drop(c1);
   return x;
}

// (head 'cnt|lst 'lst) -> lst
any doHead(any ex) {
   long n;
   any x, y;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   if (isCell(data(c1))) {
      Save(c1);
      x = cdr(x);
      if (isCell(x = EVAL(car(x)))) {
         for (y = data(c1);  equal(car(y), car(x));  x = cdr(x))
            if (!isCell(y = cdr(y)))
               return Pop(c1);
      }
      drop(c1);
      return Nil;
   }
   if ((n = xCnt(ex,data(c1))) == 0)
      return Nil;
   x = cdr(x);
   if (!isCell(x = EVAL(car(x))))
      return x;
   if (n < 0  &&  (n += length(x)) <= 0)
      return Nil;
   Push(c1,x);
   Push(c2, x = cons(car(data(c1)), Nil));
   while (--n  &&  isCell(data(c1) = cdr(data(c1))))
      x = cdr(x) = cons(car(data(c1)), Nil);
   drop(c1);
   return data(c2);
}

// (tail 'cnt|lst 'lst) -> lst
any doTail(any ex) {
   long n;
   any x, y;
   cell c1;

   x = cdr(ex);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;
   if (isCell(data(c1))) {
      Save(c1);
      x = cdr(x);
      if (isCell(x = EVAL(car(x)))) {
         do
            if (equal(x,data(c1)))
               return Pop(c1);
         while (isCell(x = cdr(x)));
      }
      drop(c1);
      return Nil;
   }
   if ((n = xCnt(ex,data(c1))) == 0)
      return Nil;
   x = cdr(x);
   if (!isCell(x = EVAL(car(x))))
      return x;
   if (n < 0)
      return nth(1 - n, x);
   for (y = cdr(x);  --n;  y = cdr(y))
      if (!isCell(y))
         return x;
   while (isCell(y))
      x = cdr(x),  y = cdr(y);
   return x;
}

// (stem 'lst 'any ..) -> lst
any doStem(any x) {
   int i, n = length(cdr(x = cdr(x)));
   cell c1, c[n];

   Push(c1, EVAL(car(x)));
   for (i = 0; i < n; ++i)
      x = cdr(x),  Push(c[i], EVAL(car(x)));
   for (x = data(c1); isCell(x); x = cdr(x)) {
      for (i = 0;  i < n;  ++i)
         if (equal(car(x), data(c[i])))
            data(c1) = cdr(x);
   }
   return Pop(c1);
}

// (fin 'any) -> num|sym
any doFin(any x) {
   x = cdr(x),  x = EVAL(car(x));
   while (isCell(x))
      x = cdr(x);
   return x;
}

// (last 'lst) -> any
any doLast(any x) {
   x = cdr(x),  x = EVAL(car(x));
   if (!isCell(x))
      return x;
   while (isCell(cdr(x)))
      x = cdr(x);
   return car(x);
}

// (== 'any ..) -> flg
any doEq(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (data(c1) != EVAL(car(x))) {
         drop(c1);
         return Nil;
      }
   drop(c1);
   return T;
}

// (n== 'any ..) -> flg
any doNEq(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (data(c1) != EVAL(car(x))) {
         drop(c1);
         return T;
      }
   drop(c1);
   return Nil;
}

// (= 'any ..) -> flg
any doEqual(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (!equal(data(c1), EVAL(car(x)))) {
         drop(c1);
         return Nil;
      }
   drop(c1);
   return T;
}

// (<> 'any ..) -> flg
any doNEqual(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (!equal(data(c1), EVAL(car(x)))) {
         drop(c1);
         return T;
      }
   drop(c1);
   return Nil;
}

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

// (=T 'any) -> flg
any doEqualT(any x) {
   x = cdr(x);
   return T == EVAL(car(x))? T : Nil;
}

// (n0 'any) -> flg
any doNEq0(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && IsZero(x)? Nil : T;
}

// (nT 'any) -> flg
any doNEqT(any x) {
   x = cdr(x);
   return T == EVAL(car(x))? Nil : T;
}

// (< 'any ..) -> flg
any doLt(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(data(c1), y) >= 0) {
         drop(c1);
         return Nil;
      }
      data(c1) = y;
   }
   drop(c1);
   return T;
}

// (<= 'any ..) -> flg
any doLe(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(data(c1), y) > 0) {
         drop(c1);
         return Nil;
      }
      data(c1) = y;
   }
   drop(c1);
   return T;
}

// (> 'any ..) -> flg
any doGt(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(data(c1), y) <= 0) {
         drop(c1);
         return Nil;
      }
      data(c1) = y;
   }
   drop(c1);
   return T;
}

// (>= 'any ..) -> flg
any doGe(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(data(c1), y) < 0) {
         drop(c1);
         return Nil;
      }
      data(c1) = y;
   }
   drop(c1);
   return T;
}

// (max 'any ..) -> any
any doMax(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(y, data(c1)) > 0)
         data(c1) = y;
   }
   return Pop(c1);
}

// (min 'any ..) -> any
any doMin(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (compare(y, data(c1)) < 0)
         data(c1) = y;
   }
   return Pop(c1);
}

// (atom 'any) -> flg
any doAtom(any x) {
   x = cdr(x);
   return !isCell(EVAL(car(x)))? T : Nil;
}

// (pair 'any) -> any
any doPair(any x) {
   x = cdr(x);
   return isCell(x = EVAL(car(x)))? x : Nil;
}

// (lst? 'any) -> flg
any doLstQ(any x) {
   x = cdr(x);
   return isCell(x = EVAL(car(x))) || isNil(x)? T : Nil;
}

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

// (sym? 'any) -> flg
any doSymQ(any x) {
   x = cdr(x);
   return isSym(EVAL(car(x)))? T : Nil;
}

// (flg? 'any) -> flg
any doFlgQ(any x) {
   x = cdr(x);
   return isNil(x = EVAL(car(x))) || x==T? T : Nil;
}

// (member 'any 'lst) -> any
any doMember(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  x = EVAL(car(x));
   return member(Pop(c1), x) ?: Nil;
}

// (memq 'any 'lst) -> any
any doMemq(any x) {
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  x = EVAL(car(x));
   return memq(Pop(c1), x) ?: Nil;
}

// (mmeq 'lst 'lst) -> any
any doMmeq(any x) {
   any y, z;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   for (x = Pop(c1);  isCell(x);  x = cdr(x))
      if (z = memq(car(x), y))
         return z;
   return Nil;
}

// (sect 'lst 'lst) -> lst
any doSect(any x) {
   cell c1, c2, c3;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   Push(c3, x = Nil);
   while (isCell(data(c1))) {
      if (member(car(data(c1)), data(c2)))
         if (isNil(x))
            x = data(c3) = cons(car(data(c1)), Nil);
         else
            x = cdr(x) = cons(car(data(c1)), Nil);
      data(c1) = cdr(data(c1));
   }
   drop(c1);
   return data(c3);
}

// (diff 'lst 'lst) -> lst
any doDiff(any x) {
   cell c1, c2, c3;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   Push(c3, x = Nil);
   while (isCell(data(c1))) {
      if (!member(car(data(c1)), data(c2)))
         if (isNil(x))
            x = data(c3) = cons(car(data(c1)), Nil);
         else
            x = cdr(x) = cons(car(data(c1)), Nil);
      data(c1) = cdr(data(c1));
   }
   drop(c1);
   return data(c3);
}

// (index 'any 'lst) -> cnt | NIL
any doIndex(any x) {
   int n;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  x = EVAL(car(x));
   if (n = indx(Pop(c1), x))
      return boxCnt(n);
   return Nil;
}

// (offset 'lst1 'lst2) -> cnt | NIL
any doOffset(any x) {