io.c

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

      f->pid = -1,  f->fd = 0;
   else if (isNum(x)) {
      int n = (int)unBox(x);

      if (n < 0) {
         inFrame *g = Env.inFiles;

         for (;;) {
            if (!(g = g->link))
               break;
            if (!++n) {
               n = g->fd;
               break;
            }
         }
      }
      if ((f->fd = n) <= 2)
         f->pid = -1;
      else {
         f->pid = 0;
         if (f->fd >= InFDs || !InFiles[f->fd])
            badFd(ex,x);
      }
   }
   else if (isSym(x)) {
      char nm[pathSize(x)];

      f->pid = 1;
      pathString(x,nm);
      if (nm[0] == '+') {
         while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_RDWR, 0666)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
         initInFile(f->fd, strdup(nm+1));
      }
      else {
         while ((f->fd = open(nm, O_RDONLY)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
         initInFile(f->fd, strdup(nm));
      }
   }
   else {
      any y;
      int i, pfd[2], ac = length(x);
      char *av[ac+1];

      if (pipe(pfd) < 0)
         pipeError(ex, "read open");
      av[0] = alloc(NULL, pathSize(y = xSym(car(x)))),  pathString(y, av[0]);
      for (i = 1; isCell(x = cdr(x)); ++i)
         av[i] = alloc(NULL, bufSize(y = xSym(car(x)))),  bufString(y, av[i]);
      av[ac] = NULL;
      if ((f->pid = fork()) == 0) {
         setpgid(0,0);
         close(pfd[0]);
         if (pfd[1] != STDOUT_FILENO)
            dup2(pfd[1], STDOUT_FILENO),  close(pfd[1]);
         execvp(av[0], (char**)av);
         execError(av[0]);
      }
      i = 0;  do
         free(av[i]);
      while (++i < ac);
      if (f->pid < 0)
         err(ex, NULL, "fork");
      setpgid(f->pid,0);
      close(pfd[1]);
      initInFile(f->fd = pfd[0], NULL);
   }
}

