flow.c

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

   }
   drop(c1);
   return Nil;
}

// (super ['any ..]) -> any
any doSuper(any ex) {
   any x, y;
   methFrame m;

   m.key = TheKey = Env.meth->key;
   x = val(isNil(Env.meth->cls)? val(This) : car(Env.meth->cls));
   while (isCell(car(x)))
      x = cdr(x);
   while (isCell(x)) {
      if (y = method(car(TheCls = x))) {
         m.cls = TheCls;
         m.link = Env.meth,  Env.meth = &m;
         x = evExpr(y, cdr(ex));
         Env.meth = Env.meth->link;
         return x;
      }
      x = cdr(x);
   }
   err(ex, TheKey, "Bad super");
}

static any extra(any x) {
   any y;

   for (x = val(x); isCell(car(x)); x = cdr(x));
   while (isCell(x)) {
      if (x == Env.meth->cls  ||  !(y = extra(car(x)))) {
         while (isCell(x = cdr(x)))
            if (y = method(car(TheCls = x)))
               return y;
         return NULL;
      }
      if (y  &&  num(y) != 1)
         return y;
      x = cdr(x);
   }
   return (any)1;
}

// (extra ['any ..]) -> any
any doExtra(any ex) {
   any x, y;
   methFrame m;

   m.key = TheKey = Env.meth->key;
   if ((y = extra(val(This)))  &&  num(y) != 1) {
      m.cls = TheCls;
      m.link = Env.meth,  Env.meth = &m;
      x = evExpr(y, cdr(ex));
      Env.meth = Env.meth->link;
      return x;
   }
   err(ex, TheKey, "Bad extra");
}

// (with 'sym . prg) -> any
any doWith(any ex) {
   any x;
   bindFrame f;

   x = cdr(ex);
   if (isNil(x = EVAL(car(x))))
      return Nil;
   NeedSym(ex,x);
   Bind(This,f),  val(This) = x;
   x = prog(cddr(ex));
   Unbind(f);
   return x;
}

// (bind 'sym|lst . prg) -> any
any doBind(any ex) {
   any x, y;

   x = cdr(ex);
   if (isNum(y = EVAL(car(x))))
      argError(ex, y);
   if (isNil(y))
      return prog(cdr(x));
   if (isSym(y)) {
      bindFrame f;

      Bind(y,f);
      x = prog(cdr(x));
      Unbind(f);
      return x;
   }
   {
      struct {  // bindFrame
         struct bindFrame *link;
         int i, cnt;
         struct {any sym; any val;} bnd[length(y)];
      } f;

      f.link = Env.bind,  Env.bind = (bindFrame*)&f;
      f.i = f.cnt = 0;
      while (isCell(y)) {
         if (isNum(car(y)))
            argError(ex, car(y));
         if (isSym(car(y))) {
            f.bnd[f.cnt].sym = car(y);
            f.bnd[f.cnt].val = val(car(y));
         }
         else {
            f.bnd[f.cnt].sym = caar(y);
            f.bnd[f.cnt].val = val(caar(y));
            val(caar(y)) = cdar(y);
         }
         ++f.cnt,  y = cdr(y);
      }
      x = prog(cdr(x));
      while (--f.cnt >= 0)
         val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
      Env.bind = f.link;
      return x;
   }
}

// (job 'lst . prg) -> any
any doJob(any ex) {
   any x = cdr(ex);
   any y = EVAL(car(x));
   any z;
   cell c1;
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[length(y)];
   } f;

   Push(c1,y);
   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = f.cnt = 0;
   while (isCell(y)) {
      f.bnd[f.cnt].sym = caar(y);
      f.bnd[f.cnt].val = val(caar(y));
      val(caar(y)) = cdar(y);
      ++f.cnt,  y = cdr(y);
   }
   z = prog(cdr(x));
   for (f.cnt = 0, y = Pop(c1);  isCell(y);  ++f.cnt, y = cdr(y)) {
      cdar(y) = val(caar(y));
      val(caar(y)) = f.bnd[f.cnt].val;
   }
   Env.bind = f.link;
   return z;
}

// (let sym 'any . prg) -> any
// (let (sym 'any ..) . prg) -> any
any doLet(any x) {
   any y;

   x = cdr(x);
   if (isSym(y = car(x))) {
      bindFrame f;

      x = cdr(x),  Bind(y,f),  val(y) = EVAL(car(x));
      x = prog(cdr(x));
      Unbind(f);
   }
   else {
      struct {  // bindFrame
         struct bindFrame *link;
         int i, cnt;
         struct {any sym; any val;} bnd[(length(y)+1)/2];
      } f;

      f.link = Env.bind,  Env.bind = (bindFrame*)&f;
      f.i = f.cnt = 0;
      do {
         f.bnd[f.cnt].sym = car(y);
         f.bnd[f.cnt].val = val(car(y));
         val(car(y)) = EVAL(cadr(y));
         ++f.cnt;
      } while (isCell(y = cddr(y)));
      x = prog(cdr(x));
      while (--f.cnt >= 0)
         val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
      Env.bind = f.link;
   }
   return x;
}

