io.c

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

   return x;
}

/* Read one token */
any token(any x, int c) {
   int i;
   any y, *h;
   cell c1;

   if (!Chr)
      Env.get();
   if (skip(c) < 0)
      return NULL;
   if (Chr == '"') {
      Env.get();
      if (Chr == '"') {
         Env.get();
         return Nil;
      }
      testEsc();
      i = 0,  Push(c1, y = box(Chr));
      while (Env.get(), Chr != '"' && testEsc())
         byteSym(Chr, &i, &y);
      Env.get();
      return consStr(y = Pop(c1));
   }
   if (Chr >= '0' && Chr <= '9') {
      i = 0,  Push(c1, y = box(Chr));
      while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.')
         byteSym(Chr, &i, &y);
      return symToNum(Pop(c1), (int)unDig(val(Scl)) / 2, '.', 0);
   }
   {
      char nm[bufSize(x)];

      bufString(x, nm);
      if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) {
         if (Chr == '\\')
            Env.get();
         i = 0,  Push(c1, y = box(Chr));
         while (Env.get(),
               Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' ||
               Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) {
            if (Chr == '\\')
               Env.get();
            byteSym(Chr, &i, &y);
         }
         y = Pop(c1);
         if (x = findHash(y, h = Intern + hash(y)))
            return x;
         x = consSym(Nil,y);
         *h = cons(x,*h);
         return x;
      }
   }
   y = box(c = getChar());
   Env.get();
   if (x = findHash(y, Intern + hash(y)))
      return x;
   return mkChar(c);
}

// (read ['sym1 ['sym2]]) -> any
any doRead(any ex) {
   any x;

   if (!isCell(x = cdr(ex)))
      x = read1(0);
   else {
      cell c1;

      Push(c1, EVAL(car(x)));
      NeedSym(ex, data(c1));
      x = cdr(x),  x = EVAL(car(x));
      NeedSym(ex,x);
      x = token(data(c1), symChar(name(x))) ?: Nil;
      drop(c1);
   }
   if (!InFile  &&  Chr == '\n')
      Chr = 0;
   return x;
}

