sym.c

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

         pack(car(x), i, nm, p);
      while (isCell(x = cdr(x)));
   if (!isNil(x)) {
      if (isNum(x)) {
         Push(c1, x = numToSym(x, 0, 0, 0));
         c = symChar(name(x));
         if (*nm)
            charSym(c, i, nm);
         else
            Tuck(*p, c1, boxChar(c, i, nm));
         while (c = symChar(NULL))
            charSym(c, i, nm);
         drop(c1);
      }
      else if (c = symChar(name(x))) {
         if (*nm) {
            if (isExt(x))
               charSym('{', i, nm);
            charSym(c, i, nm);
         }
         else if (!isExt(x))
            Push(*p, boxChar(c, i, nm));
         else {
            Push(*p, boxChar('{', i, nm));
            charSym(c, i, nm);
         }
         while (c = symChar(NULL))
            charSym(c, i, nm);
         if (isExt(x))
            charSym('}', i, nm);
      }
   }
}

// (pack 'any ..) -> sym
any doPack(any x) {
   int i;
   any nm;
   cell c1, c2;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   nm = NULL,  pack(data(c1), &i, &nm, &c2);
   while (isCell(x = cdr(x)))
      pack(data(c1) = EVAL(car(x)), &i, &nm, &c2);
   drop(c1);
   return nm? consStr(data(c2)) : Nil;
}

// (glue 'any 'lst) -> sym
any doGlue(any x) {
   int i;
   any nm;
   cell c1, c2, c3;

   x = cdr(x),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, x = EVAL(car(x)));
   if (!isCell(x)) {
      drop(c1);
      return x;
   }
   nm = NULL,  pack(car(x), &i, &nm, &c3);
   while (isCell(x = cdr(x))) {
      pack(data(c1), &i, &nm, &c3);
      pack(car(x), &i, &nm, &c3);
   }
   drop(c1);
   return nm? consStr(data(c3)) : Nil;
}

// (text 'sym 'any ..) -> sym
any doText(any x) {
   int c, n, i;
   any nm;
   any y = evSym(x = cdr(x));
   char *p, buf[bufSize(y)];
   cell c1;

   bufString(y, buf);
   if (!*(p = buf))
      return Nil;
   {
      cell arg[length(x = cdr(x))];

      for (n = 0;  isCell(x);  ++n, x = cdr(x))
         Push(arg[n], EVAL(car(x)));

      nm = NULL;
      do {
         if ((c = *p++) != '@') {
            if (nm)
               byteSym(c, &i, &nm);
            else
               i = 0,  Push(c1, nm = box(c & 0xFF));
         }
         else if (!(c = *p++))
            break;
         else if (c == '@') {
            if (nm)
               byteSym('@', &i, &nm);
            else
               i = 0,  Push(c1, nm = box('@'));
         }
         else if (c >= '1') {
            if ((c -= '1') > 8)
               c -= 7;
            if (n > c)
               pack(data(arg[c]), &i, &nm, &c1);
         }
      } while (*p);
      if (n)
         drop(arg[0]);
      else if (nm)
         drop(c1);
      return nm? consStr(data(c1)) : Nil;
   }
}

static bool subStr(word n1, any y, word n2, any x) {
   for (;;) {
      if ((n1 & 0xFF) != (n2 & 0xFF))
         return NO;
      if ((n1 >>= 8) == 0) {
         if (!isNum(y = cdr(numCell(y))))
            return YES;
         n1 = unDig(y);
      }
      if ((n2 >>= 8) == 0) {
         if (!isNum(x = cdr(numCell(x))))
            return NO;
         n2 = unDig(x);
      }
   }
}

// (pre? 'sym1 'sym2) -> flg
any doPreQ(any ex) {
   any x, y;
   cell c1;

   x = cdr(ex);
   if (isNil(y = EVAL(car(x))))
      return T;
   NeedSym(ex,y);
   if (!isNum(y = name(y)))
      return T;
   Push(c1, y);
   x = cdr(x),  x = EVAL(car(x));
   NeedSym(ex,x);
   drop(c1);
   if (!isNum(x = name(x)))
      return Nil;
   return subStr(unDig(y), y, unDig(x), x)? T : Nil;
}

