subr.c

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

   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;
}

// (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);
   }
   n = 1;
   while (car(x) == Quote) {
      if (x == cdr(x))
         return T;
      if (!isCell(x = cdr(x)))
         return boxCnt(n);
      ++n;
   }
   y = x;
   while (isCell(x = cdr(x))) {
      if (x == y)
         return T;
      ++n;
   }
   return boxCnt(n);
}

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

   n = 1;
   while (car(x) == Quote) {
      if (x == cdr(x)  ||  !isCell(x = cdr(x)))
         return n;
      ++n;
   }
   y = x;
   if (isCell(car(x)))
      n += size(car(x));
   while (isCell(x = cdr(x))  &&  x != y) {
      ++n;
      if (isCell(car(x)))
         n += size(car(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;
}

// (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;
}

// (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;
}

static any Rank;

any rank1(any lst, int n) {
   int i;

   if (isCell(car(lst)) && compare(caar(lst), Rank) > 0)
      return NULL;
   if (n == 1)
      return car(lst);
   i = n / 2;
   return rank1(nCdr(i,lst), n-i) ?: rank1(lst, i);
}

any rank2(any lst, int n) {
   int i;

   if (isCell(car(lst)) && compare(Rank, caar(lst)) > 0)
      return NULL;
   if (n == 1)
      return car(lst);
   i = n / 2;
   return rank2(nCdr(i,lst), n-i) ?: rank2(lst, i);
}

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

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, y = EVAL(car(x)));
   x = cdr(x),  x = EVAL(car(x));
   Rank = Pop(c1);
   if (!isCell(y))
      return Nil;
   if (isNil(x))
      return rank1(y, length(y)) ?: Nil;
   return rank2(y, length(y)) ?: Nil;
}

/* 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 !isCell(d) && 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
         (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)?
         val(x) : NULL;
   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 (unDig(n1) == unDig(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 (unDig(n2) == unDig(caaar(x))  &&  x2 == cdaar(x)) {
            n2 = cadar(x);
            x2 = cddar(x);
            goto lookup2;
         }
   if (unDig(n1) == unDig(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 (unDig(n) == unDig(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, q, dbg, env, n, nl, alt, tp1, tp2, e;

   x = cdr(x);
   if (!isCell(data(q) = EVAL(car(x))))
      return Nil;
   Save(q);
   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)))), crlf();
            }
            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) = EVAL(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 (isSym(caar(x)) && firstByte(caar(x)) == '@') {
         if (!isNil(data(e) = EVAL(cdar(x)))  &&
                     unify(car(data(nl)), caar(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 (!unDig(caaar(x)))
         data(e) = cons(cons(cdaar(x), lookup(Zero, cdaar(x))), data(e));
   drop(q);
   Penv = envSave,  Pnl = nlSave;
   return isCell(data(e))? data(e) : isCell(data(env))? T : Nil;
}

// (-> sym [num]) -> any
any doLookup(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 */
// (sort 'lst) -> lst
any doSort(any x) {
   int i;
   any p, in[2], out[2], last;
   any *tail[2];

   x = cdr(x);
   if (!isCell(out[0] = EVAL(car(x))))
      return out[0];

   out[1] = Nil;

   do {
      in[0] = out[0];
      in[1] = out[1];

      i  =  isCell(in[1])  &&  compare(in[0], in[1]) >= 0;
      if (isCell(p = in[i]))
         in[i] = cdr(in[i]);
      out[0] = p;
      tail[0] = &cdr(p);
      last = out[0];
      cdr(p) = Nil;
      i = 0;
      out[1] = Nil;
      tail[1] = &out[1];

      while (isCell(in[0]) || isCell(in[1])) {
         if (!isCell(in[1])) {
            if (isCell(p = in[0]))
               in[0] = cdr(in[0]);
            if (compare(p,last) < 0)
               i = 1-i;
         }
         else if (!isCell(in[0])) {
            p = in[1],  in[1] = cdr(in[1]);
            if (compare(p,last) < 0)
               i = 1-i;
         }
         else if (compare(in[0],last) < 0) {
            if (compare(in[1],last) >= 0)
               p = in[1],  in[1] = cdr(in[1]);
            else {
               if (compare(in[0],in[1]) < 0)
                  p = in[0],  in[0] = cdr(in[0]);
               else
                  p = in[1],  in[1] = cdr(in[1]);
               i = 1-i;
            }
         }
         else {
            if (compare(in[1],last) < 0)
               p = in[0],  in[0] = cdr(in[0]);
            else {
               if (compare(in[0],in[1]) < 0)
                  p = in[0],  in[0] = cdr(in[0]);
               else
                  p = in[1],  in[1] = cdr(in[1]);
            }
         }
         *tail[i] = p;
         tail[i] = &cdr(p);
         cdr(p) = Nil;
         last = p;
      }
   } while (isCell(out[1]));
   return out[0];
}