long waitFd(any ex, int fd, long ms) {
   any x;
   cell c1, c2;
   int i, j, m, n;
   long t;
   bool flg;
   fd_set rdSet, wrSet;
   struct timeval *tp, tv;
#ifndef __linux__
   struct timeval tt;
#endif

   Save(c1);
   do {
      if (ms >= 0)
         t = ms,  tp = &tv;
      else
         t = LONG_MAX,  tp = NULL;
      FD_ZERO(&rdSet);
      FD_ZERO(&wrSet);
      m = 0;
      if (fd >= 0) {
         if (inReady(fd))
            tp = &tv,  t = 0;
         else
            FD_SET(m = fd, &rdSet);
      }
      if (Hear) {
         if (inReady(Hear))
            tp = &tv,  t = 0;
         else {
            FD_SET(Hear, &rdSet);
            if (Hear > m)
               m = Hear;
         }
      }
      for (x = data(c1) = val(Run); isCell(x); x = cdr(x)) {
         if (isNeg(caar(x))) {
            if ((n = (int)unDig(cadar(x)) / 2) < t)
               tp = &tv,  t = n;
         }
         else if (inReady(n = (int)unDig(caar(x)) / 2))
            tp = &tv,  t = 0;
         else {
            FD_SET(n, &rdSet);
            if (n > m)
               m = n;
         }
      }
      if (Spkr) {
         FD_SET(Spkr, &rdSet);
         if (Spkr > m)
            m = Spkr;
      }
      for (i = 0; i < Children; ++i) {
         if (Child[i].pid) {
            FD_SET(Child[i].hear, &rdSet);
            if (Child[i].hear > m)
               m = Child[i].hear;
            if (Child[i].cnt) {
               FD_SET(Child[i].tell, &wrSet);
               if (Child[i].tell > m)
                  m = Child[i].tell;
            }
         }
      }
      if (tp) {
         tv.tv_sec = t / 1000;
         tv.tv_usec = t % 1000 * 1000;
#ifndef __linux__
         gettimeofday(&tt,NULL);
         t = tt.tv_sec*1000 + tt.tv_usec/1000;
#endif
      }
      while (select(m+1, &rdSet, &wrSet, NULL, tp) < 0) {
         if (errno != EINTR) {
            val(Run) = Nil;
            err(ex, NULL, "Select error: %s", strerror(errno));
         }
         if (Signal)
            sighandler(ex);
      }
      if (tp) {
#ifdef __linux__
         t -= tv.tv_sec*1000 + tv.tv_usec/1000;
#else
         gettimeofday(&tt,NULL);
         t = tt.tv_sec*1000 + tt.tv_usec/1000 - t;
#endif
         if (ms > 0  &&  (ms -= t) < 0)
            ms = 0;
      }
      for (flg = NO, i = 0; i < Children; ++i) {
         if (Child[i].pid) {
            if (FD_ISSET(Child[i].hear, &rdSet)) {
               static byte *buf;

               if (!buf)
                  buf = alloc(NULL, PIPE_BUF - sizeof(int));
               if (rdBytes(Child[i].hear, (byte*)&n, sizeof(int)) && rdBytes(Child[i].hear, buf, n)) {
                  flg = YES;
                  for (j = 0; j < Children; ++j)
                     if (j != i  &&  Child[j].pid)
                        wrChild(j, buf, n);
               }
               else {
                  Child[i].pid = 0;
                  close(Child[i].hear),  close(Child[i].tell);
                  free(Child[i].buf);
                  continue;
               }
            }
            if (FD_ISSET(Child[i].tell, &wrSet)) {
               n = *(int*)(Child[i].buf + Child[i].ofs);
               if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) {
                  Child[i].ofs += sizeof(int) + n;
                  if (2 * Child[i].ofs >= Child[i].cnt) {
                     if (Child[i].cnt -= Child[i].ofs) {
                        memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt);
                        Child[i].buf = alloc(Child[i].buf, Child[i].cnt);
                     }
                     Child[i].ofs = 0;
                  }
               }
               else {
                  Child[i].pid = 0;
                  close(Child[i].hear),  close(Child[i].tell);
                  free(Child[i].buf);
               }
            }
         }
      }
      if (!flg && Spkr && FD_ISSET(Spkr,&rdSet) && rdBytes(Spkr,(byte*)&m,sizeof(int)) && Child[m].pid)
         wrChild(m, TBuf, sizeof(TBuf));
      for (x = data(c1); isCell(x); x = cdr(x))
         if (isNeg(caar(x))) {
            if ((n = (int)(unDig(cadar(x)) / 2 - t)) > 0)
               setDig(cadar(x), (long)2*n);
            else {
               setDig(cadar(x), unDig(caar(x)));
               Push(c2,val(At)),  val(At) = caar(x);
               prog(cddar(x));
               val(At) = Pop(c2);
            }
         }
      if (Hear  &&  (inReady(Hear) || FD_ISSET(Hear, &rdSet))) {
         if ((data(c2) = rdHear()) == NULL)
            close(Hear),  closeInFile(Hear),  Hear = 0;
         else if (data(c2) == T)
            Sync = YES;
         else {
            Save(c2);
            evList(data(c2));
            drop(c2);
         }
         FD_SET(Hear, &rdSet);
      }
      for (x = data(c1); isCell(x); x = cdr(x))
         if (!isNeg(caar(x)) &&  (inReady(n = (int)unDig(caar(x))/2) || FD_ISSET(n, &rdSet))) {
            Push(c2,val(At)),  val(At) = caar(x);
            prog(cdar(x));
            val(At) = Pop(c2);
            FD_SET(n, &rdSet);
         }
      if (Signal)
         sighandler(ex);
   } while (ms  &&  fd >= 0 && !FD_ISSET(fd, &rdSet));
   drop(c1);
   return ms;
}

// (wait ['cnt] . prg) -> any
any doWait(any ex) {
   any x, y;
   long ms;

   x = cdr(ex);
   ms = isNil(y = EVAL(car(x)))? -1 : xCnt(ex,y);
   x = cdr(x);
   while (isNil(y = prog(x)))
      if (!(ms = waitFd(ex, -1, ms)))
         return prog(x);
   return y;
}

