Read This! | Picolisp | Picolisp Machine | Pil Sources | Pil Tutorials | Linux | BASH | C-Programmming | Javascipt | Python | Scheme | Operating Systems | AssemblyLanguage | Computer Security | Firewalls | Exploitation | Social Engineering | Metasploit | Emacs | vim | Pharo Smalltalk | Databases | Networking | Machine Learning | Git | Machine Learning | Algorithms | Open Data Science

subr.c

/* 05apr17abu
 * (c) Software Lab. Alexander Burger
 */

#include "pico.h"

// (car 'var) -> any
any doCar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return car(x);
}

// (cdr 'lst) -> any
any doCdr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cdr(x);
}

any doCaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return caar(x);
}

any doCadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cadr(x);
}

any doCdar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cdar(x);
}

any doCddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cddr(x);
}

any doCaaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return caaar(x);
}

any doCaadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return caadr(x);
}

any doCadar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cadar(x);
}

any doCaddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return caddr(x);
}

any doCdaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cdaar(x);
}

any doCdadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cdadr(x);
}

any doCddar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cddar(x);
}

any doCdddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cdddr(x);
}

any doCaaaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return caaaar(x);
}

any doCaaadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return caaadr(x);
}

any doCaadar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return caadar(x);
}

any doCaaddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return caaddr(x);
}

any doCadaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cadaar(x);
}

any doCadadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cadadr(x);
}

any doCaddar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return caddar(x);
}

any doCadddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cadddr(x);
}

any doCdaaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cdaaar(x);
}

any doCdaadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cdaadr(x);
}

any doCdadar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cdadar(x);
}

any doCdaddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cdaddr(x);
}

any doCddaar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cddaar(x);
}

any doCddadr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cddadr(x);
}

any doCdddar(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedVar(ex,x);
   return cdddar(x);
}

any doCddddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cddddr(x);
}

// (nth 'lst 'cnt ..) -> lst
any doNth(any ex) {
   any x;
   cell c1;

   x = cdr(ex),  Push(c1, EVAL(car(x))),  x = cdr(x);
   for (;;) {
      if (!isCell(data(c1)))
         return Pop(c1);
      data(c1) = nth((int)evCnt(ex,x), data(c1));
      if (!isCell(x = cdr(x)))
         return Pop(c1);
      data(c1) = car(data(c1));
   }
}

