sym.c

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

            else
               caar(y) = val;
            return val;
         }
      }
      else if (key == car(y)) {
         if (isNil(val))
            Tail(x, cdr(y));
         else if (val != T)
            car(y) = cons(val,key);
         return val;
      }
      while (isCell(z = cdr(y))) {
         if (isCell(car(z))) {
            if (key == cdar(z)) {
               if (isNil(val))
                  cdr(y) = cdr(z);
               else {
                  if (val == T)
                     car(z) = key;
                  else
                     caar(z) = val;
                  cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
               }
               return val;
            }
         }
         else if (key == car(z)) {
            if (isNil(val))
               cdr(y) = cdr(z);
            else {
               if (val != T)
                  car(z) = cons(val,key);
               cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
            }
            return val;
         }
         y = z;
      }
   }
   if (!isNil(val))
      Tail(x, cons(val==T? key : cons(val,key), tail1(x)));
   return val;
}

any get(any x, any key) {
   any y, z;

   if (!isCell(y = tail1(x)))
      return Nil;
   if (!isCell(car(y))) {
      if (key == car(y))
         return T;
   }
   else if (key == cdar(y))
      return caar(y);
   while (isCell(z = cdr(y))) {
      if (!isCell(car(z))) {
         if (key == car(z)) {
            cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
            return T;
         }
      }
      else if (key == cdar(z)) {
         cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
         return caar(z);
      }
      y = z;
   }
   return Nil;
}

any prop(any x, any key) {
   any y, z;

   if (!isCell(y = tail1(x)))
      return Nil;
   if (!isCell(car(y))) {
      if (key == car(y))
         return key;
   }
   else if (key == cdar(y))
      return car(y);
   while (isCell(z = cdr(y))) {
      if (!isCell(car(z))) {
         if (key == car(z)) {
            cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
            return key;
         }
      }
      else if (key == cdar(z)) {
         cdr(y) = cdr(z),  cdr(z) = tail1(x),  Tail(x, z);
         return car(z);
      }
      y = z;
   }
   return Nil;
}

// (put 'sym1|lst ['sym2|cnt ..] 'sym 'any) -> any
any doPut(any ex) {
   any x;
   cell c1, c2, c3;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   while (isCell(cdr(x = cdr(x)))) {
      if (isCell(data(c1)))
         data(c1) = getn(data(c2), data(c1));
      else {
         NeedSym(ex,data(c1));
         Fetch(ex,data(c1));
         data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2));
      }
      data(c2) = EVAL(car(x));
   }
   NeedSym(ex,data(c1));
   CheckNil(ex,data(c1));
   Push(c3, EVAL(car(x)));
   Touch(ex,data(c1));
   x = put(data(c1), data(c2), data(c3));
   drop(c1);
   return x;
}

// (get 'sym1|lst ['sym2|cnt ..]) -> any
any doGet(any ex) {
   any x, y;
   cell c1;

   x = cdr(ex),  data(c1) = EVAL(car(x));
   if (!isCell(x = cdr(x)))
      return data(c1);
   Save(c1);
   do {
      y = EVAL(car(x));
      if (isCell(data(c1)))
         data(c1) = getn(y, data(c1));
      else {
         NeedSym(ex,data(c1));
         Fetch(ex,data(c1));
         data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y);
      }
   } while (isCell(x = cdr(x)));
   return Pop(c1);
}

// (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym
any doProp(any ex) {
   any x, y;
   cell c1;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   x = cdr(x),  y = EVAL(car(x));
   while (isCell(x = cdr(x))) {
      if (isCell(data(c1)))
         data(c1) = getn(y, data(c1));
      else {
         NeedSym(ex,data(c1));
         Fetch(ex,data(c1));
         data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y);
      }
      y = EVAL(car(x));
   }
   NeedSym(ex,data(c1));
   Fetch(ex,data(c1));
   return prop(Pop(c1), y);
}

