flow.c

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

   Save(c1);
   if (isNum(data(c1))) {
      if (isNeg(data(c1))) {
         drop(c1);
         return Nil;
      }
      data(c1) = bigCopy(data(c1));
   }
   x = cdr(x),  z = Nil;
   for (;;) {
      if (isNum(data(c1))) {
         if (IsZero(data(c1))) {
            drop(c1);
            return z;
         }
         digSub1(data(c1));
      }
      y = x;
      do {
         if (!isNum(z = car(y))) {
            if (isSym(z))
               z = val(z);
            else if (isNil(car(z))) {
               z = cdr(z);
               if (isNil(a = EVAL(car(z)))) {
                  drop(c1);
                  return prog(cdr(z));
               }
               val(At) = a;
               z = Nil;
            }
            else if (car(z) == T) {
               z = cdr(z);
               if (!isNil(a = EVAL(car(z)))) {
                  val(At) = a;
                  drop(c1);
                  return prog(cdr(z));
               }
               z = Nil;
            }
            else
               z = evList(z);
         }
      } while (isCell(y = cdr(y)));
   }
}

// (at '(cnt1 . cnt2) . prg) -> any
any doAt(any ex) {
   any x;

   x = cdr(ex),  x = EVAL(car(x));
   NeedCell(ex,x);
   NeedCnt(ex,car(x));
   NeedCnt(ex,cdr(x));
   if (num(setDig(car(x), unDig(car(x))+2)) < unDig(cdr(x)))
      return Nil;
   setDig(car(x), 0);
   return prog(cddr(ex));
}

// (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doFor(any ex) {
   any x, y, body, cond, a;
   cell c1;
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[2];
   } f;

   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = 0;
   if (!isCell(y = car(x = cdr(ex))) || !isCell(cdr(y))) {
      if (!isCell(y)) {
         f.cnt = 1;
         f.bnd[0].sym = y;
         f.bnd[0].val = val(y);
      }
      else {
         f.cnt = 2;
         f.bnd[0].sym = cdr(y);
         f.bnd[0].val = val(cdr(y));
         f.bnd[1].sym = car(y);
         f.bnd[1].val = val(car(y));
         val(f.bnd[1].sym) = Zero;
      }
      y = Nil;
      x = cdr(x),  Push(c1, EVAL(car(x)));
      body = x = cdr(x);
      while (isCell(data(c1))) {
         val(f.bnd[0].sym) = car(data(c1)),  data(c1) = cdr(data(c1));
         if (f.cnt == 2) {
            val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
            digAdd(val(f.bnd[1].sym), 2);
         }
         do {
            if (!isNum(y = car(x))) {
               if (isSym(y))
                  y = val(y);
               else if (isNil(car(y))) {
                  y = cdr(y);
                  if (isNil(a = EVAL(car(y)))) {
                     y = prog(cdr(y));
                     goto for1;
                  }
                  val(At) = a;
                  y = Nil;
               }
               else if (car(y) == T) {
                  y = cdr(y);
                  if (!isNil(a = EVAL(car(y)))) {
                     val(At) = a;
                     y = prog(cdr(y));
                     goto for1;
                  }
                  y = Nil;
               }
               else
                  y = evList(y);
            }
         } while (isCell(x = cdr(x)));
         x = body;
      }
   for1:
      drop(c1);
      if (f.cnt == 2)
         val(f.bnd[1].sym) = f.bnd[1].val;
      val(f.bnd[0].sym) = f.bnd[0].val;
      Env.bind = f.link;
      return y;
   }
   if (!isCell(car(y))) {
      f.cnt = 1;
      f.bnd[0].sym = car(y);
      f.bnd[0].val = val(car(y));
   }
   else {
      f.cnt = 2;
      f.bnd[0].sym = cdar(y);
      f.bnd[0].val = val(cdar(y));
      f.bnd[1].sym = caar(y);
      f.bnd[1].val = val(caar(y));
      val(f.bnd[1].sym) = Zero;
   }
   y = cdr(y);
   val(f.bnd[0].sym) = EVAL(car(y));
   y = cdr(y),  cond = car(y),  y = cdr(y);
   Push(c1,Nil);
   body = x = cdr(x);
   while (!isNil(a = EVAL(cond))) {
      val(At) = a;
      if (f.cnt == 2) {
         val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
         digAdd(val(f.bnd[1].sym), 2);
      }
      do {
         if (!isNum(data(c1) = car(x))) {
            if (isSym(data(c1)))
               data(c1) = val(data(c1));
            else if (isNil(car(data(c1)))) {
               data(c1) = cdr(data(c1));
               if (isNil(a = EVAL(car(data(c1))))) {
                  data(c1) = prog(cdr(data(c1)));
                  goto for2;
               }
               val(At) = a;
               data(c1) = Nil;
            }
            else if (car(data(c1)) == T) {
               data(c1) = cdr(data(c1));
               if (!isNil(a = EVAL(car(data(c1))))) {
                  val(At) = a;
                  data(c1) = prog(cdr(data(c1)));
                  goto for2;
               }
               data(c1) = Nil;
            }
            else
               data(c1) = evList(data(c1));
         }
      } while (isCell(x = cdr(x)));
      if (isCell(y))
         val(f.bnd[0].sym) = prog(y);
      x = body;
   }
