io.c

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

         }
         if (Env.get(), eol())
            return Pop(c1);
         y = cdr(y) = cons(
            pack? boxChar(getChar(), &i, &z) : (z = cons(mkChar(getChar()), Nil)),
            Nil );
      }
   }
   for (;;) {
      if (Env.get(), eol())
         return pack? consStr(Pop(c1)) : Pop(c1);
      if (pack)
         charSym(getChar(), &i, &z);
      else
         y = cdr(y) = cons(mkChar(getChar()), Nil);
   }
}

// (lines 'any ..) -> cnt
any doLines(any ex) {
   any x, y;
   int c, cnt = 0;
   FILE *fp;

   for (x = cdr(ex); isCell(x); x = cdr(x)) {
      y = evSym(x);
      {
         char nm[pathSize(y)];

         pathString(y, nm);
         if (!(fp = fopen(nm, "r")))
            openErr(ex, nm);
         while ((c = getc_unlocked(fp)) >= 0)
            if (c == '\n')
               ++cnt;
         fclose(fp);
      }
   }
   return boxCnt(cnt);
}

static any parse(any x, bool skp, any s) {
   int c;
   parseFrame *save, parser;
   void (*getSave)(void);
   cell c1;

   if (save = Env.parser)
      Push(c1, Env.parser->name);
   Env.parser = &parser;
   parser.dig = unDig(parser.name = name(x));
   parser.eof = s? 0xFF : 0xFF00 | ']';
   getSave = Env.get,  Env.get = getParse,  c = Chr,  Chr = 0;
   if (skp)
      getParse();
   if (!s)
      x = rdList();
   else {
      any y;
      cell c2;

      if (!(x = token(s,0)))
         return Nil;
      Push(c2, y = cons(x,Nil));
      while (x = token(s,0))
         y = cdr(y) = cons(x,Nil);
      x = Pop(c2);
   }
   Chr = c,  Env.get = getSave;
   if (Env.parser = save)
      drop(c1);
   return x;
}

static void putString(int c) {
   if (StrP)
      byteSym(c, &StrI, &StrP);
   else
      StrI = 0,  data(StrCell) = StrP = box(c & 0xFF);
}

void begString(void) {
   StrP = NULL;
   Push(StrCell,Nil);
   PutSave = Env.put,  Env.put = putString;
}

any endString(void) {
   Env.put = PutSave;
   drop(StrCell);
   return StrP? consStr(data(StrCell)) : Nil;
}

// (any 'sym) -> any
any doAny(any ex) {
   any x;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   if (!isNil(x)) {
      int c;
      parseFrame *save, parser;
      void (*getSave)(void);
      cell c1;

      if (save = Env.parser)
         Push(c1, Env.parser->name);
      Env.parser = &parser;
      parser.dig = unDig(parser.name = name(x));
      parser.eof = 0xFF00 | ' ';
      getSave = Env.get,  Env.get = getParse,  c = Chr,  Chr = 0;
      getParse();
      x = read0(YES);
      Chr = c,  Env.get = getSave;
      if (Env.parser = save)
         drop(c1);
   }
   return x;
}

// (sym 'any) -> sym
any doSym(any x) {
   cell c1;

   x = EVAL(cadr(x));
   begString();
   Push(c1,x);
   print(data(c1));
   return endString();
}

// (str 'sym ['sym1]) -> lst
// (str 'lst) -> sym
any doStr(any ex) {
   any x;
   cell c1, c2;

   x = cdr(ex);
   if (isNil(x = EVAL(car(x))))
      return Nil;
   if (isSym(x)) {
      if (!isCell(cddr(ex)))
         return parse(x, NO, NULL);
      Push(c1, x);
      Push(c2, evSym(cddr(ex)));
      x = parse(x, NO, data(c2));
      drop(c1);
      return x;
   }
   NeedCell(ex,x);
   begString();
   Push(c1,x);
   print(car(x));
   while (isCell(x = cdr(x)))
      space(),  print(car(x));
   return endString();
}

any load(any ex, int pr, any x) {
   cell c1;
   inFrame f;

   if (isSym(x) && firstByte(x) == '-') {
      Push(c1, parse(x, YES, NULL));
      x = evList(data(c1));
      drop(c1);
      return x;
   }
   rdOpen(ex, x, &f);
   doHide(Nil);
   pushInFiles(&f);
   x = Nil;
   for (;;) {
      if (InFile)
         data(c1) = read1(0);
      else {
         if (pr && !Chr)
            Env.put(pr), space(), flush(OutFile);
         data(c1) = read1('\n');
         if (Chr == '\n')
            Chr = 0;
      }
      if (isNil(data(c1)))
         break;
      Save(c1),  x = EVAL(data(c1)),  drop(c1);
      if (!InFile && !Chr) {
         val(At3) = val(At2),  val(At2) = val(At),  val(At) = x;
         outString("-> "),  flush(OutFile),  print(x),  crlf();
      }
   }
   popInFiles();
   doHide(Nil);
   return x;
}