// (=: sym|0 [sym1|cnt .. sym2] 'any) -> any
any doSetCol(any ex) {
   any x, y, z;
   cell c1;

   x = cdr(ex),  y = val(This);
   Fetch(ex,y);
   if (z = car(x),  isCell(cdr(x = cdr(x)))) {
      y = isNum(z) && !unDig(z)? val(y) : get(y,z);
      while (z = car(x),  isCell(cdr(x = cdr(x)))) {
         if (isCell(y))
            y = getn(z,y);
         else {
            NeedSym(ex,y);
            Fetch(ex,y);
            y = isNum(z) && !unDig(z)? val(y) : get(y,z);
         }
      }
   }
   NeedSym(ex,y);
   CheckNil(ex,y);
   Push(c1, EVAL(car(x)));
   Touch(ex,y);
   x = put(y, z, data(c1));
   drop(c1);
   return x;
}

// (: sym|0 [sym1|cnt ..]) -> any
any doCol(any ex) {
   any x, y;

   x = cdr(ex),  y = val(This);
   Fetch(ex,y);
   y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x));
   while (isCell(x = cdr(x))) {
      if (isCell(y))
         y = getn(car(x), y);
      else {
         NeedSym(ex,y);
         Fetch(ex,y);
         y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x));
      }
   }
   return y;
}

// (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym
any doPropCol(any ex) {
   any x, y;

   x = cdr(ex),  y = val(This);
   Fetch(ex,y);
   if (!isCell(cdr(x)))
      return prop(y, car(x));
   y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x));
   while (isCell(cdr(x = cdr(x)))) {
      if (isCell(y))
         y = getn(car(x), y);
      else {
         NeedSym(ex,y);
         Fetch(ex,y);
         y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x));
      }
   }
   return prop(y,car(x));
}

// (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst
any doPutl(any ex) {
   any x;
   cell c1, c2, c3;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      if (isCell(data(c1)))
         data(c1) = getn(data(c2), data(c1));
      else {
         NeedSym(ex,data(c1));
         Fetch(ex,data(c1));
         data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2));
      }
      data(c2) = EVAL(car(x));
   }
   NeedSym(ex,data(c1));
   NeedLst(ex,data(c2));
   CheckNil(ex,data(c1));
   Touch(ex,data(c1));
   while (isCell(tail(data(c1))))
      Tail(data(c1), cdr(tail1(data(c1))));
   if (isCell(data(c2))) {
      Push(c3, x = cons(car(data(c2)), cdr(data(c2))));
      while (isCell(cdr(x)))
         cdr(x) = cons(cadr(x), cddr(x)),  x = cdr(x);
      cdr(x) = tail1(data(c1));
      Tail(data(c1), data(c3));
   }
   drop(c1);
   return data(c2);
}

// (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst
any doGetl(any ex) {
   any x, y;
   cell c1, c2;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   while (isCell(x = cdr(x))) {
      y = EVAL(car(x));
      if (isCell(data(c1)))
         data(c1) = getn(y, data(c1));
      else {
         NeedSym(ex,data(c1));
         Fetch(ex,data(c1));
         data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y);
      }
   }
   NeedSym(ex,data(c1));
   Fetch(ex,data(c1));
   if (!isCell(x = tail1(data(c1))))
      data(c2) = Nil;
   else {
      Push(c2, y = cons(car(x),Nil));
      while (isCell(x = cdr(x)))
         y = cdr(y) = cons(car(x),Nil);
   }
   drop(c1);
   return data(c2);
}

static void wipe(any x) {
   any y, z;

   for (y = tail1(x); isCell(y); y = cdr(y));
   if (!isNum(y)) {
      val(x) = Nil;
      Tail(x, y);
   }
   else {
      z = numCell(y);
      while (isNum(cdr(z)))
         z = numCell(cdr(z));
      if (isNil(cdr(z)) || cdr(z) == At) {
         val(x) = Nil;
         Tail(x, y);
         cdr(z) = Nil;
      }
   }
}

// (wipe 'sym|lst) -> sym
any doWipe(any ex) {
   any x, y;

   x = cdr(ex);
   if (!isNil(x = EVAL(car(x))))
      if (isSym(x))
         wipe(x);
      else if (isCell(x)) {