io.c

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

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

#include "pico.h"

#ifdef __CYGWIN__
#include <sys/file.h>
#define fcntl(fd,cmd,fl) 0
#endif

static any read0(bool);

// I/O Tokens
enum {NIX, BEG, DOT, END};
enum {NUMBER, INTERN, TRANSIENT, EXTERN};

static char Delim[] = " \t\n\r\"'()[]`~";
static int StrI;
static cell StrCell, *StrP;
static bool Sync;
static byte *PipeBuf, *PipePtr;
static void (*PutSave)(int);
static int Transactions;
static byte TBuf[] = {INTERN+4, 'T'};

static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));}
static void badFd(any ex, any x) {err(ex, x, "Bad FD");}
static void lockErr(void) {err(NULL, NULL, "File lock: %s", strerror(errno));}
static void writeErr(char *s) {err(NULL, NULL, "%s write: %s", s, strerror(errno));}
static void dbErr(char *s) {err(NULL, NULL, "DB %s: %s", s, strerror(errno));}
static void dbfErr(void) {err(NULL, NULL, "Bad DB file");}
static void eofErr(void) {err(NULL, NULL, "EOF Overrun");}
static void closeErr(char *s) {err(NULL, NULL, "%s close: %s", s, strerror(errno));}

static void lockFile(int fd, int cmd, int typ) {
   struct flock fl;

   fl.l_type = typ;
   fl.l_whence = SEEK_SET;
   fl.l_start = 0;
   fl.l_len = 0;
   while (fcntl(fd, cmd, &fl) < 0  &&  typ != F_UNLCK)
      if (errno != EINTR)
         lockErr();
}

void blocking(bool flg, any ex, int fd) {
   int n;

   if ((n = fcntl(fd, F_GETFL, 0)) < 0)
      err(ex, NULL, "GETFL %s", strerror(errno));
   if (flg)
      n &= ~O_NONBLOCK;
   else
      n |= O_NONBLOCK;
   if (fcntl(fd, F_SETFL, n) < 0)
      err(ex, NULL, "SETFL %s", strerror(errno));
}

static inline bool inReady(int fd) {
   inFile *p;

   return fd < InFDs  &&  (p = InFiles[fd])  &&  p->ix < p->cnt;
}

void initInFile(int fd, char *nm) {
   inFile *p;

   if (fd >= InFDs) {
      int i = InFDs;

      InFiles = alloc(InFiles, (InFDs = fd + 1) * sizeof(inFile*));
      do
         InFiles[i] = NULL;
      while (++i < InFDs);
   }
   p = InFiles[fd] = alloc(InFiles[fd], sizeof(inFile));
   p->fd = fd;
   p->ix = p->cnt = p->next = 0;
   p->line = p->src = 1;
   p->name = nm;
}

void initOutFile(int fd) {
   outFile *p;

   if (fd >= OutFDs) {
      int i = OutFDs;

      OutFiles = alloc(OutFiles, (OutFDs = fd + 1) * sizeof(outFile*));
      do
         OutFiles[i] = NULL;
      while (++i < OutFDs);
   }
   p = OutFiles[fd] = alloc(OutFiles[fd], sizeof(outFile));
   p->fd = fd;
   p->ix = 0;
}

void closeInFile(int fd) {
   inFile *p;

   if (fd < InFDs && (p = InFiles[fd]))
      free(p->name),  free(p),  InFiles[fd] = NULL;
}

void closeOutFile(int fd) {
   if (fd < OutFDs)
      free(OutFiles[fd]),  OutFiles[fd] = NULL;
}

int slow(int fd, byte *p, int cnt) {
   int n;

   while ((n = read(fd, p, cnt)) < 0) {
      if (errno != EINTR)
         return 0;
      if (Signal)
         sighandler(T);
   }
   return n;
}

bool rdBytes(int fd, byte *p, int cnt) {
   int n;

   do {
      while ((n = read(fd, p, cnt)) <= 0) {
         if (!n || errno != EINTR)
            return NO;
         if (Signal)
            sighandler(T);
      }
   } while (p += n,  cnt -= n);
   return YES;
}

