subr.c

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

/* 10oct07abu
 * (c) Software Lab. Alexander Burger
 */

#include "pico.h"

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

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));
   NeedLst(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));
   NeedLst(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));
   NeedLst(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));
   NeedLst(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));
   NeedLst(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));
   NeedLst(ex,x);
   return cddar(x);
}

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

any doCadddr(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedLst(ex,x);
   return cadddr(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)));
   NeedCell(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 = isCell(x = cdr(x))? evCnt(ex,x) : 0;
      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 ..) -> 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
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)));
   Push(c2, EVAL(cadr(x)));
   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);
}

// (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;
   cell c1, c2;

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

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))) {
      car(Env.make) = EVAL(car(x));
      if (x = cdr(x), !isCell(x = EVAL(car(x))))
         for (x = car(Env.make);  isCell(cdr(x));  x = cdr(x));
      cdr(Env.make) = x;
   }
   return car(Env.make);
}

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

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

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

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

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

   if (!Env.make)
      makeError(x);
   x = cdr(x);
   do {
      if (isCell(car(Env.make)))
         car(Env.make) = cons(y = EVAL(car(x)), car(Env.make));
      else
         car(Env.make) = cdr(Env.make) = cons(y = EVAL(car(x)), Nil);
   } while (isCell(x = cdr(x)));
   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(x))) {
      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;
   cell c1, c2;

   while (isCell(cdr(x = cdr(x)))) {
      if (isCell(data(c1) = EVAL(car(x)))) {
         Save(c1);
         Push(c2, y = cons(car(data(c1)),cdr(data(c1))));
         while (isCell(data(c1) = cdr(data(c1))))
            y = cdr(y) = cons(car(data(c1)),cdr(data(c1)));
         while (isCell(cdr(x = cdr(x)))) {
            data(c1) = EVAL(car(x));
            while (isCell(data(c1))) {
               y = cdr(y) = cons(car(data(c1)),cdr(data(c1)));
               data(c1) = cdr(data(c1));
            }
            cdr(y) = data(c1);
         }
         cdr(y) = EVAL(car(x));
         drop(c1);
         return data(c2);
      }
   }
   return EVAL(car(x));
}

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

   x = cdr(x),  Push(c1, y = EVAL(car(x)));
   x = cdr(x);
   if (!isCell(x = EVAL(car(x)))) {
      drop(c1);
      return x;
   }
   if (equal(y, car(x))) {
      drop(c1);
      return cdr(x);
   }
   Push(c2, x);
   Push(c3, z = cons(car(x), Nil));
   while (isCell(x = cdr(x))) {
      if (equal(y, car(x))) {
         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) -> lst
any doDelq(any x) {
   any y, z;
   cell c1, c2, c3;

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

// (strip 'any) -> any
any doStrip(any x) {
   x = cdr(x),  x = EVAL(car(x));