io.c

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

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

// (println 'any ..) -> any
any doPrintln(any x) {
   any y;

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

// (flush) -> flg
any doFlush(any ex __attribute__((unused))) {
   return flush(OutFile)? T : Nil;
}

// (rewind) -> flg
any doRewind(any ex __attribute__((unused))) {
   if (!OutFile)
      return fseek(StdOut, 0L, SEEK_SET) || ftruncate(fileno(StdOut), 0)? Nil : T;
   OutFile->ix = 0;
   return lseek(OutFile->fd, 0L, SEEK_SET) || ftruncate(OutFile->fd, 0)? Nil : T;
}

// (rd ['sym]) -> any
// (rd 'cnt) -> num | NIL
any doRd(any x) {
   int i, j;
   long cnt;
   word n;
   cell c1;

   x = cdr(x),  x = EVAL(car(x));
   if (!InFile)
      return Nil;
   if (!isNum(x)) {
      getBin = getBinary;
      return binRead() ?: x;
   }
   if ((cnt = unBox(x)) < 0) {
      byte buf[cnt = -cnt];

      if (!rdBytes(InFile->fd, buf, cnt))  // Little Endian
         return Nil;
      if (cnt % sizeof(word) == 0)
         Push(c1, Nil);
      else {
         n = buf[--cnt];

         while (cnt % sizeof(word))
            n = n << 8 | buf[--cnt];
         Push(c1, box(n));
      }
      while ((cnt -= WORD) >= 0) {
         n = buf[cnt + WORD-1];
         i = WORD-2;
         do
            n = n << 8 | buf[cnt + i];
         while (--i >= 0);
         data(c1) = consNum(n, data(c1));
      }
   }
   else {
      byte buf[cnt];

      if (!rdBytes(InFile->fd, buf, cnt))
         return Nil;
      if (cnt % sizeof(word) == 0) {
         i = 0;
         Push(c1, Nil);
      }
      else {
         n = buf[0];

         for (i = 1;  i < (int)(cnt % sizeof(word));  ++i)
            n = n << 8 | buf[i];
         Push(c1, box(n));
      }
      while (i < cnt) {
         n = buf[i++];
         j = 1;
         do
            n = n << 8 | buf[i++];
         while (++j < WORD);
         data(c1) = consNum(n, data(c1));
      }
   }
   zapZero(data(c1));
   digMul2(data(c1));
   return Pop(c1);
}

// (pr 'any ..) -> any
any doPr(any x) {
   any y;

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

// (wr 'num ..) -> num
any doWr(any x) {
   any y;

   x = cdr(x);
   do
      putStdout(unDig(y = EVAL(car(x))) / 2);
   while (isCell(x = cdr(x)));
   return y;
}

static void putChar(int c) {putchar_unlocked(c);}

// (rpc 'sym ['any ..]) -> flg
any doRpc(any x) {
   any y;

   x = cdr(x),  y = EVAL(car(x));
   putBin = putChar,  putBin(BEG),  binPrint(y);
   while (isCell(x = cdr(x)))
      y = EVAL(car(x)),  putBin = putChar,  binPrint(y);
   putBin(END);
   return fflush(stdout)? Nil : T;
}

/*** DB-I/O ***/
#define BLKSIZE 64  // DB block unit size
#define BLK 6
#define TAGMASK (BLKSIZE-1)
#define BLKMASK (~TAGMASK)

typedef long long adr;

static int F, Files, *BlkShift, *BlkFile, *BlkSize, MaxBlkSize;
static FILE *Journal;
static adr BlkIndex, BlkLink;
static word2 *Marks;
static byte *Locks, *Ptr, **Mark;
static byte *Block, *IniBlk;  // 01 00 00 00 00 00 NIL 0

static adr getAdr(byte *p) {
   return (adr)p[0] | (adr)p[1]<<8 | (adr)p[2]<<16 |
                           (adr)p[3]<<24 | (adr)p[4]<<32 | (adr)p[5]<<40;
}

static void setAdr(adr n, byte *p) {
   p[0] = (byte)n,  p[1] = (byte)(n >> 8),  p[2] = (byte)(n >> 16);
   p[3] = (byte)(n >> 24),  p[4] = (byte)(n >> 32),  p[5] = (byte)(n >> 40);
}

static void jnlErr(void) {err(NULL, NULL, "Bad Journal");}

any new64(word2 n, any x) {
   int c, i;
   word2 w = 0;

   do {
      if ((c = n & 0x3F) > 11)
         c += 5;
      if (c > 42)
         c += 6;
      w = w << 8 | c + '0';
   } while (n >>= 6);
   if (i = F) {
      ++i;
      w = w << 8 | '-';
      do {
         if ((c = i & 0x3F) > 11)
            c += 5;
         if (c > 42)
            c += 6;
         w = w << 8 | c + '0';
      } while (i >>= 6);
   }
   return hi(w)? consNum(num(w), consNum(hi(w), x)) :  consNum(num(w), x);
}

word2 blk64(any x) {
   int c;
   word2 w;
   word2 n = 0;

   F = 0;
   if (isNum(x)) {
      w = unDig(x);
      if (isNum(x = cdr(numCell(x))))
         w |= (word2)unDig(x) << BITS;
      do {
         if ((c = w & 0xFF) == '-')
            F = n-1,  n = 0;
         else {
            if ((c -= '0') > 42)
               c -= 6;
            if (c > 11)
               c -= 5;
            n = n << 6 | c;
         }
      } while (w >>= 8);
   }
   return n;
}

/* DB Record Locking */
static void dbLock(int cmd, int typ, int f, off_t len) {
   struct flock fl;

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

static inline void rdLock(void) {
   if (val(Solo) != T)
      dbLock(F_SETLKW, F_RDLCK, 0, 1);
}

static inline void wrLock(void) {
   if (val(Solo) != T)
      dbLock(F_SETLKW, F_WRLCK, 0, 1);
}

static inline void rwUnlock(off_t len) {
   if (val(Solo) != T) {
      if (len == 0) {
         int f;

         for (f = 1; f < Files; ++f)
            if (Locks[f])
               dbLock(F_SETLK, F_UNLCK, f, 0),  Locks[f] = 0;
         val(Solo) = Zero;
      }
      dbLock(F_SETLK, F_UNLCK, 0, len);
   }
}

static pid_t tryLock(off_t n, off_t len) {
   struct flock fl;

   for (;;) {
      fl.l_type = F_WRLCK;
      fl.l_whence = SEEK_SET;
      fl.l_start = n;
      fl.l_len = len;
      if (fcntl(BlkFile[F], F_SETLK, &fl) >= 0) {
         Locks[F] = 1;
         if (!n)
            val(Solo) = T;
         else if (val(Solo) != T)
            val(Solo) = Nil;
         return 0;
      }
      if (errno != EINTR  &&  errno != EACCES  &&  errno != EAGAIN)
         lockErr();
      fl.l_type = F_WRLCK;  //??
      fl.l_whence = SEEK_SET;
      fl.l_start = n;
      fl.l_len = len;
      while (fcntl(BlkFile[F], F_GETLK, &fl) < 0)
         if (errno != EINTR)
            lockErr();
      if (fl.l_type != F_UNLCK)
         return fl.l_pid;
   }
}

static void blkPeek(off_t pos, void *buf, int siz) {
   while (pread(BlkFile[F], buf, siz, pos) != (ssize_t)siz)
      if (errno != EINTR)
         dbErr("read");
}

static void blkPoke(off_t pos, void *buf, int siz) {
   while (pwrite(BlkFile[F], buf, siz, pos) != (ssize_t)siz)
      if (errno != EINTR)
         dbErr("write");
   if (Journal) {
      byte a[BLK];

      putc_unlocked(siz == BlkSize[F]? BLKSIZE : siz, Journal);
      a[0] = (byte)F,  a[1] = (byte)(F >> 8),  fwrite(a, 2, 1, Journal);
      setAdr(pos >> BlkShift[F], a),  fwrite(a, BLK, 1, Journal);
      fwrite(buf, siz, 1, Journal);
   }
}

static void rdBlock(adr n) {
   blkPeek((BlkIndex = n) << BlkShift[F], Block, BlkSize[F]);
   BlkLink = getAdr(Block) & BLKMASK;
   Ptr = Block + BLK;
}

static void wrBlock(void) {blkPoke(BlkIndex << BlkShift[F], Block, BlkSize[F]);}

static adr newBlock(void) {
   adr n;
   byte buf[2*BLK];

   blkPeek(0, buf, 2*BLK);  // Get Free, Next
   setAdr(0, IniBlk);
   if (n = getAdr(buf)) {
      blkPeek(n << BlkShift[F], buf, BLK);  // Get free link
      blkPoke(0, buf, 2*BLK);
      blkPoke(n << BlkShift[F], IniBlk, BlkSize[F]);
   }
   else if ((n = getAdr(buf+BLK)) < 281474976710592LL) {
      setAdr(n + BLKSIZE, buf+BLK);  // Increment next
      blkPoke(n << BlkShift[F], IniBlk, BlkSize[F]);
      blkPoke(0, buf, 2*BLK);
   }
   else
      err(NULL, NULL, "DB Oversize");
   return n;
}

any newId(int i) {
   adr n;

   if ((F = i-1) >= Files)
      dbfErr();
   wrLock();
   if (Journal)
      lockFile(fileno(Journal), F_SETLKW, F_WRLCK);
   n = newBlock();
   if (Journal)
      fflush(Journal),  lockFile(fileno(Journal), F_SETLK, F_UNLCK);
   rwUnlock(1);
   return new64(n/BLKSIZE, At2);  // dirty
}

bool isLife(any x) {
   adr n;
   byte buf[2*BLK];

   if ((n = blk64(name(x))*BLKSIZE)  &&  F < Files) {
      for (x = tail1(x); !isSym(x); x = cdr(cellPtr(x)));
      if (x == At || x == At2)
         return YES;
      if (x != At3) {
         blkPeek(0, buf, 2*BLK);  // Get Next
         if (n < getAdr(buf+BLK)) {
            blkPeek(n << BlkShift[F], buf, BLK);
            if ((getAdr(buf) & TAGMASK) == 1)
               return YES;
         }
      }
   }
   return NO;
}

static void cleanUp(adr n) {
   adr p, fr;
   byte buf[BLK];

   blkPeek(0, buf, BLK),  fr = getAdr(buf);  // Get Free
   setAdr(n, buf),  blkPoke(0, buf, BLK);    // Set new
   do {
      p = n;
      blkPeek(p << BlkShift[F], buf, BLK),  n = getAdr(buf);  // Get block link
      n &= BLKMASK;  // Clear Tag
      setAdr(n, buf),  blkPoke(p << BlkShift[F], buf, BLK);
   } while (n);
   if (fr)
      setAdr(fr, buf),  blkPoke(p << BlkShift[F], buf, BLK);  // Append old free list
}

static int getBlock(void) {
   if (Ptr == Block+BlkSize[F]) {
      if (!BlkLink)
         return 0;
      rdBlock(BlkLink);
   }
   return *Ptr++;
}

static void putBlock(int c) {
   if (Ptr == Block+BlkSize[F]) {
      if (BlkLink)
         wrBlock(),  rdBlock(BlkLink);
      else {
         adr n = newBlock();
         int cnt = Block[0];  // Link must be 0

         setAdr(n | cnt, Block);
         wrBlock();
         BlkIndex = n;
         if (cnt < TAGMASK)
            ++cnt;
         setAdr(cnt, Block);
         Ptr = Block + BLK;
      }
   }
   *Ptr++ = (byte)c;
}

// (pool ['sym1 ['lst] ['sym2]]) -> flg
any doPool(any ex) {
   any x, db;
   byte buf[2*BLK+1];

   val(Solo) = Zero;
   if (Files) {
      while (isNil(doRollback(Nil)));
      for (F = 0; F < Files; ++F) {
         if (Marks)
            free(Mark[F]);
         if (close(BlkFile[F]) < 0)
            closeErr("DB");
      }
      free(Mark), Mark = NULL, free(Marks), Marks = NULL;
      Files = 0;
   }
   if (Journal)
      fclose(Journal),  Journal = NULL;
   x = cdr(ex),  db = EVAL(car(x));
   NeedSym(ex,db);
   if (!isNil(db)) {
      x = cddr(ex),  x = EVAL(car(x));
      NeedLst(ex,x);
      Files = length(x) ?: 1;
      BlkShift = alloc(BlkShift, Files * sizeof(int));
      BlkFile = alloc(BlkFile, Files * sizeof(int));
      BlkSize = alloc(BlkSize, Files * sizeof(int));
      Locks = alloc(Locks, Files),  memset(Locks, 0, Files);
      MaxBlkSize = 0;
      for (F = 0; F < Files; ++F) {
         char nm[pathSize(db) + 8];

         pathString(db, nm);
         if (isCell(x))
            sprintf(nm + strlen(nm), "%d", F+1);
         BlkShift[F] = isNum(car(x))? (int)unDig(car(x))/2 : 2;
         if ((BlkFile[F] = open(nm, O_RDWR)) >= 0) {
            blkPeek(0, buf, 2*BLK+1);  // Get block shift
            BlkSize[F] = BLKSIZE << (BlkShift[F] = (int)buf[2*BLK]);
         }
         else {
            if (errno != ENOENT  ||
                     (BlkFile[F] = open(nm, O_CREAT|O_EXCL|O_RDWR, 0666)) < 0) {
               Files = 0;
               return Nil;
            }
            BlkSize[F] = BLKSIZE << BlkShift[F];
            setAdr(0, buf);  // Free
            if (F)
               setAdr(BLKSIZE, buf+BLK);  // Next
            else {
               byte blk[BlkSize[0]];

               setAdr(2*BLKSIZE, buf+BLK);  // Next
               memset(blk, 0, BlkSize[0]);
               setAdr(1, blk),  blkPoke(BlkSize[0], blk, BlkSize[0]);
            }
            buf[2*BLK] = (byte)BlkShift[F];
            blkPoke(0, buf, 2*BLK+1);
         }
         if (BlkSize[F] > MaxBlkSize)
            MaxBlkSize = BlkSize[F];
         x = cdr(x);
      }
      Block = alloc(Block, MaxBlkSize);
      IniBlk = alloc(IniBlk, MaxBlkSize);
      memset(IniBlk, 0, MaxBlkSize);
      x = cdddr(ex),  x = EVAL(car(x));
      NeedSym(ex,x);
      if (!isNil(x)) {
         char nm[pathSize(x)];

         pathString(x, nm);
         if (!(Journal = fopen(nm, "a")))
            openErr(ex, nm);
      }
   }
   return T;
}

// (journal 'any ..) -> T
any doJournal(any ex) {
   any x, y;
   int siz;
   FILE *fp;
   byte a[BLK], buf[MaxBlkSize];

   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 ((siz = getc_unlocked(fp)) >= 0) {
            if (fread(a, 2, 1, fp) != 1)
               jnlErr();
            if ((F = a[0] | a[1]<<8) >= Files)
               dbfErr();
            if (siz == BLKSIZE)
               siz = BlkSize[F];
            if (fread(a, BLK, 1, fp) != 1 || fread(buf, siz, 1, fp) != 1)
               jnlErr();
            blkPoke(getAdr(a) << BlkShift[F], buf, siz);
         }
         fclose(fp);
      }
   }
   return T;
}

static any mkId(word2 n) {
   any x, y, *h;

   x = new64(n, Nil);
   if (y = findHash(x, h = Extern + hash(x)))
      return y;
   mkExt(y = consSym(Nil,x));
   *h = cons(y,*h);
   return y;
}

// (id 'num 'num) -> sym
// (id 'sym [NIL]) -> num
// (id 'sym T) -> (num . num)
any doId(any ex) {
   any x, y;
   word2 n;
   cell c1;

   x = cdr(ex);
   if (isNum(y = EVAL(car(x)))) {
      F = unBox(y) - 1;
      x = cdr(x),  y = EVAL(car(x));
      NeedNum(ex,y);
      return mkId(unBoxWord2(y));
   }
   NeedExt(ex,y);
   n = blk64(name(y));
   x = cdr(x);
   if (isNil(EVAL(car(x))))
      return boxWord2(n);
   Push(c1, boxWord2(n));
   data(c1) = cons(box((F + 1) * 2), data(c1));
   return Pop(c1);
}

// (seq 'cnt|sym1 ['sym2 ['num]]) -> sym | num | NIL
any doSeq(any ex) {
   adr n, n2, free, p, next;
   any x, y;
   byte buf[2*BLK];

   x = cdr(ex);
   if (isNum(y = EVAL(car(x)))) {
      if ((F = (int)unDig(y)/2 - 1) >= Files)
         dbfErr();
      n = 0;
   }
   else {
      NeedExt(ex,y);
      if ((n = blk64(name(y))*BLKSIZE) ==