bool wrBytes(int fd, byte *p, int cnt) {
   int n;

   do {
      if ((n = write(fd, p, cnt)) >= 0)
         p += n, cnt -= n;
      else if (errno == EBADF || errno == EPIPE || errno == ECONNRESET)
         return NO;
      else if (errno != EINTR)
         writeErr("bytes");
      if (Signal)
         sighandler(T);
   } while (cnt);
   return YES;
}

static void wrChild(int i, byte *p, int cnt) {
   int n;

   if (Child[i].cnt == 0) {
      for (;;) {
         if ((n = write(Child[i].tell, p, cnt)) >= 0) {
            p += n;
            if ((cnt -= n) == 0)
               return;
         }
         else if (errno == EAGAIN)
            break;
         else if (errno == EPIPE || errno == ECONNRESET) {
            Child[i].pid = 0;
            close(Child[i].hear),  close(Child[i].tell);
            free(Child[i].buf);
            return;
         }
         else if (errno != EINTR)
            writeErr("child");
      }
   }
   n = Child[i].cnt;
   Child[i].buf = alloc(Child[i].buf, n + sizeof(int) + cnt);
   *(int*)(Child[i].buf + n) = cnt;
   memcpy(Child[i].buf + n + sizeof(int), p, cnt);
   Child[i].cnt += sizeof(int) + cnt;
}

bool flush(outFile *p) {
   int n;

   if (!p)
      return !fflush(StdOut);
   if (n = p->ix) {
      p->ix = 0;
      return wrBytes(p->fd, p->buf, n);
   }
   return YES;
}

/*** Low level I/O ***/
static int getBinary(void) {
   if (InFile->ix == InFile->cnt) {
      InFile->ix = InFile->cnt = 0;
      if (!(InFile->cnt = slow(InFile->fd, InFile->buf, BUFSIZ)))
         return -1;
   }
   return InFile->buf[InFile->ix++];
}

static any rdNum(int cnt) {
   int n, i;
   any x;
   cell c1;

   if ((n = getBin()) < 0)
      return NULL;
   i = 0,  Push(c1, x = box(n));
   if (--cnt == 62) {
      do {
         if ((n = getBin()) < 0)
            return NULL;
         byteSym(n, &i, &x);
      } while (--cnt);
      for (;;) {
         if ((cnt = getBin()) < 0)
            return NULL;
         if (cnt != 255)
            break;
         do {
            if ((n = getBin()) < 0)
               return NULL;
            byteSym(n, &i, &x);
         } while (--cnt);
      }
   }
   while (--cnt >= 0) {
      if ((n = getBin()) < 0)
         return NULL;
      byteSym(n, &i, &x);
   }
   return Pop(c1);
}

any binRead(void) {
   int c;
   any x, y, *h;
   cell c1;

   if ((c = getBin()) < 0)
      return NULL;
   if ((c & ~3) == 0) {
      if (c == NIX)
         return Nil;
      if (c == BEG) {
         if ((x = binRead()) == NULL)
            return NULL;
         Push(c1, x = cons(x,Nil));
         while ((y = binRead()) != (any)END) {
            if (y == NULL) {
               drop(c1);
               return NULL;
            }
            if (y == (any)DOT) {
               if ((y = binRead()) == NULL) {
                  drop(c1);
                  return NULL;
               }
               cdr(x) = y == (any)END? data(c1) : y;
               break;
            }
            x = cdr(x) = cons(y,Nil);
         }
         return Pop(c1);
      }
      return (any)(long)c;  // NIX, DOT or END
   }
   if ((y = rdNum(c / 4)) == NULL)
      return NULL;
   if ((c &= 3) == NUMBER)
      return y;
   if (c == TRANSIENT)
      return consStr(y);
   if (c == EXTERN) {
      if (x = findHash(y, h = Extern + hash(y)))
         return x;
      mkExt(x = consSym(Nil,y));
      *h = cons(x,*h);
      return x;
   }
   if (x = findHash(y, h = Intern + hash(y)))
      return x;
   x = consSym(Nil,y);
   *h = cons(x,*h);
   return x;
}