void wrOpen(any ex, any x, outFrame *f) {
   if (isNil(x))
      f->pid = -1,  f->fd = 1;
   else if (isNum(x)) {
      int n = (int)unBox(x);

      if (n < 0) {
         outFrame *g = Env.outFiles;

         for (;;) {
            if (!(g = g->link))
               break;
            if (!++n) {
               n = g->fd;
               break;
            }
         }
      }
      if ((f->fd = n) <= 2)
         f->pid = -1;
      else {
         f->pid = 0;
         if (f->fd >= OutFDs || !OutFiles[f->fd])
            badFd(ex,x);
      }
   }
   else if (isSym(x)) {
      char nm[pathSize(x)];

      f->pid = 1;
      pathString(x,nm);
      if (nm[0] == '+') {
         while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
      }
      else {
         while ((f->fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
      }
      initOutFile(f->fd);
   }
   else {
      any y;
      int i, pfd[2], ac = length(x);
      char *av[ac+1];

      if (pipe(pfd) < 0)
         pipeError(ex, "write open");
      av[0] = alloc(NULL, pathSize(y = xSym(car(x)))),  pathString(y, av[0]);
      for (i = 1; isCell(x = cdr(x)); ++i)
         av[i] = alloc(NULL, bufSize(y = xSym(car(x)))),  bufString(y, av[i]);
      av[ac] = NULL;
      if ((f->pid = fork()) == 0) {
         setpgid(0,0);
         close(pfd[1]);
         if (pfd[0] != STDIN_FILENO)
            dup2(pfd[0], STDIN_FILENO),  close(pfd[0]);
         execvp(av[0], (char**)av);
         execError(av[0]);
      }
      i = 0;  do
         free(av[i]);
      while (++i < ac);
      if (f->pid < 0)
         err(ex, NULL, "fork");
      setpgid(f->pid,0);
      close(pfd[0]);
      initOutFile(f->fd = pfd[1]);
   }
}

void ctOpen(any ex, any x, ctlFrame *f) {
   NeedSym(ex,x);
   if (isNil(x)) {
      f->fd = -1;
      lockFile(currFd(ex, (char*)f), F_SETLKW, F_RDLCK);
   }
   else if (x == T) {
      f->fd = -1;
      lockFile(currFd(ex, (char*)f), F_SETLKW, F_WRLCK);
   }
   else {
      char nm[pathSize(x)];

      pathString(x,nm);
      if (nm[0] == '+') {
         while ((f->fd = open(nm+1, O_CREAT|O_RDWR, 0666)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
         lockFile(f->fd, F_SETLKW, F_RDLCK);
      }
      else {
         while ((f->fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) {
            if (errno != EINTR)
               openErr(ex, nm);
            if (Signal)
               sighandler(ex);
         }
         lockFile(f->fd, F_SETLKW, F_WRLCK);
      }
   }
}

/*** Reading ***/
void getStdin(void) {
   if (InFile) {
      if (InFile->ix == InFile->cnt) {
         InFile->ix = InFile->cnt = 0;
         if (!(InFile->cnt = slow(InFile->fd, InFile->buf, BUFSIZ))) {
            Chr = -1;
            return;
         }
      }
      if ((Chr = InFile->buf[InFile->ix++]) == '\n')
         ++InFile->line;
   }
   else if (!isCell(val(Led))) {
      byte buf[1];

      waitFd(NULL, STDIN_FILENO, -1);
      Chr = rdBytes(STDIN_FILENO, buf, 1)? buf[0] : -1;
   }
   else {
      static word dig;

      if (!isNum(Line))
         dig = isNum(Line = name(run(val(Led))))? unDig(Line) : '\n';
      else if ((dig >>= 8) == 0)
         dig = isNum(Line = cdr(numCell(Line)))? unDig(Line) : '\n';
      Chr = dig & 0xFF;
   }
}

static void getParse(void) {
   if ((Chr = Env.parser->dig & 0xFF) == 0xFF)
      Chr = -1;
   else if ((Env.parser->dig >>= 8) == 0) {
      Env.parser->dig =
         isNum(Env.parser->name = cdr(numCell(Env.parser->name))) ?
            unDig(Env.parser->name) : Env.parser->eof;
   }
}

void pushInFiles(inFrame *f) {
   if (InFile)
      InFile->next = Chr;
   else
      Next0 = Chr;
   if (f->pid < 0)
      InFile = NULL,  Chr = Next0;
   else if (InFile = InFiles[f->fd])
      Chr = InFile->next;
   else
      Chr = Next0;
   f->get = Env.get,  Env.get = getStdin;
   f->link = Env.inFiles,  Env.inFiles = f;
}

void pushOutFiles(outFrame *f) {
   if (f->pid < 0)
      OutFile = NULL,  StdOut = f->fd == 2? stderr : stdout;
   else
      OutFile = OutFiles[f->fd];
   f->put = Env.put,  Env.put = putStdout;
   f->link = Env.outFiles,  Env.outFiles = f;
}

void pushCtlFiles(ctlFrame *f) {
   f->link = Env.ctlFiles,  Env.ctlFiles = f;
}

void popInFiles(void) {
   if (Env.inFiles->pid > 0) {
      close(Env.inFiles->fd),  closeInFile(Env.inFiles->fd);
      if (Env.inFiles->pid > 1)
         while (waitpid(Env.inFiles->pid, NULL, 0) < 0) {
            if (errno != EINTR)
               closeErr("Read pipe");
            if (Signal)
               sighandler(T);
         }
   }
   Env.get = Env.inFiles->get;
   if (!(Env.inFiles = Env.inFiles->link) || Env.inFiles->pid < 0)
      InFile = NULL,  Chr = Next0;
   else if (InFile = InFiles[Env.inFiles->fd])
      Chr = InFile->next;
   else
      Chr = Next0;
}

void popOutFiles(void) {
   flush(OutFile);
   if (Env.outFiles->pid > 0) {
      close(Env.outFiles->fd),  closeOutFile(Env.outFiles->fd);
      if (Env.outFiles->pid > 1)
         while (waitpid(Env.outFiles->pid, NULL, 0) < 0) {
            if (errno != EINTR)
               closeErr("Write pipe");
            if (Signal)
               sighandler(T);
         }
   }
   Env.put = Env.outFiles->put;
   if (!(Env.outFiles = Env.outFiles->link))
      OutFile = NULL,  StdOut = stdout;
   else if (Env.outFiles->pid >= 0)
      OutFile = OutFiles[Env.outFiles->fd];
   else
      OutFile = NULL,  StdOut = Env.outFiles->fd == 2? stderr : stdout;
}

void popCtlFiles(void) {
   if (Env.ctlFiles->fd >= 0)
      close(Env.ctlFiles->fd);
   else
      lockFile(currFd(NULL, (char*)Env.ctlFiles), F_SETLK, F_UNLCK);
   Env.ctlFiles = Env.ctlFiles->link;
}

/* Get full char from input channel */
int getChar(void) {
   int c;

   if ((c = Chr) == 0xFF)
      return TOP;
   if (c & 0x80) {
      Env.get();
      if ((c & 0x20) == 0)
         c &= 0x1F;
      else
         c = (c & 0xF) << 6 | Chr & 0x3F,  Env.get();
      if (Chr < 0)
         eofErr();
      c = c << 6 | Chr & 0x3F;
   }
   return c;
}

/* Skip White Space and Comments */
static int skip(int c) {
   for (;;) {
      if (Chr < 0)
         return Chr;
      while (Chr <= ' ') {
         Env.get();
         if (Chr < 0)
            return Chr;
      }
      if (Chr != c)
         return Chr;
      while (Env.get(), Chr != '\n')
         if (Chr < 0)
            return Chr;
      Env.get();
   }
}

/* Test for escaped characters */
static bool testEsc(void) {
   for (;;) {
      if (Chr < 0)
         return NO;
      if (Chr == '^') {
         Env.get();
         if (Chr == '?')
            Chr = 127;
         else
            Chr &= 0x1F;
         return YES;
      }
      if (Chr != '\\')
         return YES;
      if (Env.get(), Chr != '\n')
         return YES;
      do
         Env.get();
      while (Chr == ' '  ||  Chr == '\t');
   }
}

/* Read a list */
static any rdList(void) {
   any x;
   cell c1, c2;

   Env.get();
   if (skip('#') == ')') {
      Env.get();
      return Nil;
   }
   if (Chr == ']')
      return Nil;
   for (;;) {
      if (Chr != '~') {
         Push(c1, x = cons(read0(NO),Nil));
         break;
      }
      Env.get();
      Push(c1, read0(NO));
      if (isCell(x = data(c1) = EVAL(data(c1)))) {
         do
            x = cdr(x);
         while (isCell(cdr(x)));
         break;
      }
      drop(c1);
   }
   for (;;) {
      if (skip('#') == ')') {
         Env.get();
         break;
      }
      if (Chr == ']')
         break;
      if (Chr == '.') {
         Env.get();
         cdr(x) = skip('#')==')' || Chr==']'? data(c1) : read0(NO);
         if (skip('#') == ')')
            Env.get();
         else if (Chr != ']')
            err(NULL, x, "Bad dotted pair");
         break;
      }
      if (Chr != '~')
         x = cdr(x) = cons(read0(NO),Nil);
      else {
         Env.get();
         Push(c2, read0(NO));
         data(c2) = EVAL(data(c2));
         if (isCell(cdr(x) = Pop(c2)))
            do
               x = cdr(x);
            while (isCell(cdr(x)));
      }
   }
   return Pop(c1);
}

/* Try for anonymous symbol */
static any anonymous(any s) {
   unsigned c;
   unsigned long n;
   heap *h;

   if ((c = symByte(s)) != '$')
      return NULL;
   n = 0;
   while (c = symByte(NULL)) {
      if (c < '0' || c > '9')
         return NULL;
      n = n * 10 + c - '0';
   }
   n *= sizeof(cell);
   h = Heaps;
   do
      if ((any)n > h->cells  &&  (any)n < h->cells + CELLS)
         return symPtr((any)n);
   while (h = h->next);
   return NULL;
}

/* Read one expression */
static any read0(bool top) {
   int i;
   any x, y, *h;
   cell c1;

   if (skip('#') < 0) {
      if (top)
         return Nil;
      eofErr();
   }
   if (top && InFile)
      InFile->src = InFile->line;
   if (Chr == '(') {
      x = rdList();
      if (top  &&  Chr == ']')
         Env.get();
      return x;
   }
   if (Chr == '[') {
      x = rdList();
      if (Chr != ']')
         err(NULL, x, "Super parentheses mismatch");
      Env.get();
      return x;
   }
   if (Chr == '\'') {
      Env.get();
      return cons(Quote, read0(NO));
   }
   if (Chr == ',') {
      Env.get();
      if ((y = member(x = read0(NO), val(Uni))) && isCell(y))
         return car(y);
      val(Uni) = cons(x, val(Uni));
      return x;
   }
   if (Chr == '`') {
      Env.get();
      Push(c1, read0(NO));
      x = EVAL(data(c1));
      drop(c1);
      return x;
   }
   if (Chr == '"') {
      Env.get();
      if (Chr == '"') {
         Env.get();
         return Nil;
      }
      if (!testEsc())
         eofErr();
      i = 0,  Push(c1, y = box(Chr));
      while (Env.get(), Chr != '"') {
         if (!testEsc())
            eofErr();
         byteSym(Chr, &i, &y);
      }
      y = Pop(c1),  Env.get();
      if (x = findHash(y, h = Transient + hash(y)))
         return x;
      x = consStr(y);
      if (Env.get == getStdin)
         *h = cons(x,*h);
      return x;
   }
   if (Chr == '{') {
      Env.get();
      if (Chr == '}') {
         Env.get();
         return consSym(Nil,Nil);
      }
      i = 0,  Push(c1, y = box(Chr));
      while (Env.get(), Chr != '}') {
         if (Chr < 0)
            eofErr();
         byteSym(Chr, &i, &y);
      }
      y = Pop(c1),  Env.get();
      if (x = findHash(y, h = Extern + hash(y)))
         return x;
      mkExt(x = consSym(Nil,y));
      *h = cons(x,*h);
      return x;
   }
   if (strchr(Delim, Chr))
      err(NULL, NULL, "Bad input '%c' (%d)", isprint(Chr)? Chr:'?', Chr);
   if (Chr == '\\')
      Env.get();
   i = 0,  Push(c1, y = box(Chr));
   for (;;) {
      Env.get();
      if (strchr(Delim, Chr))
         break;
      if (Chr == '\\')
         Env.get();
      byteSym(Chr, &i, &y);
   }
   y = Pop(c1);
   if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N'))
      return Nil;
   if (x = symToNum(y, (int)unDig(val(Scl)) / 2, '.', 0))
      return x;
   if (x = findHash(y, h = Intern + hash(y)))
      return x;
   if (x = anonymous(y))
      return x;
   x = consSym(Nil,y);
   *h = cons(x,*h);
   return x;
}

any read1(int end) {
   any x;

   if (!Chr)
      Env.get();
   if (Chr == end)
      return Nil;
   x = read0(YES);
   while (Chr  &&  strchr(" \t)]", Chr))
      Env.get();