// (let? sym 'any . prg) -> any
any doLetQ(any ex) {
   any x, y, z;
   bindFrame f;

   x = cdr(ex),  y = car(x),  x = cdr(x);
   if (isNil(z = EVAL(car(x))))
      return Nil;
   Bind(y,f),  val(y) = z;
   x = prog(cdr(x));
   Unbind(f);
   return x;
}

// (use sym . prg) -> any
// (use (sym ..) . prg) -> any
any doUse(any x) {
   any y;

   x = cdr(x);
   if (isSym(y = car(x))) {
      bindFrame f;

      Bind(y,f);
      x = prog(cdr(x));
      Unbind(f);
   }
   else {
      struct {  // bindFrame
         struct bindFrame *link;
         int i, cnt;
         struct {any sym; any val;} bnd[length(y)];
      } f;

      f.link = Env.bind,  Env.bind = (bindFrame*)&f;
      f.i = f.cnt = 0;
      do {
         f.bnd[f.cnt].sym = car(y);
         f.bnd[f.cnt].val = val(car(y));
         ++f.cnt;
      } while (isCell(y = cdr(y)));
      x = prog(cdr(x));
      while (--f.cnt >= 0)
         val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
      Env.bind = f.link;
   }
   return x;
}

// (and 'any ..) -> any
any doAnd(any x) {
   any a;

   x = cdr(x);
   do {
      if (isNil(a = EVAL(car(x))))
         return Nil;
      val(At) = a;
   }
   while (isCell(x = cdr(x)));
   return a;
}

// (or 'any ..) -> any
any doOr(any x) {
   any a;

   x = cdr(x);
   do
      if (!isNil(a = EVAL(car(x))))
         return val(At) = a;
   while (isCell(x = cdr(x)));
   return Nil;
}

// (nand 'any ..) -> flg
any doNand(any x) {
   any a;

   x = cdr(x);
   do {
      if (isNil(a = EVAL(car(x))))
         return T;
      val(At) = a;
   }
   while (isCell(x = cdr(x)));
   return Nil;
}

// (nor 'any ..) -> flg
any doNor(any x) {
   any a;

   x = cdr(x);
   do {
      if (!isNil(a = EVAL(car(x)))) {
         val(At) = a;
         return Nil;
      }
   } while (isCell(x = cdr(x)));
   return T;
}

// (xor 'any 'any) -> flg
any doXor(any x) {
   bool f;

   x = cdr(x),  f = isNil(EVAL(car(x))),  x = cdr(x);
   return  f ^ isNil(EVAL(car(x)))?  T : Nil;
}

// (bool 'any) -> flg
any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;}

// (not 'any) -> flg
any doNot(any x) {return isNil(EVAL(cadr(x)))? T : Nil;}

// (nil . prg) -> NIL
any doNil(any x) {
   while (isCell(x = cdr(x)))
      if (isCell(car(x)))
         evList(car(x));
   return Nil;
}

// (t . prg) -> T
any doT(any x) {
   while (isCell(x = cdr(x)))
      if (isCell(car(x)))
         evList(car(x));
   return T;
}

// (prog . prg) -> any
any doProg(any x) {return prog(cdr(x));}