static void prDig(int t, word n) {
   int i = 1;
   word m = MASK;

   while (n & (m <<= 8))
      ++i;
   putBin(i*4+t);
   while (putBin(n), --i)
      n >>= 8;
}

static int numByte(any s) {
   static int i;
   static any x;
   static word n;

   if (s)
      i = 0,  n = unDig(x = s);
   else if (n >>= 8,  (++i & sizeof(word)-1) == 0)
      n = unDig(x = cdr(numCell(x)));
   return n & 0xFF;
}

static void prNum(int t, any x) {
   int cnt, i;

   if (!isNum(cdr(numCell(x))))
      prDig(t, unDig(x));
   else if ((cnt = numBytes(x)) < 63) {
      putBin(cnt*4+t);
      putBin(numByte(x));
      while (--cnt)
         putBin(numByte(NULL));
   }
   else {
      putBin(63*4+t);
      putBin(numByte(x));
      for (i = 1; i < 63; ++i)
         putBin(numByte(NULL));
      cnt -= 63;
      while (cnt >= 255) {
         putBin(255);
         for (i = 0; i < 255; ++i)
            putBin(numByte(NULL));
         cnt -= 255;
      }
      putBin(cnt);
      while (--cnt >= 0)
         putBin(numByte(NULL));
   }
}

void binPrint(any x) {
   any y;

   if (isNum(x))
      prNum(NUMBER, x);
   else if (isNil(x))
      putBin(NIX);
   else if (isSym(x)) {
      if (!isNum(y = name(x)))
         binPrint(y);
      else
         prNum(
            isExt(x)? EXTERN : hashed(x, hash(y), Intern)? INTERN : TRANSIENT,
            y );
   }
   else {
      y = x;
      putBin(BEG);
      while (binPrint(car(x)), !isNil(x = cdr(x))) {
         if (x == y) {
            putBin(DOT);
            break;
         }
         if (!isCell(x)) {
            putBin(DOT);
            binPrint(x);
            return;
         }
      }
      putBin(END);
   }
}

void pr(any x) {putBin = putStdout,  binPrint(x);}
void prn(long n) {putBin = putStdout,  prDig(0, n >= 0? n * 2 : -n * 2 + 1);}

/* Family IPC */
static void putTell(int c) {
   *PipePtr++ = c;
   if (PipePtr == PipeBuf + PIPE_BUF - 1)  // END
      err(NULL, NULL, "Tell PIPE_BUF");
}

static void tellBeg(ptr *pb, ptr *pp, ptr buf) {
   *pb = PipeBuf,  *pp = PipePtr;
   PipePtr = (PipeBuf = buf) + sizeof(int);
   *PipePtr++ = BEG;
}

static void prTell(any x) {putBin = putTell,  binPrint(x);}

static void tellEnd(ptr *pb, ptr *pp) {
   int i, n;

   *PipePtr++ = END;
   *(int*)PipeBuf = n = PipePtr - PipeBuf - sizeof(int);
   if (Tell && !wrBytes(Tell, PipeBuf, n+sizeof(int)))
      close(Tell),  Tell = 0;
   for (i = 0; i < Children; ++i)
      if (Child[i].pid)
         wrChild(i, PipeBuf+sizeof(int), n);
   PipePtr = *pp,  PipeBuf = *pb;
}

static any rdHear(void) {
   any x;
   inFile *iSave = InFile;

   InFile = InFiles[Hear];
   getBin = getBinary;
   x = binRead();
   InFile = iSave;
   return x;
}


/* Return next byte from symbol name */
int symByte(any s) {
   static any x;
   static word n;

   if (s) {
      if (!isNum(x = s))
         return 0;
      n = unDig(x);
   }
   else if ((n >>= 8) == 0) {
      if (!isNum(x = cdr(numCell(x))))
         return 0;
      n = unDig(x);
   }
   return n & 0xFF;
}

