flow.c

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

/* 22dec07abu
 * (c) Software Lab. Alexander Burger
 */

#include "pico.h"

static void redefMsg(any x, any y) {
   outFile *oSave = OutFile;
   FILE *stdSave = StdOut;

   OutFile = NULL,  StdOut = stderr;
   outString("# ");
   print(x);
   if (y)
      space(), print(y);
   outString(" redefined\n");
   OutFile = oSave,  StdOut = stdSave;
}

static void putSrc(any s, any k) {
   if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) {
      any x, y;
      cell c1;

      Push(c1, boxCnt(InFile->src));
      data(c1) = cons(data(c1), mkStr(InFile->name));
      if (!k) {
         if (isNil(x = get(s, Dbg)))
            put(s, Dbg, cons(data(c1), Nil));
         else
            car(x) = data(c1);
      }
      else if (isNil(x = get(s, Dbg)))
         put(s, Dbg, cons(Nil, cons(data(c1), Nil)));
      else {
         for (y = cdr(x); isCell(y); y = cdr(y))
            if (caar(y) == k) {
               cdar(y) = data(c1);
               drop(c1);
               return;
            }
         cdr(x) = cons(cons(k, data(c1)), cdr(x));
      }
      drop(c1);
   }
}

static void redefine(any ex, any s, any x) {
   NeedSym(ex,s);
   CheckVar(ex,s);
   if (!isNil(val(s))  &&  s != val(s)  &&  !equal(x,val(s)))
      redefMsg(s, NULL);
   val(s) = x;
   putSrc(s, NULL);
}

// (quote . any) -> any
any doQuote(any x) {return cdr(x);}

// (as 'any1 . any2) -> any2 | NIL
any doAs(any x) {
   x = cdr(x);
   if (isNil(EVAL(car(x))))
      return Nil;
   return cdr(x);
}

// (pid 'pid|lst . exe) -> any
any doPid(any x) {
   any y;

   x = cdr(x);
   if (!isCell(y = EVAL(car(x))))
      return equal(y, val(Pid))? EVAL(cdr(x)) : Nil;
   do
      if (equal(car(y), val(Pid)))
         return EVAL(cdr(x));
   while (isCell(y = cdr(y)));
   return Nil;
}

// (lit 'any) -> any
any doLit(any x) {
   x = cadr(x);
   if (isNum(x = EVAL(x)) || isSym(x) && x==val(x) || isCell(x) && isNum(car(x)))
      return x;
   return cons(Quote, x);
}

// (eval 'any ['cnt]) -> any
any doEval(any x) {
   cell c1;
   bindFrame *p;

   x = cdr(x),  Push(c1, EVAL(car(x))),  x = cdr(x);
   if (!isNum(x = EVAL(car(x))) || !(p = Env.bind))
      data(c1) = EVAL(data(c1));
   else {
      int cnt, n, i;
      bindFrame *q;

      for (cnt = (int)unBox(x), n = 0;;) {
         ++n;
         if (p->i <= 0) {
            if (p->i-- == 0) {
               for (i = 0;  i < p->cnt;  ++i) {
                  x = val(p->bnd[i].sym);
                  val(p->bnd[i].sym) = p->bnd[i].val;
                  p->bnd[i].val = x;
               }
               if (p->cnt  &&  p->bnd[0].sym == At  &&  !--cnt)
                  break;
            }
         }
         if (!(q = Env.bind->link))
            break;
         Env.bind->link = q->link,  q->link = p,  p = q;
      }
      Env.bind = p;
      data(c1) = EVAL(data(c1));
      for (;;) {
         if (p->i < 0) {
            if (++p->i == 0)
               for (i = p->cnt;  --i >= 0;) {
                  x = val(p->bnd[i].sym);
                  val(p->bnd[i].sym) = p->bnd[i].val;
                  p->bnd[i].val = x;
               }
         }
         if (!--n)
            break;
         q = Env.bind->link, Env.bind->link = q->link,  q->link = p,  p = q;
      }
      Env.bind = p;
   }
   return Pop(c1);
}