// (con 'lst 'any) -> any
any doCon(any ex) {
   any x;
   cell c1;

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

// (cons 'any ['any ..]) -> lst
any doCons(any x) {
   any y;
   cell c1;

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

// (conc 'lst ..) -> lst
any doConc(any x) {
   any y, z;
   cell c1;

   x = cdr(x),  Push(c1, y = EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      z = EVAL(car(x));
      if (!isCell(y))
         y = data(c1) = z;
      else {
         while (isCell(cdr(y)))
            y = cdr(y);
         cdr(y) = z;
      }
   }
   return Pop(c1);
}

// (circ 'any ..) -> lst
any doCirc(any x) {
   any y;
   cell c1;

   x = cdr(x);
   Push(c1, y = cons(EVAL(car(x)),Nil));
   while (isCell(x = cdr(x)))
      y = cdr(y) = cons(EVAL(car(x)),Nil);
   cdr(y) = data(c1);
   return Pop(c1);
}

// (rot 'lst ['cnt]) -> lst
any doRot(any ex) {
   any x, y, z;
   int n;
   cell c1;

   x = cdr(ex),  Push(c1, y = EVAL(car(x)));
   if (isCell(y)) {
      n = 0;
      if (!isCell(x = cdr(x)) || (n = (int)evCnt(ex,x))) {
         x = car(y);
         while (--n  &&  isCell(y = cdr(y))  &&  y != data(c1))
            z = car(y),  car(y) = x,  x = z;
         car(data(c1)) = x;
      }
   }
   return Pop(c1);
}

// (list 'any ['any ..]) -> lst
any doList(any x) {
   any y;
   cell c1;

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

// (need 'cnt ['lst ['any]]) -> lst
// (need 'cnt ['num|sym]) -> lst
any doNeed(any ex) {
   int n;
   any x;
   cell c1, c2;

   n = (int)evCnt(ex, x = cdr(ex));
   x = cdr(x),  Push(c1, EVAL(car(x)));
   if (isCell(data(c1)) || isNil(data(c1)))
      Push(c2, EVAL(cadr(x)));
   else {
      Push(c2, data(c1));
      data(c1) = Nil;
   }
   x = data(c1);
   if (n > 0)
      for (n -= length(x); n > 0; --n)
         data(c1) = cons(data(c2), data(c1));
   else if (n) {
      if (!isCell(x))
         data(c1) = x = cons(data(c2),Nil);
      else
         while (isCell(cdr(x)))
            ++n,  x = cdr(x);
      while (++n < 0)
         x = cdr(x) = cons(data(c2),Nil);
   }
   return Pop(c1);
}

// (range 'num1 'num2 ['num3]) -> lst
any doRange(any ex) {
   any x;
   cell c1, c2, c3, c4;

   x = cdr(ex),  Push(c1, EVAL(car(x)));  // Start value
   NeedNum(ex,data(c1));
   x = cdr(x),  Push(c2, EVAL(car(x)));  // End value
   NeedNum(ex,data(c2));
   x = cdr(x),  Push(c3, One);  // Increment
   if (!isNil(x = EVAL(car(x)))) {
      NeedNum(ex, data(c3) = x);
      if (IsZero(x) || isNeg(x))
         argError(ex,x);
   }
   Push(c4, x = cons(data(c1), Nil));
   if (bigCompare(data(c2), data(c1)) >= 0) {
      for (;;) {
         data(c1) = bigCopy(data(c1));
         if (!isNeg(data(c1)))
            bigAdd(data(c1), data(c3));
         else {
            bigSub(data(c1), data(c3));
            if (!IsZero(data(c1)))
               neg(data(c1));
         }
         if (bigCompare(data(c2), data(c1)) < 0)
            break;
         x = cdr(x) = cons(data(c1), Nil);
      }
   }
   else {
      for (;;) {
         data(c1) = bigCopy(data(c1));
         if (!isNeg(data(c1)))
            bigSub(data(c1), data(c3));
         else {
            bigAdd(data(c1), data(c3));
            if (!IsZero(data(c1)))
               neg(data(c1));
         }
         if (bigCompare(data(c2), data(c1)) > 0)
            break;
         x = cdr(x) = cons(data(c1), Nil);
      }
   }
   drop(c1);
   return data(c4);
}

// (full 'any) -> bool
any doFull(any x) {
   x = cdr(x);
   for (x = EVAL(car(x)); isCell(x); x = cdr(x))
      if (isNil(car(x)))
         return Nil;
   return T;
}

// (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any
any doMake(any x) {
   any *make, *yoke;
   cell c1;

   Push(c1, Nil);
   make = Env.make;
   yoke = Env.yoke;
   Env.make = Env.yoke = &data(c1);
   while (isCell(x = cdr(x)))
      if (isCell(car(x)))
         evList(car(x));
   Env.yoke = yoke;
   Env.make = make;
   return Pop(c1);
}

static void makeError(any ex) {err(ex, NULL, "Not making");}

// (made ['lst1 ['lst2]]) -> lst
any doMade(any x) {
   if (!Env.make)
      makeError(x);
   if (isCell(x = cdr(x))) {
      *Env.yoke = EVAL(car(x));
      if (x = cdr(x), !isCell(x = EVAL(car(x)))) {
         any y;

         x = *Env.yoke;
         while (isCell(y = cdr(x)))
            x = y;
      }
      Env.make = &cdr(x);
   }
   return *Env.yoke;
}

// (chain 'lst ..) -> lst
any doChain(any x) {
   any y;

   if (!Env.make)
      makeError(x);
   x = cdr(x);
   do
      if (isCell(*Env.make = y = EVAL(car(x))))
         do
            Env.make = &cdr(*Env.make);
         while (isCell(*Env.make));
   while (isCell(x = cdr(x)));
   return y;
}

// (link 'any ..) -> any
any doLink(any x) {
   any y;

   if (!Env.make)
      makeError(x);
   x = cdr(x);
   do {
      y = EVAL(car(x));
      Env.make = &cdr(*Env.make = cons(y, Nil));
   } while (isCell(x = cdr(x)));
   return y;
}

// (yoke 'any ..) -> any
any doYoke(any x) {
   any y;

   if (!Env.make)
      makeError(x);
   x = cdr(x);
   do {
      y = EVAL(car(x));
      *Env.yoke = cons(y, *Env.yoke);
   } while (isCell(x = cdr(x)));
   while (isCell(*Env.make))
      Env.make = &cdr(*Env.make);
   return y;
}

// (copy 'any) -> any
any doCopy(any x) {
   any y, z;
   cell c1;

   x = cdr(x);
   if (!isCell(x = EVAL(car(x))))
      return x;
   Push(c1, y = cons(car(x), cdr(z = x)));
   while (isCell(x = cdr(y))) {
      if (x == z) {
         cdr(y) = data(c1);
         break;
      }
      y = cdr(y) = cons(car(x), cdr(x));
   }
   return Pop(c1);
}

// (mix 'lst cnt|'any ..) -> lst
any doMix(any x) {
   any y;
   cell c1, c2;

   x = cdr(x);
   if (!isCell(data(c1) = EVAL(car(x))) && !isNil(data(c1)))
      return data(c1);
   if (!isCell(x = cdr(x)))
      return Nil;
   Save(c1);
   Push(c2,
      y = cons(
         isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)),
         Nil ) );
   while (isCell(x = cdr(x)))
      y = cdr(y) = cons(
         isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)),
         Nil );
   drop(c1);
   return data(c2);
}