/* Return next char from symbol name */
int symChar(any s) {
   int c = symByte(s);

   if (c == 0xFF)
      return TOP;
   if (c & 0x80) {
      if ((c & 0x20) == 0)
         c &= 0x1F;
      else
         c = (c & 0xF) << 6 | symByte(NULL) & 0x3F;
      c = c << 6 | symByte(NULL) & 0x3F;
   }
   return c;
}

int numBytes(any x) {
   int cnt;
   word n, m = MASK;

   for (cnt = 1;  isNum(cdr(numCell(x)));  cnt += WORD)
      x = cdr(numCell(x));
   for (n = unDig(x); n & (m <<= 8); ++cnt);
   return cnt;
}

/* Buffer size */
int bufSize(any x) {return isNum(x = name(x))? numBytes(x)+1 : 1;}

int pathSize(any x) {
   int c = firstByte(x);

   if (c != '@'  &&  (c != '+' || secondByte(x) != '@'))
      return bufSize(x);
   if (!Home)
      return numBytes(name(x));
   return strlen(Home) + numBytes(name(x));
}

void bufString(any x, char *p) {
   int c = symByte(name(x));

   while (*p++ = c)
      c = symByte(NULL);
}

void pathString(any x, char *p) {
   int c;
   char *h;

   if ((c = symByte(name(x))) == '+')
      *p++ = c,  c = symByte(NULL);
   if (c != '@')
      while (*p++ = c)
         c = symByte(NULL);
   else {
      if (h = Home)
         do
            *p++ = *h++;
         while (*h);
      while (*p++ = symByte(NULL));
   }
}

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

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

      pathString(x,nm);
      return mkStr(nm);
   }
}

/* Add next byte to symbol name */
void byteSym(int c, int *i, any *p) {
   if ((*i += 8) < BITS)
      setDig(*p, unDig(*p) | (c & 0xFF) << *i);
   else
      *i = 0,  *p = cdr(numCell(*p)) = box(c & 0xFF);
}

/* Box first char of symbol name */
any boxChar(int c, int *i, any *p) {
   *i = 0;
   if (c < 0x80)
      *p = box(c);
   else if (c < 0x800) {
      *p = box(0xC0 | c>>6 & 0x1F);
      byteSym(0x80 | c & 0x3F, i, p);
   }
   else if (c == TOP)
      *p = box(0xFF);
   else {
      *p = box(0xE0 | c>>12 & 0x0F);
      byteSym(0x80 | c>>6 & 0x3F, i, p);
      byteSym(0x80 | c & 0x3F, i, p);
   }
   return *p;
}

/* Add next char to symbol name */
void charSym(int c, int *i, any *p) {
   if (c < 0x80)
      byteSym(c, i, p);
   else if (c < 0x800) {
      byteSym(0xC0 | c>>6 & 0x1F, i, p);
      byteSym(0x80 | c & 0x3F, i, p);
   }
   else if (c == TOP)
      byteSym(0xFF, i, p);
   else {
      byteSym(0xE0 | c>>12 & 0x0F, i, p);
      byteSym(0x80 | c>>6 & 0x3F, i, p);
      byteSym(0x80 | c & 0x3F, i, p);
   }
}

static int currFd(any ex, char *p) {
   if (!Env.inFiles && !Env.outFiles)
      err(ex, NULL, "No current fd");
   if (!Env.inFiles)
      return OutFile? OutFile->fd : STDOUT_FILENO;
   if (!Env.outFiles)
      return InFile? InFile->fd : STDIN_FILENO;
   return labs((char*)Env.outFiles - p) > labs((char*)Env.inFiles - p)?
      (InFile? InFile->fd : STDIN_FILENO) : (OutFile? OutFile->fd : STDOUT_FILENO);
}

void rdOpen(any ex, any x, inFrame *f) {
   if (isNil(x))