// (run 'any ['cnt]) -> any
any doRun(any x) {
   cell c1;
   bindFrame *p;

   x = cdr(x),  data(c1) = EVAL(car(x)),  x = cdr(x);
   if (!isNum(data(c1))) {
      Save(c1);
      if (!isNum(x = EVAL(car(x))) || !(p = Env.bind))
         data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1));
      else {
         int cnt, n, i;
         bindFrame *q;

         for (cnt = (int)unBox(x), n = 0;;) {
            ++n;
            if (p->i <= 0) {
               if (p->i-- == 0) {
                  for (i = 0;  i < p->cnt;  ++i) {
                     x = val(p->bnd[i].sym);
                     val(p->bnd[i].sym) = p->bnd[i].val;
                     p->bnd[i].val = x;
                  }
                  if (p->cnt  &&  p->bnd[0].sym==At  &&  !--cnt)
                     break;
               }
            }
            if (!(q = Env.bind->link))
               break;
            Env.bind->link = q->link,  q->link = p,  p = q;
         }
         Env.bind = p;
         data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1));
         for (;;) {
            if (p->i < 0) {
               if (++p->i == 0)
                  for (i = p->cnt;  --i >= 0;) {
                     x = val(p->bnd[i].sym);
                     val(p->bnd[i].sym) = p->bnd[i].val;
                     p->bnd[i].val = x;
                  }
            }
            if (!--n)
               break;
            q = Env.bind->link, Env.bind->link = q->link,  q->link = p,  p = q;
         }
         Env.bind = p;
      }
      drop(c1);
   }
   return data(c1);
}

// (def 'sym 'any) -> sym
// (def 'sym 'sym 'any) -> sym
any doDef(any ex) {
   any x, y;
   cell c1, c2, c3;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   NeedSym(ex,data(c1));
   CheckVar(ex,data(c1));
   x = cdr(x),  Push(c2, EVAL(car(x)));
   if (!isCell(cdr(x))) {
      if (!equal(data(c2), y = val(data(c1)))) {
         if (!isNil(y)  &&  data(c1) != y)
            redefMsg(data(c1), NULL);
         Touch(ex,data(c1));
         val(data(c1)) = data(c2);
      }
      putSrc(data(c1), NULL);
   }
   else {
      x = cdr(x),  Push(c3, EVAL(car(x)));
      if (!equal(data(c3), y = get(data(c1), data(c2)))) {
         if (!isNil(y))
            redefMsg(data(c1), data(c2));
         Touch(ex,data(c1));
         put(data(c1), data(c2), data(c3));
      }
      putSrc(data(c1), data(c2));
   }
   return Pop(c1);
}

// (de sym . any) -> sym
any doDe(any ex) {
   redefine(ex, cadr(ex), cddr(ex));
   return cadr(ex);
}

// (dm sym . fun) -> sym
// (dm (sym . cls) . fun) -> sym
// (dm (sym sym [. cls]) . fun) -> sym
any doDm(any ex) {
   any x, y, msg, cls;

   x = cdr(ex);
   if (!isCell(car(x)))
      msg = car(x),  cls = val(Class);
   else {
      msg = caar(x);
      cls = !isCell(cdar(x))? cdar(x) :
         get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x));
   }
   if (msg != T)
      redefine(ex, msg, val(Meth));
   if (isSym(cdr(x))) {
      y = val(cdr(x));
      for (;;) {
         if (!isCell(y) || !isCell(car(y)))
            err(ex, msg, "Bad message");
         if (caar(y) == msg) {
            x = car(y);
            break;
         }
         y = cdr(y);
      }
   }
   for (y = val(cls);  isCell(y) && isCell(car(y));  y = cdr(y))
      if (caar(y) == msg) {
         if (!equal(cdr(x), cdar(y)))
            redefMsg(msg, cls);
         cdar(y) = cdr(x);
         putSrc(cls, msg);
         return msg;
      }
   if (!isCell(car(x)))
      val(cls) = cons(x, val(cls));
   else
      val(cls) = cons(cons(caar(x), cdr(x)), val(cls));
   putSrc(cls, msg);
   return msg;
}