// (sub? 'sym1 'sym2) -> flg
any doSubQ(any ex) {
   any x, y;
   word n;
   cell c1;

   x = cdr(ex);
   if (isNil(y = EVAL(car(x))))
      return T;
   NeedSym(ex,y);
   if (!isNum(y = name(y)))
      return T;
   Push(c1, y);
   x = cdr(x),  x = EVAL(car(x));
   NeedSym(ex,x);
   drop(c1);
   if (!isNum(x = name(x)))
      return Nil;
   n = unDig(x);
   for (;;) {
      if (subStr(unDig(y), y, n, x))
         return T;
      if ((n >>= 8) == 0) {
         if (!isNum(x = cdr(numCell(x))))
            return Nil;
         n = unDig(x);
      }
   }
}

// (val 'var) -> any
any doVal(any ex) {
   any x;

   x = cdr(ex),  x = EVAL(car(x));
   NeedVar(ex,x);
   if (isSym(x))
      Fetch(ex,x);
   return val(x);
}

// (set 'var 'any ..) -> any
any doSet(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   do {
      Push(c1, EVAL(car(x))),  x = cdr(x);
      NeedVar(ex,data(c1));
      CheckVar(ex,data(c1));
      Push(c2, EVAL(car(x))),  x = cdr(x);
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      val(data(c1)) = data(c2);
      drop(c1);
   } while (isCell(x));
   return val(data(c1));
}

// (setq var 'any ..) -> any
any doSetq(any ex) {
   any x, y;

   x = cdr(ex);
   do {
      y = car(x),  x = cdr(x);
      NeedVar(ex,y);
      CheckVar(ex,y);
      val(y) = EVAL(car(x));
   } while (isCell(x = cdr(x)));
   return val(y);
}

// (xchg 'var 'var ..) -> any
any doXchg(any ex) {
   any x, y;
   cell c1, c2;

   x = cdr(ex);
   do {
      Push(c1, EVAL(car(x))),  x = cdr(x);
      NeedVar(ex,data(c1));
      CheckVar(ex,data(c1));
      Push(c2, EVAL(car(x))),  x = cdr(x);
      NeedVar(ex,data(c2));
      CheckVar(ex,data(c2));
      if (isSym(data(c1)))
         Touch(ex,data(c1));
      if (isSym(data(c2)))
         Touch(ex,data(c2));
      y = val(data(c1)),  val(data(c1)) = val(data(c2)),  val(data(c2)) = y;
      drop(c1);
   } while (isCell(x));
   return y;
}

// (on sym ..) -> T
any doOn(any ex) {
   any x = cdr(ex);
   do {
      NeedSym(ex,car(x));
      val(car(x)) = T;
   } while (isCell(x = cdr(x)));
   return T;
}

// (off sym ..) -> NIL
any doOff(any ex) {
   any x = cdr(ex);
   do {
      NeedSym(ex,car(x));
      val(car(x)) = Nil;
   } while (isCell(x = cdr(x)));
   return Nil;
}

// (onOff sym ..) -> flg
any doOnOff(any ex) {
   any x = cdr(ex);
   any y;

   do {
      NeedSym(ex,car(x));
      y = val(car(x)) = isNil(val(car(x)))? T : Nil;
   } while (isCell(x = cdr(x)));
   return y;
}

// (zero sym ..) -> 0
any doZero(any ex) {
   any x = cdr(ex);
   do {
      NeedSym(ex,car(x));
      val(car(x)) = Zero;
   } while (isCell(x = cdr(x)));
   return Zero;
}

// (one sym ..) -> 1
any doOne(any ex) {
   any x = cdr(ex);
   do {
      NeedSym(ex,car(x));
      val(car(x)) = One;
   } while (isCell(x = cdr(x)));
   return One;
}

// (default sym 'any ..) -> any
any doDefault(any ex) {
   any x, y;

   x = cdr(ex);
   do {
      y = car(x),  x = cdr(x);
      NeedSym(ex,y);
      if (isNil(val(y)))
         val(y) = EVAL(car(x));
   } while (isCell(x = cdr(x)));
   return val(y);
}

// (push 'var 'any ..) -> any
any doPush(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   NeedVar(ex,data(c1));
   CheckVar(ex,data(c1));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   if (isSym(data(c1)))
      Touch(ex,data(c1));
   val(data(c1)) = cons(data(c2), val(data(c1)));