// (sync) -> flg
any doSync(any ex) {
   byte *p;
   int n, cnt;

   if (!Mic || !Hear)
      return Nil;
   p = (byte*)&Slot;
   cnt = sizeof(int);
   do {
      if ((n = write(Mic, p, cnt)) < 0) {
         if (errno != EINTR)
            writeErr("sync");
         if (Signal)
            sighandler(ex);
      }
      p += n;
   } while (cnt -= n);
   Sync = NO;
   do
      waitFd(ex, Hear, -1);
   while (!Sync);
   return T;
}

// (hear 'num|sym) -> any
any doHear(any ex) {
   any x;
   int fd;

   x = cdr(ex),  x = EVAL(car(x));
   NeedAtom(ex,x);
   if (Hear)
      close(Hear),  closeInFile(Hear);
   if (isNum(x)) {
      fd = (int)xCnt(ex,x);
      if (fd >= InFDs || !InFiles[fd])
         badFd(ex,x);
      Hear = fd;
   }
   else {
      char nm[pathSize(x)];

      pathString(x, nm);
      while ((fd = open(nm, O_RDONLY)) < 0) {
         if (errno != EINTR)
            openErr(ex, nm);
         if (Signal)
            sighandler(ex);
      }
      initInFile(Hear = fd, strdup(nm));
   }
   return x;
}

// (tell 'sym ['any ..]) -> any
any doTell(any x) {
   any y;
   ptr pbSave, ppSave;
   byte buf[PIPE_BUF];

   if (!Tell && !Children)
      return Nil;
   tellBeg(&pbSave, &ppSave, buf);
   do
      x = cdr(x),  prTell(y = EVAL(car(x)));
   while (isCell(cdr(x)));
   tellEnd(&pbSave, &ppSave);
   return y;
}

// (poll 'cnt) -> cnt | NIL
any doPoll(any ex) {
   any x;
   int fd;
   fd_set fdSet;
   struct timeval tv;

   x = cdr(ex),  x = EVAL(car(x));
   if (inReady(fd = (int)xCnt(ex,x)))
      return x;
   FD_ZERO(&fdSet);
   FD_SET(fd, &fdSet);
   tv.tv_sec = tv.tv_usec = 0;
   while (select(fd+1, &fdSet, NULL, NULL, &tv) < 0)
      if (errno != EINTR)
         err(ex, NULL, "Poll error: %s", strerror(errno));
   return FD_ISSET(fd, &fdSet)? x : Nil;
}

// (key ['cnt]) -> sym
any doKey(any ex) {
   any x;
   int c;
   byte buf[2];

   fflush(stdout);
   setRaw();
   x = cdr(ex);
   if (!waitFd(ex, STDIN_FILENO, isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x)))
      return Nil;
   if (!rdBytes(STDIN_FILENO, buf, 1))
      return Nil;
   if ((c = buf[0]) == 0xFF)
      c = TOP;
   else if (c & 0x80) {
      if ((c & 0x20) == 0) {
         if (!rdBytes(STDIN_FILENO, buf, 1))
            return Nil;
         c = (c & 0x1F) << 6 | buf[0] & 0x3F;
      }
      else {
         if (!rdBytes(STDIN_FILENO, buf, 2))
            return Nil;
         c = ((c & 0xF) << 6 | buf[0] & 0x3F) << 6 | buf[1] & 0x3F;
      }
   }
   return mkChar(c);
}

// (peek) -> sym
any doPeek(any ex __attribute__((unused))) {
   if (!Chr)
      Env.get();
   return Chr<0? Nil : mkChar(Chr);
}

// (char) -> sym
// (char 'cnt) -> sym
// (char T) -> sym
// (char 'sym) -> cnt
any doChar(any ex) {
   any x = cdr(ex);
   if (!isCell(x)) {
      if (!Chr)
         Env.get();
      x = Chr<0? Nil : mkChar(getChar());
      Env.get();
      return x;
   }
   if (isNum(x = EVAL(car(x))))
      return IsZero(x)? Nil : mkChar(unDig(x) / 2);
   if (isSym(x))
      return x == T? mkChar(TOP) : boxCnt(symChar(name(x)));
   atomError(ex,x);
}