// (prog1 'any1 . prg) -> any1
any doProg1(any x) {
   cell c1;

   x = cdr(x),  Push(c1, val(At) = EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (isCell(car(x)))
         evList(car(x));
   return Pop(c1);
}

// (prog2 'any1 'any2 . prg) -> any2
any doProg2(any x) {
   cell c1;

   x = cdr(x),  EVAL(car(x));
   x = cdr(x),  Push(c1, val(At) = EVAL(car(x)));
   while (isCell(x = cdr(x)))
      if (isCell(car(x)))
         evList(car(x));
   return Pop(c1);
}

// (if 'any1 'any2 . prg) -> any
any doIf(any x) {
   any a;

   x = cdr(x);
   if (isNil(a = EVAL(car(x))))
      return prog(cddr(x));
   val(At) = a;
   x = cdr(x);
   return EVAL(car(x));
}

// (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any
any doIf2(any x) {
   any a;

   x = cdr(x);
   if (isNil(a = EVAL(car(x)))) {
      x = cdr(x);
      if (isNil(a = EVAL(car(x))))
         return prog(cddddr(x));
      val(At) = a;
      x = cdddr(x);
      return EVAL(car(x));
   }
   val(At) = a;
   x = cdr(x);
   if (isNil(a = EVAL(car(x)))) {
      x = cddr(x);
      return EVAL(car(x));
   }
   val(At) = a;
   x = cdr(x);
   return EVAL(car(x));
}

// (ifn 'any1 'any2 . prg) -> any
any doIfn(any x) {
   any a;

   x = cdr(x);
   if (!isNil(a = EVAL(car(x)))) {
      val(At) = a;
      return prog(cddr(x));
   }
   x = cdr(x);
   return EVAL(car(x));
}

// (when 'any . prg) -> any
any doWhen(any x) {
   any a;

   x = cdr(x);
   if (isNil(a = EVAL(car(x))))
      return Nil;
   val(At) = a;
   return prog(cdr(x));
}

// (unless 'any . prg) -> any
any doUnless(any x) {
   any a;

   x = cdr(x);
   if (!isNil(a = EVAL(car(x)))) {
      val(At) = a;
      return Nil;
   }
   return prog(cdr(x));
}

// (cond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doCond(any x) {
   any a;

   while (isCell(x = cdr(x))) {
      if (!isNil(a = EVAL(caar(x)))) {
         val(At) = a;
         return prog(cdar(x));
      }
   }
   return Nil;
}

// (nond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doNond(any x) {
   any a;

   while (isCell(x = cdr(x))) {
      if (isNil(a = EVAL(caar(x))))
         return prog(cdar(x));
      val(At) = a;
   }
   return Nil;
}

// (case 'any (any1 . prg1) (any2 . prg2) ..) -> any
any doCase(any x) {
   any y, z;

   x = cdr(x),  val(At) = EVAL(car(x));
   while (isCell(x = cdr(x))) {
      y = car(x),  z = car(y);
      if (z == T  ||  equal(val(At), z))
         return prog(cdr(y));
      if (isCell(z)) {
         do
            if (equal(val(At), car(z)))
               return prog(cdr(y));
         while (isCell(z = cdr(z)));
      }
   }
   return Nil;
}

// (state 'var ((sym|lst sym [. prg]) . prg) ..) -> any
any doState(any ex) {
   any x, y, z, a;
   cell c1;

   x = cdr(ex);
   Push(c1, EVAL(car(x)));
   NeedVar(ex,data(c1));
   CheckVar(ex,data(c1));
   while (isCell(x = cdr(x))) {
      y = caar(x),  z = car(y);
      if (z==T || z==val(data(c1)) || isCell(z) && memq(val(data(c1)),z)) {
         y = cdr(y);
         if (!isCell(cdr(y)))
            goto st1;
         if (!isNil(a = prog(cdr(y)))) {
            val(At) = a;
         st1:
            if (isSym(data(c1)))
               Touch(ex,data(c1));
            val(data(c1)) = car(y);
            drop(c1);
            return prog(cdar(x));
         }
      }
   }
   drop(c1);
   return Nil;
}

// (while 'any . prg) -> any
any doWhile(any x) {
   any cond, a;
   cell c1;

   cond = car(x = cdr(x)),  x = cdr(x);
   Push(c1, Nil);
   while (!isNil(a = EVAL(cond))) {
      val(At) = a;
      data(c1) = prog(x);
   }
   return Pop(c1);
}

// (until 'any . prg) -> any
any doUntil(any x) {
   any cond, a;
   cell c1;

   cond = car(x = cdr(x)),  x = cdr(x);
   Push(c1, Nil);
   while (isNil(a = EVAL(cond)))
      data(c1) = prog(x);
   val(At) = a;
   return Pop(c1);
}

// (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doLoop(any ex) {
   any x, y, a;

   for (;;) {
      x = cdr(ex);
      do {
         if (isCell(y = car(x))) {
            if (isNil(car(y))) {
               y = cdr(y);
               if (isNil(a = EVAL(car(y))))
                  return prog(cdr(y));
               val(At) = a;
            }
            else if (car(y) == T) {
               y = cdr(y);
               if (!isNil(a = EVAL(car(y)))) {
                  val(At) = a;
                  return prog(cdr(y));
               }
            }
            else
               evList(y);
         }
      } while (isCell(x = cdr(x)));
   }
}

// (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doDo(any x) {
   any y, z, a;
   cell c1;

   x = cdr(x);
   if (isNil(data(c1) = EVAL(car(x))))
      return Nil;