/* Evaluate method invocation */
static any evMethod(any o, any expr, any x) {
   any y = car(expr);
   methFrame m;
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[length(y)+3];
   } f;

   m.link = Env.meth;
   m.key = TheKey;
   m.cls = TheCls;
   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2;
   f.cnt = 1,  f.bnd[0].sym = At,  f.bnd[0].val = val(At);
   while (isCell(y)) {
      f.bnd[f.cnt].sym = car(y);
      f.bnd[f.cnt].val = EVAL(car(x));
      ++f.cnt, x = cdr(x), y = cdr(y);
   }
   if (isNil(y)) {
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      f.bnd[f.cnt].sym = This;
      f.bnd[f.cnt++].val = val(This);
      val(This) = o;
      Env.meth = &m;
      x = prog(cdr(expr));
   }
   else if (y != At) {
      f.bnd[f.cnt].sym = y,  f.bnd[f.cnt++].val = val(y),  val(y) = x;
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      f.bnd[f.cnt].sym = This,  f.bnd[f.cnt++].val = val(This),  val(This) = o;
      Env.meth = &m;
      x = prog(cdr(expr));
   }
   else {
      int n, cnt;
      cell *arg;
      cell c[n = cnt = length(x)];

      while (--n >= 0)
         Push(c[n], EVAL(car(x))),  x = cdr(x);
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      n = Env.next,  Env.next = cnt;
      arg = Env.arg,  Env.arg = c;
      f.bnd[f.cnt].sym = This;
      f.bnd[f.cnt++].val = val(This);
      val(This) = o;
      Env.meth = &m;
      x = prog(cdr(expr));
      if (cnt)
         drop(c[cnt-1]);
      Env.arg = arg,  Env.next = n;
   }
   while (--f.cnt >= 0)
      val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
   Env.bind = f.link;
   Env.meth = Env.meth->link;
   return x;
}

any method(any x) {
   any y, z;

   if (isCell(y = val(x))) {
      if (isCell(car(y))) {
         if (caar(y) == TheKey)
            return cdar(y);
         for (;;) {
            z = y;
            if (!isCell(y = cdr(y)))
               return NULL;
            if (!isCell(car(y)))
               break;
            if (caar(y) == TheKey) {
               cdr(z) = cdr(y),  cdr(y) = val(x),  val(x) = y;
               return cdar(y);
            }
         }
      }
      do
         if (x = method(car(TheCls = y)))
            return x;
      while (isCell(y = cdr(y)));
   }
   return NULL;
}

// (box 'any) -> sym
any doBox(any x) {
   x = cdr(x);
   return consSym(EVAL(car(x)), Nil);
}

// (new ['flg|num] ['typ ['any ..]]) -> obj
any doNew(any ex) {
   any x, y, *p;
   cell c1, c2;

   x = cdr(ex);
   Push(c1, consSym(Nil,Nil));
   if (isCell(y = EVAL(car(x))))
      val(data(c1)) = y;
   else {
      if (!isNil(y)) {
         p = Extern + hash(tail(data(c1)) = newId(isNum(y)? (int)unDig(y)/2 : 1));
         mkExt(data(c1));
         *p = cons(data(c1),*p);
      }
      x = cdr(x),  y = EVAL(car(x));
      NeedLst(ex,y);
      val(data(c1)) = y;
   }
   TheKey = T,  TheCls = Nil;
   if (y = method(data(c1)))
      evMethod(data(c1), y, cdr(x));
   else {
      Push(c2, Nil);
      while (isCell(x = cdr(x))) {
         data(c2) = EVAL(car(x)),  x = cdr(x);
         put(data(c1), data(c2), EVAL(car(x)));
      }
   }
   return Pop(c1);
}