// (skip ['sym]) -> sym
any doSkip(any ex) {
   any x;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   return skip(symChar(name(x)))<0? Nil : mkChar(Chr);
}

// (eol) -> flg
any doEol(any ex __attribute__((unused))) {
   return InFile && Chr=='\n' || Chr<=0? T : Nil;
}

// (eof ['flg]) -> flg
any doEof(any x) {
   x = cdr(x);
   if (!isNil(EVAL(car(x)))) {
      Chr = -1;
      return T;
   }
   if (!Chr)
      Env.get();
   return Chr < 0? T : Nil;
}

// (from 'any ..) -> sym
any doFrom(any ex) {
   any x;
   int res, i, j, ac = length(x = cdr(ex)), p[ac];
   cell c[ac];
   char *av[ac];

   if (ac == 0)
      return Nil;
   for (i = 0;;) {
      Push(c[i], evSym(x));
      av[i] = alloc(NULL, bufSize(data(c[i]))),  bufString(data(c[i]), av[i]);
      p[i] = 0;
      if (++i == ac)
         break;
      x = cdr(x);
   }
   res = -1;
   if (!Chr)
      Env.get();
   while (Chr >= 0) {
      for (i = 0; i < ac; ++i) {
         for (;;) {
            if (av[i][p[i]] == (byte)Chr) {
               if (av[i][++p[i]])
                  break;
               Env.get();
               res = i;
               goto done;
            }
            if (!p[i])
               break;
            for (j = 1; --p[i]; ++j)
               if (memcmp(av[i], av[i]+j, p[i]) == 0)
                  break;
         }
      }
      Env.get();
   }
done:
   i = 0;  do
      free(av[i]);
   while (++i < ac);
   drop(c[0]);
   return res < 0? Nil : data(c[res]);
}

// (till 'any ['flg]) -> lst|sym
any doTill(any ex) {
   any x;
   int i;
   cell c1;

   x = evSym(cdr(ex));
   {
      char buf[bufSize(x)];

      bufString(x, buf);
      if (!Chr)
         Env.get();
      if (Chr < 0 || strchr(buf,Chr))
         return Nil;
      x = cddr(ex);
      if (isNil(EVAL(car(x)))) {
         Push(c1, x = cons(mkChar(getChar()), Nil));
         while (Env.get(), Chr > 0 && !strchr(buf,Chr))
            x = cdr(x) = cons(mkChar(getChar()), Nil);
         return Pop(c1);
      }
      Push(c1, boxChar(getChar(), &i, &x));
      while (Env.get(), Chr > 0 && !strchr(buf,Chr))
         charSym(getChar(), &i, &x);
      return consStr(Pop(c1));
   }
}

static inline bool eol(void) {
   if (Chr < 0)
      return YES;
   if (Chr == '\n') {
      Chr = 0;
      return YES;
   }
   if (Chr == '\r') {
      Env.get();
      if (Chr == '\n')
         Chr = 0;
      return YES;
   }
   return NO;
}

// (line 'flg ['cnt ..]) -> lst|sym
any doLine(any ex) {
   any x, y, z;
   bool pack;
   int i, n;
   cell c1;

   if (!Chr)
      Env.get();
   if (eol())
      return Nil;
   x = cdr(ex);
   if (pack = !isNil(EVAL(car(x))))
      Push(c1, boxChar(getChar(), &i, &z));
   else
      Push(c1, cons(mkChar(getChar()), Nil));
   if (!isCell(x = cdr(x)))
      y = data(c1);
   else {
      if (!pack)
         z = data(c1);
      data(c1) = y = cons(data(c1), Nil);
      for (;;) {
         n = (int)evCnt(ex,x);
         while (--n) {
            if (Env.get(), eol()) {
               if (pack)
                  car(y) = consStr(car(y));
               return Pop(c1);
            }
            if (pack)
               charSym(getChar(), &i, &z);
            else
               z = cdr(z) = cons(mkChar(getChar()), Nil);
         }
         if (pack)
            car(y) = consStr(car(y));
         if (!isCell(x = cdr(x))) {
            pack = NO;
            break;