// (load 'any ..) -> any
any doLoad(any ex) {
   any x, y;

   x = cdr(ex);
   do {
      if ((y = EVAL(car(x))) != T)
         y = load(ex, '>', y);
      else
         while (*AV  &&  strcmp(*AV,"-") != 0)
            y = load(ex, '>', mkStr(*AV++));
   } while (isCell(x = cdr(x)));
   return y;
}

// (in 'any . prg) -> any
any doIn(any ex) {
   any x;
   inFrame f;

   x = cdr(ex),  x = EVAL(car(x));
   rdOpen(ex,x,&f);
   pushInFiles(&f);
   x = prog(cddr(ex));
   popInFiles();
   return x;
}

// (out 'any . prg) -> any
any doOut(any ex) {
   any x;
   outFrame f;

   x = cdr(ex),  x = EVAL(car(x));
   wrOpen(ex,x,&f);
   pushOutFiles(&f);
   x = prog(cddr(ex));
   popOutFiles();
   return x;
}

// (pipe exe) -> cnt
// (pipe exe . prg) -> any
any doPipe(any ex) {
   any x;
   inFrame f;
   int pfd[2];

   if (pipe(pfd) < 0)
      err(ex, NULL, "Can't pipe");
   if ((f.pid = forkLisp(ex)) == 0) {
      if (isCell(cddr(ex)))
         setpgid(0,0);
      close(pfd[0]);
      if (pfd[1] != STDOUT_FILENO)
         dup2(pfd[1], STDOUT_FILENO),  close(pfd[1]);
      EVAL(cadr(ex));
      bye(0);
   }
   close(pfd[1]);
   if (f.pid < 0)
      err(ex, NULL, "fork");
   if (!isCell(cddr(ex))) {
      initInFile(pfd[0], NULL);
      return boxCnt(pfd[0]);
   }
   initInFile(f.fd = pfd[0], NULL);
   setpgid(f.pid,0);
   pushInFiles(&f);
   x = prog(cddr(ex));
   popInFiles();
   return x;
}

// (ctl 'sym . prg) -> any
any doCtl(any ex) {
   any x;
   ctlFrame f;

   x = cdr(ex),  x = EVAL(car(x));
   ctOpen(ex,x,&f);
   pushCtlFiles(&f);
   x = prog(cddr(ex));
   popCtlFiles();
   return x;
}