// (type 'any) -> lst
any doType(any ex) {
   any x, y, z;

   x = cdr(ex),  x = EVAL(car(x));
   if (isSym(x)) {
      Fetch(ex,x);
      z = x = val(x);
      while (isCell(x)) {
         if (!isCell(car(x))) {
            y = x;
            while (isSym(car(x))) {
               if (!isCell(x = cdr(x)))
                  return isNil(x)? y : Nil;
               if (z == x)
                  return Nil;
            }
            return Nil;
         }
         if (z == (x = cdr(x)))
            return Nil;
      }
   }
   return Nil;
}

static bool isa(any ex, any cls, any x) {
   any z;

   z = x = val(x);
   while (isCell(x)) {
      if (!isCell(car(x))) {
         while (isSym(car(x))) {
            if (isExt(car(x)))
               return NO;
            if (cls == car(x) || isa(ex, cls, car(x)))
               return YES;
            if (!isCell(x = cdr(x)) || z == x)
               return NO;
         }
         return NO;
      }
      if (z == (x = cdr(x)))
         return NO;
   }
   return NO;
}

// (isa 'cls|typ 'any) -> obj | NIL
any doIsa(any ex) {
   any x;
   cell c1;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   x = cdr(x),  x = EVAL(car(x));
   drop(c1);
   if (isSym(x)) {
      if (isSym(data(c1))) {
         Fetch(ex,x);
         return isa(ex, data(c1), x)? x : Nil;
      }
      while (isCell(data(c1))) {
         Fetch(ex,x);
         if (!isa(ex, car(data(c1)), x))
            return Nil;
         data(c1) = cdr(data(c1));
      }
      return x;
   }
   return Nil;
}

// (method 'msg 'obj) -> fun
any doMethod(any ex) {
   any x, y;

   x = cdr(ex),  y = EVAL(car(x));
   x = cdr(x),  x = EVAL(car(x));
   NeedSym(ex,x);
   Fetch(ex,x);
   TheKey = y;
   return method(x)? : Nil;
}

// (meth 'obj ..) -> any
any doMeth(any ex) {
   any x, y;
   cell c1;

   x = cdr(ex),  Push(c1, EVAL(car(x)));
   NeedSym(ex,data(c1));
   Fetch(ex,data(c1));
   for (TheKey = car(ex); ; TheKey = val(TheKey)) {
      if (!isSym(TheKey))
         err(ex, car(ex), "Bad message");
      if (isNum(val(TheKey))) {
         TheCls = Nil;
         if (y = method(data(c1))) {
            x = evMethod(data(c1), y, cdr(x));
            drop(c1);
            return x;
         }
         err(ex, TheKey, "Bad message");
      }
   }
}

// (send 'msg 'obj ['any ..]) -> any
any doSend(any ex) {
   any x, y;
   cell c1, c2;

   x = cdr(ex),  Push(c1,  EVAL(car(x)));
   NeedSym(ex,data(c1));
   x = cdr(x),  Push(c2,  EVAL(car(x)));
   NeedSym(ex,data(c2));
   Fetch(ex,data(c2));
   TheKey = data(c1),  TheCls = Nil;
   if (y = method(data(c2))) {
      x = evMethod(data(c2), y, cdr(x));
      drop(c1);
      return x;
   }
   err(ex, TheKey, "Bad message");
}

// (try 'msg 'obj ['any ..]) -> any
any doTry(any ex) {
   any x, y;
   cell c1, c2;

   x = cdr(ex),  Push(c1,  EVAL(car(x)));
   NeedSym(ex,data(c1));
   x = cdr(x),  Push(c2,  EVAL(car(x)));
   if (isSym(data(c2))) {
      if (isExt(data(c2))) {
         if (!isLife(data(c2)))
            return Nil;
         db(ex,data(c2),1);
      }
      TheKey = data(c1),  TheCls = Nil;
      if (y = method(data(c2))) {
         x = evMethod(data(c2), y, cdr(x));
         drop(c1);
         return x;
      }