// (append 'lst ..) -> lst
any doAppend(any x) {
   any y, z;
   cell c1;

   while (isCell(cdr(x = cdr(x)))) {
      if (isCell(y = EVAL(car(x)))) {
         Push(c1, z = cons(car(y), cdr(y)));
         while (isCell(y = cdr(z)))
            z = cdr(z) = cons(car(y), cdr(y));
         while (isCell(cdr(x = cdr(x)))) {
            for (y = EVAL(car(x)); isCell(y); y = cdr(z))
               z = cdr(z) = cons(car(y), cdr(y));
            cdr(z) = y;
         }
         cdr(z) = EVAL(car(x));
         return Pop(c1);
      }
   }
   return EVAL(car(x));
}

// (delete 'any 'lst ['flg]) -> lst
any doDelete(any ex) {
   any x, y, z;
   bool flg;
   cell c1, c2, c3;

   x = cdr(ex),  Push(c1, y = EVAL(car(x)));
   x = cadr(x),  x = EVAL(x);
   flg = !isNil(EVAL(cadddr(ex)));
   for (;;) {
      if (!isCell(x)) {
         drop(c1);
         return x;
      }
      if (!equal(y, car(x)))
         break;
      x = cdr(x);
      if (!flg) {
         drop(c1);
         return x;
      }
   }
   Push(c2, x);
   Push(c3, z = cons(car(x), Nil));
   while (isCell(x = cdr(x))) {
      if (equal(y, car(x))) {
         if (flg)
            continue;
         cdr(z) = cdr(x);
         drop(c1);
         return data(c3);
      }
      z = cdr(z) = cons(car(x), Nil);
   }
   cdr(z) = x;
   drop(c1);
   return data(c3);
}

// (delq 'any 'lst ['flg]) -> lst
any doDelq(any ex) {
   any x, y, z;
   bool flg;
   cell c1, c2, c3;

   x = cdr(ex),  Push(c1, y = EVAL(car(x)));
   x = cadr(x),  x = EVAL(x);
   flg = !isNil(EVAL(cadddr(ex)));
   for (;;) {
      if (!isCell(x)) {
         drop(c1);
         return x;
      }
      if (y != car(x))
         break;
      x = cdr(x);
      if (!flg) {
         drop(c1);
         return x;
      }
   }
   Push(c2, x);
   Push(c3, z = cons(car(x), Nil));
   while (isCell(x = cdr(x))) {
      if (y == car(x)) {
         if (flg)
            continue;
         cdr(z) = cdr(x);
         drop(c1);
         return data(c3);
      }
      z = cdr(z) = cons(car(x), Nil);
   }
   cdr(z) = x;
   drop(c1);
   return data(c3);
}

// (replace 'lst 'any1 'any2 ..) -> lst
any doReplace(any x) {
   any y;
   int i, n = length(cdr(x = cdr(x))) + 1 & ~1;
   cell c1, c2, c[n];

   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)));
   for (x = car(data(c1)), i = 0;  i < n;  i += 2)
      if (equal(x, data(c[i]))) {
         x = data(c[i+1]);
         break;
      }
   Push(c2, y = cons(x,Nil));
   while (isCell(data(c1) = cdr(data(c1)))) {
      for (x = car(data(c1)), i = 0;  i < n;  i += 2)
         if (equal(x, data(c[i]))) {
            x = data(c[i+1]);
            break;
         }
      y = cdr(y) = cons(x, Nil);
   }
   cdr(y) = data(c1);
   drop(c1);
   return data(c2);
}