for2:
   if (f.cnt == 2)
      val(f.bnd[1].sym) = f.bnd[1].val;
   val(f.bnd[0].sym) = f.bnd[0].val;
   Env.bind = f.link;
   return Pop(c1);
}

static any Thrown;

// (catch 'sym . prg) -> any
any doCatch(any ex) {
   any x, y;
   catchFrame f;

   x = cdr(ex),  f.tag = EVAL(car(x));
   NeedSym(ex,f.tag);
   f.link = CatchPtr,  CatchPtr = &f;
   f.env = Env;
   y = setjmp(f.rst)? Thrown : prog(cdr(x));
   CatchPtr = f.link;
   return y;
}

// (throw 'sym 'any)
any doThrow(any ex) {
   any x, tag;
   catchFrame *p;

   x = cdr(ex),  tag = EVAL(car(x));
   x = cdr(x),  Thrown = EVAL(car(x));
   for (p = CatchPtr;  p;  p = p->link)
      if (p->tag == T  ||  tag == p->tag) {
         unwind(p);
         longjmp(p->rst, 1);
      }
   err(ex, tag, "Tag not found");
}

// (finally exe . prg) -> any
any doFinally(any x) {
   catchFrame f;
   cell c1;

   x = cdr(x);
   f.tag = car(x);
   f.link = CatchPtr,  CatchPtr = &f;
   f.env = Env;
   Push(c1, prog(cdr(x)));
   EVAL(f.tag);
   CatchPtr = f.link;
   return Pop(c1);
}

static outFrame Out;
static struct {  // bindFrame
   struct bindFrame *link;
   int i, cnt;
   struct {any sym; any val;} bnd[3];  // for 'Up', 'Run' and 'At'
} Brk;

void brkLoad(any x) {
   if (!isNil(val(Dbg)) && !Env.brk) {
      if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO))
         err(x, NULL, "BREAK");
      Env.brk = YES;
      Brk.cnt = 3;
      Brk.bnd[0].sym = Up,  Brk.bnd[0].val = val(Up),  val(Up) = x;
      Brk.bnd[1].sym = Run,  Brk.bnd[1].val = val(Run),  val(Run) = Nil;
      Brk.bnd[2].sym = At,  Brk.bnd[2].val = val(At);
      Brk.link = Env.bind,  Env.bind = (bindFrame*)&Brk;
      Out.pid = -1,  Out.fd = 1,  pushOutFiles(&Out);
      print(x), crlf();
      load(NULL, '!', Nil);
      popOutFiles();
      val(At) = Brk.bnd[2].val;
      val(Run) = Brk.bnd[1].val;
      val(Up) = Brk.bnd[0].val;
      Env.bind = Brk.link;
      Env.brk = NO;
   }
}

// (! . prg) -> any
any doBreak(any ex) {
   brkLoad(cdr(ex));
   return EVAL(cdr(ex));
}