// (open 'sym) -> cnt | NIL
any doOpen(any ex) {
   any x;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   {
      int fd;
      char nm[pathSize(x)];

      pathString(x, nm);
      while ((fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) {
         if (errno != EINTR)
            return Nil;
         if (Signal)
            sighandler(ex);
      }
      initInFile(fd, strdup(nm)), initOutFile(fd);
      return boxCnt(fd);
   }
}

// (close 'cnt) -> cnt | NIL
any doClose(any ex) {
   any x;
   int fd;

   x = cdr(ex),  x = EVAL(car(x));
   if (close(fd = (int)xCnt(ex,x)))
      return Nil;
   closeInFile(fd),  closeOutFile(fd);
   return x;
}

// (echo ['cnt ['cnt]] | ['sym ..]) -> sym
any doEcho(any ex) {
   any x, y;
   long cnt;

   x = cdr(ex),  y = EVAL(car(x));
   if (!Chr)
      Env.get();
   if (isNil(y) && !isCell(cdr(x))) {
      while (Chr >= 0)
         Env.put(Chr),  Env.get();
      return T;
   }
   if (isSym(y)) {
      int res, m, n, i, j, ac = length(x), p[ac], om, op;
      cell c[ac];
      char *av[ac];

      for (i = 0;;) {
         Push(c[i], y);
         av[i] = alloc(NULL, bufSize(y)),  bufString(y, av[i]);
         p[i] = 0;
         if (++i == ac)
            break;
         y = evSym(x = cdr(x));
      }
      res = m = -1;
      while (Chr >= 0) {
         if ((om = m) >= 0)
            op = p[m];
         for (i = 0; i < ac; ++i) {
            for (;;) {
               if (av[i][p[i]] == (byte)Chr) {
                  if (av[i][++p[i]]) {
                     if (m < 0  ||  p[i] > p[m])
                        m = i;
                     break;
                  }
                  if (om >= 0)
                     for (j = 0, n = op-p[i]+1; j < n; ++j)
                        Env.put(av[om][j]);
                  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;
               if (m == i)
                  for (m = -1, j = 0; j < ac; ++j)
                     if (p[j] && (m < 0 || p[j] > p[m]))
                        m = j;
            }
         }
         if (m < 0) {
            if (om >= 0)
               for (i = 0; i < op; ++i)
                  Env.put(av[om][i]);
            Env.put(Chr);
         }
         else if (om >= 0)
            for (i = 0, n = op-p[m]+1; i < n; ++i)
               Env.put(av[om][i]);
         Env.get();
      }
   done:
      i = 0;  do
         free(av[i]);
      while (++i < ac);
      drop(c[0]);
      return res < 0? Nil : data(c[res]);
   }
   if (isCell(x = cdr(x))) {
      for (cnt = xCnt(ex,y), y = EVAL(car(x)); --cnt >= 0; Env.get())
         if (Chr < 0)
            return Nil;
   }
   for (cnt = xCnt(ex,y); --cnt >= 0; Env.get()) {
      if (Chr < 0)
         return Nil;
      Env.put(Chr);
   }
   return T;
}

/*** Prining ***/
void putStdout(int c) {
   if (!OutFile)
      putc_unlocked(c, StdOut);
   else {
      if (OutFile->ix == BUFSIZ) {
         OutFile->ix = 0;
         wrBytes(OutFile->fd, OutFile->buf, BUFSIZ);
      }
      OutFile->buf[OutFile->ix++] = c;
   }
}

void crlf(void) {Env.put('\n');}
void space(void) {Env.put(' ');}

void outWord(word n) {
   if (n > 9)
      outWord(n / 10);
   Env.put('0' + n % 10);
}

void outString(char *s) {
   while (*s)
      Env.put(*s++);
}

static void outSym(int c) {
   do
      Env.put(c);
   while (c = symByte(NULL));
}

void outName(any s) {outSym(symByte(name(s)));}

/* Print one expression */
void print(any x) {
   if (Signal)
      sighandler(T);
   if (isNum(x))
      outName(numToSym(x, 0, 0, 0));
   else if (isNil(x))
      outString("NIL");
   else if (isSym(x)) {
      int c;

      if (!(c = symByte(name(x))))
         Env.put('$'),  outWord(num(x)/sizeof(cell));
      else if (isExt(x))
         Env.put('{'),  outSym(c),  Env.put('}');
      else if (hashed(x, hash(name(x)), Intern)) {
         do {
            if (strchr(Delim, c))
               Env.put('\\');
            Env.put(c);
         } while (c = symByte(NULL));
      }
      else {
         Env.put('"');
         do {
            if (c == '"'  ||  c == '^'  ||  c == '\\')
               Env.put('\\');
            else if (c == 127)
               Env.put('^'),  c = '?';
            else if (c < ' ')
               Env.put('^'),  c |= 0x40;
            Env.put(c);
         } while (c = symByte(NULL));
         Env.put('"');
      }
   }
   else if (car(x) == Quote  &&  x != cdr(x))
      Env.put('\''),  print(cdr(x));
   else {
      cell c1;

      Push(c1,x);
      Env.put('(');
      while (print(car(x)), !isNil(x = cdr(x))) {
         if (x == data(c1)) {
            outString(" .");
            break;
         }
         if (!isCell(x)) {
            outString(" . ");
            print(x);
            break;
         }
         space();
      }
      Env.put(')');
      drop(c1);
   }
}

void prin(any x) {
   if (Signal)
      sighandler(T);
   if (!isNil(x)) {
      if (isNum(x))
         outName(numToSym(x, 0, 0, 0));
      else if (isSym(x)) {
         if (isExt(x))
            Env.put('{');
         outName(x);
         if (isExt(x))
            Env.put('}');
      }
      else {
         cell c1;

         Push(c1,x);
         while (prin(car(x)), !isNil(x = cdr(x))) {
            if (!isCell(x)) {
               prin(x);
               break;
            }
         }
         drop(c1);
      }
   }
}

// (prin 'any ..) -> any
any doPrin(any x) {
   any y = Nil;

   while (isCell(x = cdr(x)))
      prin(y = EVAL(car(x)));
   return y;
}

// (prinl 'any ..) -> any
any doPrinl(any x) {
   any y = Nil;

   while (isCell(x = cdr(x)))
      prin(y = EVAL(car(x)));
   crlf();
   return y;
}

// (space ['cnt]) -> cnt
any doSpace(any ex) {
   any x;
   int n;

   if (isNil(x = EVAL(cadr(ex)))) {
      Env.put(' ');
      return One;
   }
   for (n = xCnt(ex,x); n > 0; --n)
      Env.put(' ');
   return x;
}

// (print 'any ..) -> any
any doPrint(any x) {
   any y;

   x = cdr(x),  print(y = EVAL(car(x)));
   while (isCell(x = cdr(x)))
      space(),  print(y = EVAL(car(x)));
   return y;
}

// (printsp 'any ..) -> any
any doPrintsp(any x) {
   any y;