// (insert 'cnt 'lst 'any) -> lst
any doInsert(any x) {
   long n;
   any y;
   cell c1, c2;

   n = evCnt(x, cdr(x)),  x = cddr(x);
   Push(c1, EVAL(car(x))),  x = cdr(x);
   if (!isCell(data(c1)) || --n <= 0) {
      x = cons(EVAL(car(x)), data(c1));
      drop(c1);
      return x;
   }
   Push(c2, y = cons(car(data(c1)), Nil));
   while (isCell(data(c1) = cdr(data(c1))) && --n)
      y = cdr(y) = cons(car(data(c1)), Nil);
   cdr(y) = cons(EVAL(car(x)), data(c1));
   drop(c1);
   return data(c2);
}

// (remove 'cnt 'lst) -> lst
any doRemove(any x) {
   long n;
   any y;
   cell c1, c2;

   n = evCnt(x, cdr(x)),  x = cddr(x);
   if (!isCell(data(c1) = EVAL(car(x))) || --n < 0)
      return data(c1);
   if (!n)
      return cdr(data(c1));
   Save(c1);
   Push(c2, y = cons(car(data(c1)), Nil));
   while (isCell(data(c1) = cdr(data(c1))) && --n)
      y = cdr(y) = cons(car(data(c1)), Nil);
   cdr(y) = cdr(data(c1));
   drop(c1);
   return data(c2);
}

// (place 'cnt 'lst 'any) -> lst
any doPlace(any x) {
   long n;
   any y;
   cell c1, c2;

   n = evCnt(x, cdr(x)),  x = cddr(x);
   data(c1) = EVAL(car(x)),  x = cdr(x);
   if (!isCell(data(c1)))
      return EVAL(car(x));
   Save(c1);
   if (--n <= 0) {
      x = cons(EVAL(car(x)), cdr(data(c1)));
      drop(c1);
      return x;
   }
   Push(c2, y = cons(car(data(c1)), Nil));
   while (isCell(data(c1) = cdr(data(c1))) && --n)
      y = cdr(y) = cons(car(data(c1)), Nil);
   cdr(y) = cons(EVAL(car(x)), cdr(data(c1)));
   drop(c1);
   return data(c2);
}