// (e . prg) -> any
any doE(any ex) {
   any x;
   cell c1, at, key;

   if (!Env.brk)
      err(ex, NULL, "No Break");
   Push(c1,val(Dbg)),  val(Dbg) = Nil;
   Push(at, val(At)),  val(At) = Brk.bnd[2].val;
   Push(key, val(Run)),  val(Run) = Brk.bnd[1].val;
   if (Env.inFiles) {
      Env.get = Env.inFiles->get;
      if (!Env.inFiles->link  || Env.inFiles->link->pid < 0)
         InFile = NULL,  Chr = Next0;
      else if (InFile = InFiles[Env.inFiles->link->fd])
         Chr = InFile->next;
      else
         Chr = Next0;
   }
   popOutFiles();
   x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up));
   pushOutFiles(&Out);
   if (InFile)
      InFile->next = Chr;
   else
      Next0 = Chr;
   InFile = NULL,  OutFile = NULL,  Chr = 0;
   val(Run) = data(key);
   val(At) = data(at);
   val(Dbg) = Pop(c1);
   return x;
}

static void traceIndent(int i, any x, char *s) {
   if (i > 64)
      i = 64;
   while (--i >= 0)
      Env.put(' ');
   if (isSym(x))
      print(x);
   else
      print(car(x)), space(), print(cdr(x)), space(), print(val(This));
   outString(s);
}

static void traceSym(any x) {
   if (x != At)
      space(), print(val(x));
   else {
      int i = Env.next;

      while (--i >= 0)
         space(), print(data(Env.arg[i]));
   }
}

// ($ sym|lst lst . prg) -> any
any doTrace(any x) {
   any foo, body;
   outFile *oSave = OutFile;
   FILE *stdSave = StdOut;
   void (*putSave)(int) = Env.put;
   cell c1;

   if (isNil(val(Dbg)))
      return prog(cdddr(x));
   OutFile = NULL,  StdOut = stderr,  Env.put = putStdout;
   x = cdr(x),  foo = car(x);
   x = cdr(x),  body = cdr(x);
   traceIndent(++Env.trace, foo, " :");
   for (x = car(x);  isCell(x);  x = cdr(x))
      traceSym(car(x));
   if (!isNil(x) && isSym(x))
      traceSym(x);
   crlf();
   Env.put = putSave,  OutFile = oSave,  StdOut = stdSave;
   Push(c1, prog(body));
   OutFile = NULL,  StdOut = stderr;
   Env.put = putStdout;
   traceIndent(Env.trace--, foo, " = "),  print(data(c1)),  crlf();
   Env.put = putSave,  OutFile = oSave,  StdOut = stdSave;
   return Pop(c1);
}

// (sys 'any ['any]) -> sym
any doSys(any x) {
   any y;

   y = evSym(x = cdr(x));
   {
      char nm[bufSize(y)];

      bufString(y,nm);
      if (!isCell(x = cdr(x)))
         return mkStr(getenv(nm));
      y = evSym(x);
      {
         char val[bufSize(y)];

         bufString(y,val);
         return setenv(nm,val,1)? Nil : y;
      }
   }
}

// (call 'any ..) -> flg
any doCall(any ex) {
   pid_t pid;
   any x, y;
   int res, i, ac = length(x = cdr(ex));
   char *av[ac+1];

   if (ac == 0)
      return Nil;
   i = 0;  do {
      y = evSym(x),  x = cdr(x);
      av[i] = alloc(NULL, bufSize(y)),  bufString(y, av[i]);
   } while (++i < ac);
   av[ac] = NULL;
   if ((pid = fork()) == 0) {
      setpgid(0,0);
      execvp(av[0], (char**)av);
      execError(av[0]);
   }
   i = 0;  do
      free(av[i]);
   while (++i < ac);
   if (pid < 0)
      err(ex, NULL, "fork");
   setpgid(pid,0);
   if (Termio)
      tcsetpgrp(0,pid);
   for (;;) {
      while (waitpid(pid, &res, WUNTRACED) < 0) {
         if (errno != EINTR)
            err(ex, NULL, "wait pid");
         if (Signal)
            sighandler(ex);
      }
      if (Termio)
         tcsetpgrp(0,getpgrp());
      if (!WIFSTOPPED(res))
         return res == 0? T : Nil;
      load(NULL, '+', Nil);
      if (Termio)
         tcsetpgrp(0,pid);
      kill(pid, SIGCONT);
   }
}