// (strip 'any) -> any
any doStrip(any x) {
   x = cdr(x),  x = EVAL(car(x));
   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 ['cnt])) -> lst
any doFlip(any ex) {
   any x, y, z;
   int n;
   cell c1;

   x = cdr(ex);
   if (!isCell(y = EVAL(car(x))) || !isCell(z = cdr(y)))
      return y;
   if (!isCell(x = cdr(x))) {
      cdr(y) = Nil;
      for (;;) {
         x = cdr(z),  cdr(z) = y;
         if (!isCell(x))
            return z;
         y = z,  z = x;
      }
   }
   Push(c1, y);
   n = (int)evCnt(ex,x) - 1;
   drop(c1);
   if (n <= 0)
      return y;
   cdr(y) = cdr(z),  cdr(z) = y;
   while (--n && isCell(x = cdr(y)))
      cdr(y) = cdr(x),  cdr(x) = z,  z = x;
   return 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;
   x = cdr(x);
   if (isCell(data(c1))) {
      Save(c1);
      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;
   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;
   x = cdr(x);
   if (isCell(data(c1))) {
      Save(c1);
      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;
   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);
            break;
         }
   }
   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) -> 0 | NIL
any doEq0(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && IsZero(x)? x : Nil;
}

// (=1 'any) -> 1 | NIL
any doEq1(any x) {
   x = cdr(x);
   return isNum(x = EVAL(car(x))) && (unDig(x)==2 && !isNum(cdr(numCell(x))))? x : Nil;
}

// (=T 'any) -> flg
any doEqT(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)))
      if (compare(y = EVAL(car(x)), 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)))
      if (compare(y = EVAL(car(x)), 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;
}

// (circ? 'any) -> any
any doCircQ(any x) {
   x = cdr(x);
   return isCell(x = EVAL(car(x))) && (x = circ(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));
   return (n = indx(Pop(c1), x))? boxCnt(n) : Nil;
}

// (offset 'lst1 'lst2) -> cnt | NIL
any doOffset(any x) {
   int n;
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   for (n = 1, x = Pop(c1);  isCell(y);  ++n, y = cdr(y))
      if (equal(x,y))
         return boxCnt(n);
   return Nil;
}

// (prior 'lst1 'lst2) -> lst | NIL
any doPrior(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   if ((x = Pop(c1)) != y)
      while (isCell(y)) {
         if (x == cdr(y))
            return y;
         y = cdr(y);
      }
   return Nil;
}

// (length 'any) -> cnt | T
any doLength(any x) {
   int n, c;
   any y;

   if (isNum(x = EVAL(cadr(x))))
      return numToSym(x, 0, -1, 0);
   if (isSym(x)) {
      for (n = 0, c = symChar(name(x));  c;  ++n, c = symChar(NULL));
      return boxCnt(n);
   }
   for (n = 0, y = x;;) {
      ++n;
      *(word*)&car(y) |= 1;
      if (!isCell(y = cdr(y))) {
         do
            *(word*)&car(x) &= ~1;
         while (isCell(x = cdr(x)));
         return boxCnt(n);
      }
      if (num(car(y)) & 1) {
         while (x != y)
            *(word*)&car(x) &= ~1,  x = cdr(x);
         do
            *(word*)&car(x) &= ~1;
         while (y != (x = cdr(x)));
         return T;
      }
   }
}

static int size(any x) {
   int n;
   any y;

   for (n = 0, y = x;;) {
      ++n;
      if (isCell(car(y)))
         n += size(car(y));
      *(word*)&car(y) |= 1;
      if (!isCell(y = cdr(y))) {
         do
            *(word*)&car(x) &= ~1;
         while (isCell(x = cdr(x)));
         return n;
      }
      if (num(car(y)) & 1) {
         while (x != y)
            *(word*)&car(x) &= ~1,  x = cdr(x);
         do
            *(word*)&car(x) &= ~1;
         while (y != (x = cdr(x)));
         return n;
      }
   }
}

// (size 'any) -> cnt
any doSize(any ex) {
   any x = cdr(ex);

   if (isNum(x = EVAL(car(x))))
      return boxCnt(numBytes(x));
   if (!isSym(x))
      return boxCnt(size(x));
   if (isExt(x))
      return boxCnt(dbSize(ex,x));
   return isNum(x = name(x))? boxCnt(numBytes(x)) : Zero;
}

// (bytes 'any) -> cnt
any doBytes(any x) {
   return boxCnt(binSize(EVAL(cadr(x))));
}

// (assoc 'any 'lst) -> lst
any doAssoc(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   for (x = Pop(c1);  isCell(y);  y = cdr(y))
      if (isCell(car(y)) && equal(x,caar(y)))
         return car(y);
   return Nil;
}

// (rassoc 'any 'lst) -> lst
any doRassoc(any x) {
   any y;
   cell c1;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   for (x = Pop(c1);  isCell(y);  y = cdr(y))
      if (isCell(car(y)) && equal(x,cdar(y)))
         return car(y);
   return Nil;
}

// (asoq 'any 'lst) -> lst
any doAsoq(any x) {
   any y;
   cell c1;

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

// (rank 'any 'lst ['flg]) -> lst
any doRank(any x) {
   any y, z;
   cell c1, c2;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, y = EVAL(car(x)));
   z = Nil;
   x = cdr(x);
   if (isNil(EVAL(car(x))))
      for (x = Pop(c1);  isCell(y);  y = cdr(y)) {
         if (compare(caar(y), x) > 0)
            break;
         z = y;
      }
   else
      for (x = Pop(c1);  isCell(y);  y = cdr(y)) {
         if (compare(x, caar(y)) > 0)
            break;
         z = y;
      }
   return car(z);
}

/* Pattern matching */
bool match(any p, any d) {
   any x;

   for (;;) {
      if (!isCell(p)) {
         if (isSym(p)  &&  firstByte(p) == '@') {
            val(p) = d;
            return YES;
         }
         return equal(p,d);
      }
      if (isSym(x = car(p))  &&  firstByte(x) == '@') {
         if (!isCell(d)) {
            if (equal(d, cdr(p))) {
               val(x) = Nil;
               return YES;
            }
            return NO;
         }
         if (match(cdr(p), cdr(d))) {
            val(x) = cons(car(d), Nil);
            return YES;
         }
         if (match(cdr(p), d)) {
            val(x) = Nil;
            return YES;
         }
         if (match(p, cdr(d))) {
            val(x) = cons(car(d), val(x));
            return YES;
         }
      }
      if (!isCell(d) || !match(x, car(d)))
         return NO;
      p = cdr(p);
      d = cdr(d);
   }
}

// (match 'lst1 'lst2) -> flg
any doMatch(any x) {
   cell c1, c2;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   x = match(data(c1), data(c2))? T : Nil;
   drop(c1);
   return x;
}

// Fill template structure
static any fill(any x, any s) {
   any y;
   cell c1;

   if (isNum(x))
      return NULL;
   if (isSym(x))
      return x != val(x) && (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? val(x) : NULL;
   if (car(x) == Up) {
      x = cdr(x);
      if (!isCell(y = EVAL(car(x))))
         return fill(cdr(x), s) ?: cdr(x);
      Push(c1, y);
      while (isCell(cdr(y)))
         y = cdr(y);
      cdr(y) = fill(cdr(x), s) ?: cdr(x);
      return Pop(c1);
   }
   if (y = fill(car(x), s)) {
      Push(c1,y);
      y = fill(cdr(x), s);
      return cons(Pop(c1), y ?: cdr(x));
   }
   if (y = fill(cdr(x), s))
      return cons(car(x), y);
   return NULL;
}

// (fill 'any ['sym|lst]) -> any
any doFill(any x) {
   cell c1, c2;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   if (x = fill(data(c1), data(c2))) {
      drop(c1);
      return x;
   }
   return Pop(c1);
}

/* Declarative Programming */
cell *Penv, *Pnl;

static bool unify(any n1, any x1, any n2, any x2) {
   any x, env;

lookup1:
   if (isSym(x1)  &&  firstByte(x1) == '@')
      for (x = data(*Penv);  isCell(car(x));  x = cdr(x))
         if (equal(n1, caaar(x))  &&  x1 == cdaar(x)) {
            n1 = cadar(x);
            x1 = cddar(x);
            goto lookup1;
         }
lookup2:
   if (isSym(x2)  &&  firstByte(x2) == '@')
      for (x = data(*Penv);  isCell(car(x));  x = cdr(x))
         if (equal(n2, caaar(x))  &&  x2 == cdaar(x)) {
            n2 = cadar(x);
            x2 = cddar(x);
            goto lookup2;
         }
   if (equal(n1, n2)  &&  equal(x1, x2))
      return YES;
   if (isSym(x1)  &&  firstByte(x1) == '@') {
      if (x1 != At) {
         data(*Penv) = cons(cons(cons(n1,x1), Nil), data(*Penv));
         cdar(data(*Penv)) = cons(n2,x2);
      }
      return YES;
   }
   if (isSym(x2)  &&  firstByte(x2) == '@') {
      if (x2 != At) {
         data(*Penv) = cons(cons(cons(n2,x2), Nil), data(*Penv));
         cdar(data(*Penv)) = cons(n1,x1);
      }
      return YES;
   }
   if (!isCell(x1) || !isCell(x2))
      return equal(x1, x2);
   env = data(*Penv);
   if (unify(n1, car(x1), n2, car(x2))  &&  unify(n1, cdr(x1), n2, cdr(x2)))
      return YES;
   data(*Penv) = env;
   return NO;
}

static any lup(any n, any x) {
   any y;
   cell c1;

lup:
   if (isSym(x)  &&  firstByte(x) == '@')
      for (y = data(*Penv);  isCell(car(y));  y = cdr(y))
         if (equal(n, caaar(y))  &&  x == cdaar(y)) {
            n = cadar(y);
            x = cddar(y);
            goto lup;
         }
   if (!isCell(x))
      return x;
   Push(c1, lup(n, car(x)));
   x = lup(n, cdr(x));
   return cons(Pop(c1), x);
}

static any lookup(any n, any x) {
   return isSym(x = lup(n,x)) && firstByte(x)=='@'?  Nil : x;
}

static any uniFill(any x) {
   cell c1;

   if (isNum(x))
      return x;
   if (isSym(x))
      return lup(car(data(*Pnl)), x);
   Push(c1, uniFill(car(x)));
   x = uniFill(cdr(x));
   return cons(Pop(c1), x);
}

// (prove 'lst ['lst]) -> lst
any doProve(any x) {
   int i;
   cell *envSave, *nlSave, at, q, dbg, env, n, nl, alt, tp1, tp2, e;

   x = cdr(x);
   if (!isCell(data(q) = EVAL(car(x))))
      return Nil;
   Save(q);
   Push(at,val(At));
   envSave = Penv,  Penv = &env,  nlSave = Pnl,  Pnl = &nl;
   if (x = cdr(x), isNil(x = EVAL(car(x))))
      data(dbg) = NULL;
   else
      Push(dbg, x);
   Push(env, caar(data(q))),  car(data(q)) = cdar(data(q));
   Push(n, car(data(env))),  data(env) = cdr(data(env));
   Push(nl, car(data(env))),  data(env) = cdr(data(env));
   Push(alt, car(data(env))),  data(env) = cdr(data(env));
   Push(tp1, car(data(env))),  data(env) = cdr(data(env));
   Push(tp2, car(data(env))),  data(env) = cdr(data(env));
   Push(e,Nil);
   while (isCell(data(tp1)) || isCell(data(tp2))) {
      if (isCell(data(alt))) {
         data(e) = data(env);
         if (!unify(car(data(nl)), cdar(data(tp1)), data(n), caar(data(alt)))) {
            if (!isCell(data(alt) = cdr(data(alt)))) {
               data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
               data(n) = car(data(env)),  data(env) = cdr(data(env));
               data(nl) = car(data(env)),  data(env) = cdr(data(env));
               data(alt) = car(data(env)),  data(env) = cdr(data(env));
               data(tp1) = car(data(env)),  data(env) = cdr(data(env));
               data(tp2) = car(data(env)),  data(env) = cdr(data(env));
            }
         }
         else {
            if (data(dbg)  &&  memq(caar(data(tp1)), data(dbg))) {
               outWord(indx(car(data(alt)), get(caar(data(tp1)), T)));
               space();
               print(uniFill(car(data(tp1)))), newline();
            }
            if (isCell(cdr(data(alt))))
               car(data(q)) =
                  cons(
                     cons(data(n),
                        cons(data(nl),
                           cons(cdr(data(alt)),
                              cons(data(tp1), cons(data(tp2),data(e))) ) ) ),
                     car(data(q)) );
            data(nl) = cons(data(n), data(nl));
            data(n) = box(2 + unDig(data(n)));
            data(tp2) = cons(cdr(data(tp1)), data(tp2));
            data(tp1) = cdar(data(alt));
            data(alt) = Nil;
         }
      }
      else if (!isCell(x = data(tp1))) {
         data(tp1) = car(data(tp2)),  data(tp2) = cdr(data(tp2));
         data(nl) = cdr(data(nl));
      }
      else if (car(x) == T) {
         while (isCell(car(data(q)))  &&
                              unDig(caaar(data(q))) >= unDig(car(data(nl))) )
            car(data(q)) = cdar(data(q));
         data(tp1) = cdr(x);
      }
      else if (isNum(caar(x))) {
         data(e) = prog(cdar(x));
         for (i = unDig(caar(x)), x = data(nl);  (i -= 2) > 0;)
            x = cdr(x);
         data(nl) = cons(car(x), data(nl));
         data(tp2) = cons(cdr(data(tp1)), data(tp2));
         data(tp1) = data(e);
      }
      else if (caar(x) == Up) {
         if (!isNil(data(e) = prog(cddar(x)))  &&
                     unify(car(data(nl)), cadar(x), car(data(nl)), data(e)) )
            data(tp1) = cdr(x);
         else {
            data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
            data(n) = car(data(env)),  data(env) = cdr(data(env));
            data(nl) = car(data(env)),  data(env) = cdr(data(env));
            data(alt) = car(data(env)),  data(env) = cdr(data(env));
            data(tp1) = car(data(env)),  data(env) = cdr(data(env));
            data(tp2) = car(data(env)),  data(env) = cdr(data(env));
         }
      }
      else if (!isCell(data(alt) = get(caar(x), T))) {
         data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
         data(n) = car(data(env)),  data(env) = cdr(data(env));
         data(nl) = car(data(env)),  data(env) = cdr(data(env));
         data(alt) = car(data(env)),  data(env) = cdr(data(env));
         data(tp1) = car(data(env)),  data(env) = cdr(data(env));
         data(tp2) = car(data(env)),  data(env) = cdr(data(env));
      }
   }
   for (data(e) = Nil,  x = data(env);  isCell(cdr(x));  x = cdr(x))
      if (isNum(caaar(x)) && IsZero(caaar(x)))
         data(e) = cons(cons(cdaar(x), lookup(Zero, cdaar(x))), data(e));
   val(At) = data(at);
   drop(q);
   Penv = envSave,  Pnl = nlSave;
   return isCell(data(e))? data(e) : isCell(data(env))? T : Nil;
}

// (-> any [cnt]) -> any
any doArrow(any x) {
   int i;
   any y;

   if (!isNum(caddr(x)))
      return lookup(car(data(*Pnl)), cadr(x));
   for (i = unDig(caddr(x)), y = data(*Pnl);  (i -= 2) > 0;)
      y = cdr(y);
   return lookup(car(y), cadr(x));
}

// (unify 'any) -> lst
any doUnify(any x) {
   cell c1;

   Push(c1, EVAL(cadr(x)));
   if (unify(cadr(data(*Pnl)), data(c1), car(data(*Pnl)), data(c1))) {
      drop(c1);
      return data(*Penv);
   }
   drop(c1);
   return Nil;
}

/* List Merge Sort: Bill McDaniel, DDJ Jun99 */
static bool cmp(any ex, any foo, cell c[2]) {
   if (isNil(foo))
      return compare(car(data(c[0])), car(data(c[1]))) < 0;
   return !isNil(apply(ex, foo, YES, 2, c));
}

// (group 'lst) -> lst
any doGroup(any x) {
   any y, z;
   cell c1, c2;

   x = cdr(x);
   if (!isCell(x = EVAL(car(x))))
      return Nil;
   Push(c1, x);
   Push(c2, y = cons(cdar(x), Nil));
   data(c2) = cons(cons(caar(x), cons(y,y)), Nil);
   while (isCell(x = cdr(x))) {
      y = cons(cdar(x), Nil);
      for (z = data(c2);;) {
         if (equal(caar(z), caar(x))) {
            z = cdar(z),  car(z) = cdar(z) = y;
            break;
         }
         if (!isCell(cdr(z))) {
            cdr(z) = y;
            cdr(z) = cons(cons(caar(x), cons(y,y)), Nil);
            break;
         }
         z = cdr(z);
      }
   }
   x = data(c2);
   do
      cdar(x) = cddar(x);
   while (isCell(x = cdr(x)));
   drop(c1);
   return data(c2);
}

// (sort 'lst ['fun]) -> lst
any doSort(any ex) {
   int i;
   any x;
   cell p, foo, in[2], out[2], last[2];
   any *tail[2];

   x = cdr(ex);
   if (!isCell(data(out[0]) = EVAL(car(x))))
      return data(out[0]);
   Save(out[0]);
   x = cdr(x),  Push(foo, EVAL(car(x)));
   Push(out[1], Nil);
   Save(in[0]);
   Save(in[1]);
   Push(p, Nil);
   Push(last[1], Nil);
   do {
      data(in[0]) = data(out[0]);
      data(in[1]) = data(out[1]);

      i = isCell(data(in[1]))  &&  !cmp(ex, data(foo), in);
      if (isCell(data(p) = data(in[i])))
         data(in[i]) = cdr(data(in[i]));
      data(out[0]) = data(p);
      tail[0] = &cdr(data(p));
      data(last[1]) = data(out[0]);
      cdr(data(p)) = Nil;
      i = 0;
      data(out[1]) = Nil;
      tail[1] = &data(out[1]);
      while (isCell(data(in[0])) || isCell(data(in[1]))) {
         if (!isCell(data(in[1]))) {
            if (isCell(data(p) = data(in[0])))
               data(in[0]) = cdr(data(in[0]));
            data(last[0]) = data(p);
            if (cmp(ex, data(foo), last))
               i = 1 - i;
         }
         else if (!isCell(data(in[0]))) {
            data(last[0]) = data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
            if (cmp(ex, data(foo), last))
               i = 1 - i;
         }
         else if (data(last[0]) = data(in[0]),  cmp(ex, data(foo), last)) {
            data(last[0]) = data(in[1]);
            if (!cmp(ex, data(foo), last))
               data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
            else {
               if (cmp(ex, data(foo), in))
                  data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
               else
                  data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
               i = 1 - i;
            }
         }
         else {
            data(last[0]) = data(in[1]);
            if (cmp(ex, data(foo), last))
               data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
            else {
               if (cmp(ex, data(foo), in))
                  data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
               else
                  data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
            }
         }
         *tail[i] = data(p);
         tail[i] = &cdr(data(p));
         cdr(data(p)) = Nil;
         data(last[1]) = data(p);
      }
   } while (isCell(data(out[1])));
   return Pop(out[0]);
}

http:///wiki/?subrc

29jun17

admin