// (tick (cnt1 . cnt2) . prg) -> any
any doTick(any ex) {
   any x;
   clock_t n1, n2, save1, save2;
   struct tms tim;
   static clock_t ticks1, ticks2;

   save1 = ticks1,  save2 = ticks2;
   times(&tim),  n1 = tim.tms_utime,  n2 = tim.tms_stime;
   x = prog(cddr(ex));
   times(&tim);
   n1 = (tim.tms_utime - n1) - (ticks1 - save1);
   n2 = (tim.tms_stime - n2) - (ticks2 - save2);
   setDig(caadr(ex), unDig(caadr(ex)) + 2*n1);
   setDig(cdadr(ex), unDig(cdadr(ex)) + 2*n2);
   ticks1 += n1,  ticks2 += n2;
   return x;
}

// (ipid) -> pid | NIL
any doIpid(any ex __attribute__((unused))) {
   if (Env.inFiles  &&  Env.inFiles->pid > 0)
      return boxCnt((long)Env.inFiles->pid);
   return Nil;
}

// (opid) -> pid | NIL
any doOpid(any ex __attribute__((unused))) {
   if (Env.outFiles  &&  Env.outFiles->pid > 0)
      return boxCnt((long)Env.outFiles->pid);
   return Nil;
}

// (kill 'pid ['cnt]) -> flg
any doKill(any ex) {
   pid_t pid;

   pid = (pid_t)evCnt(ex,cdr(ex));
   return kill(pid, isCell(cddr(ex))? (int)evCnt(ex,cddr(ex)) : SIGTERM)? Nil : T;
}

static int allocChild(void) {
   int i;

   for (i = 0; i < Children; ++i)
      if (!Child[i].pid)
         return i;
   return i;
}

static void allocChildren(void) {
   int i;

   Child = alloc(Child, (Children + 8) * sizeof(child));
   for (i = 0; i < 8; ++i)
      Child[Children++].pid = 0;
}

pid_t forkLisp(any ex) {
   pid_t n;
   inFrame *in;
   outFrame *out;
   int i, hear[2], tell[2];
   static int mic[2];

   fflush(NULL);
   if (!Spkr) {
      if (pipe(mic) < 0)
         pipeError(ex, "open");
      Spkr = mic[0];
   }
   if (pipe(hear) < 0  ||  pipe(tell) < 0)
      pipeError(ex, "open");
   i = allocChild();
   if ((n = fork()) < 0)
      err(ex, NULL, "fork");
   if (n == 0) {
      /* Child Process */
      for (in = Env.inFiles; in; in = in->link)
         if (in->pid > 0)
            in->pid = 0;
      for (out = Env.outFiles; out; out = out->link)
         if (out->pid > 0)
            out->pid = 0;
      free(Termio),  Termio = NULL;
      if (close(hear[1]) < 0  ||  close(tell[0]) < 0  ||  close(mic[0]) < 0)
         pipeError(ex, "close");
      Slot = i;
      Spkr = 0;
      Mic = mic[1];
      for (i = 0; i < Children; ++i)
         if (Child[i].pid)
            close(Child[i].hear), close(Child[i].tell),  free(Child[i].buf);
      Children = 0,  free(Child),  Child = NULL;
      if (Hear)
         close(Hear),  closeInFile(Hear);
      initInFile(Hear = hear[0], NULL);
      if (Tell)
         close(Tell);
      Tell = tell[1];
      val(PPid) = val(Pid);
      val(Pid) = boxCnt(getpid());
      run(val(Fork));
      return 0;
   }
   if (i == Children)
      allocChildren();
   if (close(hear[0]) < 0  ||  close(tell[1]) < 0)
      pipeError(ex, "close");
   Child[i].pid = n;
   Child[i].hear = tell[0];
   blocking(NO, ex, Child[i].tell = hear[1]);
   Child[i].ofs = Child[i].cnt = 0;
   Child[i].buf = NULL;
   return n;
}

// (fork) -> pid | NIL
any doFork(any ex) {
   int n;

   return (n = forkLisp(ex))? boxCnt(n) : Nil;
}

// (bye 'cnt|NIL)
any doBye(any ex) {
   any x = EVAL(cadr(ex));

   bye(isNil(x)? 0 : xCnt(ex,x));
}