io.c - picolisp - Unnamed repository; edit this file to name it for gitweb.

io.c (86116B)
      1 /* 10jul13abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 #ifdef __CYGWIN__
      8 #include <sys/file.h>
      9 #define fcntl(fd,cmd,fl) 0
     10 #endif
     11 
     12 static any read0(bool);
     13 
     14 // I/O Tokens
     15 enum {NIX, BEG, DOT, END};
     16 enum {NUMBER, INTERN, TRANSIENT, EXTERN};
     17 
     18 static char Delim[] = " \t\n\r\"'(),[]`~{}";
     19 static int StrI;
     20 static cell StrCell, *StrP;
     21 static bool Sync;
     22 static pid_t Talking;
     23 static byte *PipeBuf, *PipePtr;
     24 static void (*PutSave)(int);
     25 static byte TBuf[] = {INTERN+4, 'T'};
     26 
     27 static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));}
     28 static void closeErr(void) {err(NULL, NULL, "Close error: %s", strerror(errno));}
     29 static void eofErr(void) {err(NULL, NULL, "EOF Overrun");}
     30 static void badInput(void) {err(NULL, NULL, "Bad input '%c'", Chr);}
     31 static void badFd(any ex, any x) {err(ex, x, "Bad FD");}
     32 static void lockErr(void) {err(NULL, NULL, "File lock: %s", strerror(errno));}
     33 static void writeErr(char *s) {err(NULL, NULL, "%s write: %s", s, strerror(errno));}
     34 static void selectErr(any ex) {err(ex, NULL, "Select error: %s", strerror(errno));}
     35 
     36 static void lockFile(int fd, int cmd, int typ) {
     37    struct flock fl;
     38 
     39    fl.l_type = typ;
     40    fl.l_whence = SEEK_SET;
     41    fl.l_start = 0;
     42    fl.l_len = 0;
     43    while (fcntl(fd, cmd, &fl) < 0  &&  typ != F_UNLCK)
     44       if (errno != EINTR)
     45          lockErr();
     46 }
     47 
     48 void closeOnExec(any ex, int fd) {
     49    if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
     50       err(ex, NULL, "SETFD %s", strerror(errno));
     51 }
     52 
     53 int nonblocking(int fd) {
     54    int flg = fcntl(fd, F_GETFL, 0);
     55 
     56    fcntl(fd, F_SETFL, flg | O_NONBLOCK);
     57    return flg;
     58 }
     59 
     60 inFile *initInFile(int fd, char *nm) {
     61    inFile *p;
     62 
     63    if (fd >= InFDs) {
     64       int i = InFDs;
     65 
     66       InFiles = alloc(InFiles, (InFDs = fd + 1) * sizeof(inFile*));
     67       do
     68          InFiles[i] = NULL;
     69       while (++i < InFDs);
     70    }
     71    p = InFiles[fd] = alloc(InFiles[fd], sizeof(inFile));
     72    p->fd = fd;
     73    p->ix = p->cnt = p->next = 0;
     74    p->line = p->src = 1;
     75    p->name = nm;
     76    return p;
     77 }
     78 
     79 outFile *initOutFile(int fd) {
     80    outFile *p;
     81 
     82    if (fd >= OutFDs) {
     83       int i = OutFDs;
     84 
     85       OutFiles = alloc(OutFiles, (OutFDs = fd + 1) * sizeof(outFile*));
     86       do
     87          OutFiles[i] = NULL;
     88       while (++i < OutFDs);
     89    }
     90    p = OutFiles[fd] = alloc(OutFiles[fd], sizeof(outFile));
     91    p->tty = isatty(p->fd = fd);
     92    p->ix = 0;
     93    return p;
     94 }
     95 
     96 void closeInFile(int fd) {
     97    inFile *p;
     98 
     99    if (fd < InFDs && (p = InFiles[fd])) {
    100       if (p == InFile)
    101          InFile = NULL;
    102       free(p->name),  free(p),  InFiles[fd] = NULL;
    103    }
    104 }
    105 
    106 void closeOutFile(int fd) {
    107    outFile *p;
    108 
    109    if (fd < OutFDs && (p = OutFiles[fd])) {
    110       if (p == OutFile)
    111          OutFile = NULL;
    112       free(p),  OutFiles[fd] = NULL;
    113    }
    114 }
    115 
    116 int slow(inFile *p, bool nb) {
    117    int n, f;
    118 
    119    p->ix = p->cnt = 0;
    120    for (;;) {
    121       if (nb)
    122          f = nonblocking(p->fd);
    123       n = read(p->fd, p->buf, BUFSIZ);
    124       if (nb)
    125          fcntl(p->fd, F_SETFL, f);
    126       if (n > 0)
    127          return p->cnt = n;
    128       if (n == 0) {
    129          p->ix = p->cnt = -1;
    130          return 0;
    131       }
    132       if (errno == EAGAIN)
    133          return -1;
    134       if (errno != EINTR)
    135          return 0;
    136       if (*Signal)
    137          sighandler(NULL);
    138    }
    139 }
    140 
    141 int rdBytes(int fd, byte *p, int cnt, bool nb) {
    142    int n, f;
    143 
    144    for (;;) {
    145       if (nb)
    146          f = nonblocking(fd);
    147       n = read(fd, p, cnt);
    148       if (nb)
    149          fcntl(fd, F_SETFL, f);
    150       if (n > 0) {
    151          for (;;) {
    152             if ((cnt -= n) == 0)
    153                return 1;
    154             p += n;
    155             while ((n = read(fd, p, cnt)) <= 0) {
    156                if (!n || errno != EINTR)
    157                   return 0;
    158                if (*Signal)
    159                   sighandler(NULL);
    160             }
    161          }
    162       }
    163       if (n == 0)
    164          return 0;
    165       if (errno == EAGAIN)
    166          return -1;
    167       if (errno != EINTR)
    168          return 0;
    169       if (*Signal)
    170          sighandler(NULL);
    171    }
    172 }
    173 
    174 bool wrBytes(int fd, byte *p, int cnt) {
    175    int n;
    176 
    177    for (;;) {
    178       if ((n = write(fd, p, cnt)) >= 0) {
    179          if ((cnt -= n) == 0)
    180             return YES;
    181          p += n;
    182       }
    183       else {
    184          if (errno == EBADF || errno == EPIPE || errno == ECONNRESET)
    185             return NO;
    186          if (errno != EINTR) {
    187             if (fd == STDERR_FILENO)
    188                bye(2);
    189             writeErr("bytes");
    190          }
    191          if (*Signal)
    192             sighandler(NULL);
    193       }
    194    }
    195 }
    196 
    197 static void clsChild(int i) {
    198    if (Child[i].pid == Talking)
    199       Talking = 0;
    200    Child[i].pid = 0;
    201    close(Child[i].hear),  close(Child[i].tell);
    202    free(Child[i].buf);
    203 }
    204 
    205 static void wrChild(int i, byte *p, int cnt) {
    206    int n;
    207 
    208    if (Child[i].cnt == 0) {
    209       for (;;) {
    210          if ((n = write(Child[i].tell, p, cnt)) >= 0) {
    211             if ((cnt -= n) == 0)
    212                return;
    213             p += n;
    214          }
    215          else if (errno == EAGAIN)
    216             break;
    217          else if (errno == EPIPE || errno == ECONNRESET) {
    218             clsChild(i);
    219             return;
    220          }
    221          else if (errno != EINTR)
    222             writeErr("child");
    223       }
    224    }
    225    n = Child[i].cnt;
    226    Child[i].buf = alloc(Child[i].buf, n + sizeof(int) + cnt);
    227    *(int*)(Child[i].buf + n) = cnt;
    228    memcpy(Child[i].buf + n + sizeof(int), p, cnt);
    229    Child[i].cnt += sizeof(int) + cnt;
    230 }
    231 
    232 bool flush(outFile *p) {
    233    int n;
    234 
    235    if (p && (n = p->ix)) {
    236       p->ix = 0;
    237       return wrBytes(p->fd, p->buf, n);
    238    }
    239    return YES;
    240 }
    241 
    242 void flushAll(void) {
    243    int i;
    244 
    245    for (i = 0; i < OutFDs; ++i)
    246       flush(OutFiles[i]);
    247 }
    248 
    249 /*** Low level I/O ***/
    250 static int stdinByte(void) {
    251    inFile *p;
    252 
    253    if ((p = InFiles[STDIN_FILENO]) && (p->ix != p->cnt || (p->ix >= 0 && slow(p,NO))))
    254       return p->buf[p->ix++];
    255    if (!isatty(STDIN_FILENO))
    256       return -1;
    257    bye(0);
    258 }
    259 
    260 static int getBinary(void) {
    261    if (!InFile || InFile->ix == InFile->cnt && (InFile->ix < 0 || !slow(InFile,NO)))
    262       return -1;
    263    return InFile->buf[InFile->ix++];
    264 }
    265 
    266 static any rdNum(int cnt) {
    267    int n, i;
    268    any x;
    269    cell c1;
    270 
    271    if ((n = getBin()) < 0)
    272       return NULL;
    273    i = 0,  Push(c1, x = box(n));
    274    if (--cnt == 62) {
    275       do {
    276          do {
    277             if ((n = getBin()) < 0)
    278                return NULL;
    279             byteSym(n, &i, &x);
    280          } while (--cnt);
    281          if ((cnt = getBin()) < 0)
    282             return NULL;
    283       } while (cnt == 255);
    284    }
    285    while (--cnt >= 0) {
    286       if ((n = getBin()) < 0)
    287          return NULL;
    288       byteSym(n, &i, &x);
    289    }
    290    return Pop(c1);
    291 }
    292 
    293 any binRead(int extn) {
    294    int c;
    295    any x, y, *h;
    296    cell c1;
    297 
    298    if ((c = getBin()) < 0)
    299       return NULL;
    300    if ((c & ~3) == 0) {
    301       if (c == NIX)
    302          return Nil;
    303       if (c == BEG) {
    304          if ((x = binRead(extn)) == NULL)
    305             return NULL;
    306          Push(c1, x = cons(x,Nil));
    307          while ((y = binRead(extn)) != (any)END) {
    308             if (y == NULL) {
    309                drop(c1);
    310                return NULL;
    311             }
    312             if (y == (any)DOT) {
    313                if ((y = binRead(extn)) == NULL) {
    314                   drop(c1);
    315                   return NULL;
    316                }
    317                cdr(x) = y == (any)END? data(c1) : y;
    318                break;
    319             }
    320             x = cdr(x) = cons(y,Nil);
    321          }
    322          return Pop(c1);
    323       }
    324       return (any)(long)c;  // DOT or END
    325    }
    326    if ((y = rdNum(c / 4)) == NULL)
    327       return NULL;
    328    if ((c &= 3) == NUMBER)
    329       return y;
    330    if (c == TRANSIENT)
    331       return consStr(y);
    332    if (c == EXTERN) {
    333       if (extn)
    334          y = extOffs(extn, y);
    335       if (x = findHash(y, h = Extern + ehash(y)))
    336          return x;
    337       mkExt(x = consSym(Nil,y));
    338       *h = cons(x,*h);
    339       return x;
    340    }
    341    if (x = findHash(y, h = Intern + ihash(y)))
    342       return x;
    343    x = consSym(Nil,y);
    344    *h = cons(x,*h);
    345    return x;
    346 }
    347 
    348 static void prDig(int t, word n) {
    349    int i = 1;
    350    word m = MASK;
    351 
    352    while (n & (m <<= 8))
    353       ++i;
    354    putBin(i*4+t);
    355    while (putBin(n), --i)
    356       n >>= 8;
    357 }
    358 
    359 static int numByte(any s) {
    360    static int i;
    361    static any x;
    362    static word n;
    363 
    364    if (s)
    365       i = 0,  n = unDig(x = s);
    366    else if (n >>= 8,  (++i & sizeof(word)-1) == 0)
    367       n = unDig(x = cdr(numCell(x)));
    368    return n & 0xFF;
    369 }
    370 
    371 static void prNum(int t, any x) {
    372    int cnt, i;
    373 
    374    if (!isNum(cdr(numCell(x))))
    375       prDig(t, unDig(x));
    376    else if ((cnt = numBytes(x)) < 63) {
    377       putBin(cnt*4+t);
    378       putBin(numByte(x));
    379       while (--cnt)
    380          putBin(numByte(NULL));
    381    }
    382    else {
    383       putBin(63*4+t);
    384       putBin(numByte(x));
    385       for (i = 1; i < 63; ++i)
    386          putBin(numByte(NULL));
    387       cnt -= 63;
    388       while (cnt >= 255) {
    389          putBin(255);
    390          for (i = 0; i < 255; ++i)
    391             putBin(numByte(NULL));
    392          cnt -= 255;
    393       }
    394       putBin(cnt);
    395       while (--cnt >= 0)
    396          putBin(numByte(NULL));
    397    }
    398 }
    399 
    400 void binPrint(int extn, any x) {
    401    any y;
    402 
    403    if (isNum(x))
    404       prNum(NUMBER, x);
    405    else if (isNil(x))
    406       putBin(NIX);
    407    else if (isSym(x)) {
    408       if (!isNum(y = name(x)))
    409          binPrint(extn, y);
    410       else if (!isExt(x))
    411          prNum(hashed(x, Intern[ihash(y)])? INTERN : TRANSIENT, y);
    412       else
    413          prNum(EXTERN, extn? extOffs(-extn, y) : y);
    414    }
    415    else {
    416       putBin(BEG);
    417       if ((y = circ(x)) == NULL) {
    418          while (binPrint(extn, car(x)), !isNil(x = cdr(x))) {
    419             if (!isCell(x)) {
    420                putBin(DOT);
    421                binPrint(extn, x);
    422                return;
    423             }
    424          }
    425       }
    426       else if (y == x) {
    427          do
    428             binPrint(extn, car(x));
    429          while (y != (x = cdr(x)));
    430          putBin(DOT);
    431       }
    432       else {
    433          do
    434             binPrint(extn, car(x));
    435          while (y != (x = cdr(x)));
    436          putBin(DOT),  putBin(BEG);
    437          do
    438             binPrint(extn, car(x));
    439          while (y != (x = cdr(x)));
    440          putBin(DOT),  putBin(END);
    441       }
    442       putBin(END);
    443    }
    444 }
    445 
    446 void pr(int extn, any x) {putBin = putStdout,  binPrint(extn, x);}
    447 
    448 void prn(long n) {
    449    putBin = putStdout;
    450    prDig(NUMBER, n >= 0? n * 2 : -n * 2 + 1);
    451 }
    452 
    453 /* Family IPC */
    454 static void putTell(int c) {
    455    *PipePtr++ = c;
    456    if (PipePtr == PipeBuf + PIPE_BUF - 1)  // END
    457       err(NULL, NULL, "Tell PIPE_BUF");
    458 }
    459 
    460 static void tellBeg(ptr *pb, ptr *pp, ptr buf) {
    461    *pb = PipeBuf,  *pp = PipePtr;
    462    PipePtr = (PipeBuf = buf) + sizeof(int);
    463    *PipePtr++ = BEG;
    464 }
    465 
    466 static void prTell(any x) {putBin = putTell,  binPrint(0, x);}
    467 
    468 static void tellEnd(ptr *pb, ptr *pp, int pid) {
    469    int i, n;
    470 
    471    *PipePtr++ = END;
    472    *(int*)PipeBuf = (n = PipePtr - PipeBuf - sizeof(int)) | pid << 16;
    473    if (Tell && !wrBytes(Tell, PipeBuf, n+sizeof(int)))
    474       close(Tell),  Tell = 0;
    475    for (i = 0; i < Children; ++i)
    476       if (Child[i].pid && (!pid || pid == Child[i].pid))
    477          wrChild(i, PipeBuf+sizeof(int), n);
    478    PipePtr = *pp,  PipeBuf = *pb;
    479 }
    480 
    481 static void unsync(void) {
    482    int n = 0;
    483 
    484    if (Tell && !wrBytes(Tell, (byte*)&n, sizeof(int)))
    485       close(Tell),  Tell = 0;
    486    Sync = NO;
    487 }
    488 
    489 static any rdHear(void) {
    490    any x;
    491    inFile *iSave = InFile;
    492 
    493    InFile = InFiles[Hear];
    494    getBin = getBinary;
    495    x = binRead(0);
    496    InFile = iSave;
    497    return x;
    498 }
    499 
    500 /* Return next byte from symbol name */
    501 int symByte(any s) {
    502    static any x;
    503    static word n;
    504 
    505    if (s) {
    506       if (!isNum(x = s))
    507          return 0;
    508       n = unDig(x);
    509    }
    510    else if ((n >>= 8) == 0) {
    511       if (!isNum(cdr(numCell(x))))
    512          return 0;
    513       n = unDig(x = cdr(numCell(x)));
    514    }
    515    return n & 0xFF;
    516 }
    517 
    518 /* Return next char from symbol name */
    519 int symChar(any s) {
    520    int c = symByte(s);
    521 
    522    if (c == 0xFF)
    523       return TOP;
    524    if (c & 0x80) {
    525       if ((c & 0x20) == 0)
    526          c &= 0x1F;
    527       else
    528          c = (c & 0xF) << 6 | symByte(NULL) & 0x3F;
    529       c = c << 6 | symByte(NULL) & 0x3F;
    530    }
    531    return c;
    532 }
    533 
    534 int numBytes(any x) {
    535    int cnt;
    536    word n, m = MASK;
    537 
    538    for (cnt = 1;  isNum(cdr(numCell(x)));  cnt += WORD)
    539       x = cdr(numCell(x));
    540    for (n = unDig(x); n & (m <<= 8); ++cnt);
    541    return cnt;
    542 }
    543 
    544 /* Buffer size */
    545 int bufSize(any x) {return isNum(x = name(x))? numBytes(x)+1 : 1;}
    546 
    547 int pathSize(any x) {
    548    int c = firstByte(x);
    549 
    550    if (c != '@'  &&  (c != '+' || secondByte(x) != '@'))
    551       return bufSize(x);
    552    if (!Home)
    553       return numBytes(name(x));
    554    return strlen(Home) + numBytes(name(x));
    555 }
    556 
    557 void bufString(any x, char *p) {
    558    int c = symByte(name(x));
    559 
    560    while (*p++ = c)
    561       c = symByte(NULL);
    562 }
    563 
    564 void pathString(any x, char *p) {
    565    int c;
    566    char *h;
    567 
    568    if ((c = symByte(name(x))) == '+')
    569       *p++ = c,  c = symByte(NULL);
    570    if (c != '@')
    571       while (*p++ = c)
    572          c = symByte(NULL);
    573    else {
    574       if (h = Home)
    575          do
    576             *p++ = *h++;
    577          while (*h);
    578       while (*p++ = symByte(NULL));
    579    }
    580 }
    581 
    582 // (path 'any) -> sym
    583 any doPath(any x) {
    584    x = evSym(cdr(x));
    585    {
    586       char nm[pathSize(x)];
    587 
    588       pathString(x,nm);
    589       return mkStr(nm);
    590    }
    591 }
    592 
    593 /* Add next byte to symbol name */
    594 void byteSym(int c, int *i, any *p) {
    595    if ((*i += 8) < BITS)
    596       setDig(*p, unDig(*p) | (c & 0xFF) << *i);
    597    else
    598       *i = 0,  *p = cdr(numCell(*p)) = box(c & 0xFF);
    599 }
    600 
    601 /* Box first char of symbol name */
    602 any boxChar(int c, int *i, any *p) {
    603    *i = 0;
    604    if (c < 0x80)
    605       *p = box(c);
    606    else if (c < 0x800) {
    607       *p = box(0xC0 | c>>6 & 0x1F);
    608       byteSym(0x80 | c & 0x3F, i, p);
    609    }
    610    else if (c == TOP)
    611       *p = box(0xFF);
    612    else {
    613       *p = box(0xE0 | c>>12 & 0x0F);
    614       byteSym(0x80 | c>>6 & 0x3F, i, p);
    615       byteSym(0x80 | c & 0x3F, i, p);
    616    }
    617    return *p;
    618 }
    619 
    620 /* Add next char to symbol name */
    621 void charSym(int c, int *i, any *p) {
    622    if (c < 0x80)
    623       byteSym(c, i, p);
    624    else if (c < 0x800) {
    625       byteSym(0xC0 | c>>6 & 0x1F, i, p);
    626       byteSym(0x80 | c & 0x3F, i, p);
    627    }
    628    else if (c == TOP)
    629       byteSym(0xFF, i, p);
    630    else {
    631       byteSym(0xE0 | c>>12 & 0x0F, i, p);
    632       byteSym(0x80 | c>>6 & 0x3F, i, p);
    633       byteSym(0x80 | c & 0x3F, i, p);
    634    }
    635 }
    636 
    637 static int currFd(any ex, char *p) {
    638    if (!Env.inFrames && !Env.outFrames)
    639       err(ex, NULL, "No current fd");
    640    if (!Env.inFrames)
    641       return OutFile->fd;
    642    if (!Env.outFrames)
    643       return InFile->fd;
    644    return labs((char*)Env.outFrames - p) > labs((char*)Env.inFrames - p)?
    645       InFile->fd : OutFile->fd;
    646 }
    647 
    648 void rdOpen(any ex, any x, inFrame *f) {
    649    if (isNil(x))
    650       f->pid = 0,  f->fd = STDIN_FILENO;
    651    else if (isNum(x)) {
    652       int n = (int)unBox(x);
    653 
    654       if (n < 0) {
    655          inFrame *g = Env.inFrames;
    656 
    657          for (;;) {
    658             if (!(g = g->link))
    659                badFd(ex,x);
    660             if (!++n) {
    661                n = g->fd;
    662                break;
    663             }
    664          }
    665       }
    666       f->pid = 0,  f->fd = n;
    667       if (n >= InFDs || !InFiles[n])
    668          badFd(ex,x);
    669    }
    670    else if (isSym(x)) {
    671       char nm[pathSize(x)];
    672 
    673       f->pid = 1;
    674       pathString(x,nm);
    675       if (nm[0] == '+') {
    676          while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_RDWR, 0666)) < 0) {
    677             if (errno != EINTR)
    678                openErr(ex, nm);
    679             if (*Signal)
    680                sighandler(ex);
    681          }
    682          initInFile(f->fd, strdup(nm+1));
    683       }
    684       else {
    685          while ((f->fd = open(nm, O_RDONLY)) < 0) {
    686             if (errno != EINTR)
    687                openErr(ex, nm);
    688             if (*Signal)
    689                sighandler(ex);
    690          }
    691          initInFile(f->fd, strdup(nm));
    692       }
    693       closeOnExec(ex, f->fd);
    694    }
    695    else {
    696       any y;
    697       int i, pfd[2], ac = length(x);
    698       char *av[ac+1];
    699 
    700       if (pipe(pfd) < 0)
    701          pipeError(ex, "read open");
    702       closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]);
    703       av[0] = alloc(NULL, pathSize(y = xSym(car(x)))),  pathString(y, av[0]);
    704       for (i = 1; isCell(x = cdr(x)); ++i)
    705          av[i] = alloc(NULL, bufSize(y = xSym(car(x)))),  bufString(y, av[i]);
    706       av[ac] = NULL;
    707       if ((f->pid = fork()) == 0) {
    708          setpgid(0,0);
    709          close(pfd[0]);
    710          if (pfd[1] != STDOUT_FILENO)
    711             dup2(pfd[1], STDOUT_FILENO),  close(pfd[1]);
    712          execvp(av[0], av);
    713          execError(av[0]);
    714       }
    715       i = 0;  do
    716          free(av[i]);
    717       while (++i < ac);
    718       if (f->pid < 0)
    719          err(ex, NULL, "fork");
    720       setpgid(f->pid,0);
    721       close(pfd[1]);
    722       initInFile(f->fd = pfd[0], NULL);
    723    }
    724 }
    725 
    726 void wrOpen(any ex, any x, outFrame *f) {
    727    if (isNil(x))
    728       f->pid = 0,  f->fd = STDOUT_FILENO;
    729    else if (isNum(x)) {
    730       int n = (int)unBox(x);
    731 
    732       if (n < 0) {
    733          outFrame *g = Env.outFrames;
    734 
    735          for (;;) {
    736             if (!(g = g->link))
    737                badFd(ex,x);
    738             if (!++n) {
    739                n = g->fd;
    740                break;
    741             }
    742          }
    743       }
    744       f->pid = 0,  f->fd = n;
    745       if (n >= OutFDs || !OutFiles[n])
    746          badFd(ex,x);
    747    }
    748    else if (isSym(x)) {
    749       char nm[pathSize(x)];
    750 
    751       f->pid = 1;
    752       pathString(x,nm);
    753       if (nm[0] == '+') {
    754          while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) {
    755             if (errno != EINTR)
    756                openErr(ex, nm);
    757             if (*Signal)
    758                sighandler(ex);
    759          }
    760       }
    761       else {
    762          while ((f->fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) {
    763             if (errno != EINTR)
    764                openErr(ex, nm);
    765             if (*Signal)
    766                sighandler(ex);
    767          }
    768       }
    769       closeOnExec(ex, f->fd);
    770       initOutFile(f->fd);
    771    }
    772    else {
    773       any y;
    774       int i, pfd[2], ac = length(x);
    775       char *av[ac+1];
    776 
    777       if (pipe(pfd) < 0)
    778          pipeError(ex, "write open");
    779       closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]);
    780       av[0] = alloc(NULL, pathSize(y = xSym(car(x)))),  pathString(y, av[0]);
    781       for (i = 1; isCell(x = cdr(x)); ++i)
    782          av[i] = alloc(NULL, bufSize(y = xSym(car(x)))),  bufString(y, av[i]);
    783       av[ac] = NULL;
    784       if ((f->pid = fork()) == 0) {
    785          setpgid(0,0);
    786          close(pfd[1]);
    787          if (pfd[0] != STDIN_FILENO)
    788             dup2(pfd[0], STDIN_FILENO),  close(pfd[0]);
    789          execvp(av[0], av);
    790          execError(av[0]);
    791       }
    792       i = 0;  do
    793          free(av[i]);
    794       while (++i < ac);
    795       if (f->pid < 0)
    796          err(ex, NULL, "fork");
    797       setpgid(f->pid,0);
    798       close(pfd[0]);
    799       initOutFile(f->fd = pfd[1]);
    800    }
    801 }
    802 
    803 void erOpen(any ex, any x, errFrame *f) {
    804    int fd;
    805 
    806    NeedSym(ex,x);
    807    f->fd = dup(STDERR_FILENO);
    808    if (isNil(x))
    809       fd = dup(OutFile->fd);
    810    else {
    811       char nm[pathSize(x)];
    812 
    813       pathString(x,nm);
    814       if (nm[0] == '+') {
    815          while ((fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) {
    816             if (errno != EINTR)
    817                openErr(ex, nm);
    818             if (*Signal)
    819                sighandler(ex);
    820          }
    821       }
    822       else {
    823          while ((fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) {
    824             if (errno != EINTR)
    825                openErr(ex, nm);
    826             if (*Signal)
    827                sighandler(ex);
    828          }
    829       }
    830       closeOnExec(ex, fd);
    831    }
    832    dup2(fd, STDERR_FILENO),  close(fd);
    833 }
    834 
    835 void ctOpen(any ex, any x, ctlFrame *f) {
    836    NeedSym(ex,x);
    837    if (isNil(x)) {
    838       f->fd = -1;
    839       lockFile(currFd(ex, (char*)f), F_SETLKW, F_RDLCK);
    840    }
    841    else if (x == T) {
    842       f->fd = -1;
    843       lockFile(currFd(ex, (char*)f), F_SETLKW, F_WRLCK);
    844    }
    845    else {
    846       char nm[pathSize(x)];
    847 
    848       pathString(x,nm);
    849       if (nm[0] == '+') {
    850          while ((f->fd = open(nm+1, O_CREAT|O_RDWR, 0666)) < 0) {
    851             if (errno != EINTR)
    852                openErr(ex, nm);
    853             if (*Signal)
    854                sighandler(ex);
    855          }
    856          lockFile(f->fd, F_SETLKW, F_RDLCK);
    857       }
    858       else {
    859          while ((f->fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) {
    860             if (errno != EINTR)
    861                openErr(ex, nm);
    862             if (*Signal)
    863                sighandler(ex);
    864          }
    865          lockFile(f->fd, F_SETLKW, F_WRLCK);
    866       }
    867       closeOnExec(ex, f->fd);
    868    }
    869 }
    870 
    871 /*** Reading ***/
    872 void getStdin(void) {
    873    if (!InFile)
    874       Chr = -1;
    875    else if (InFile != InFiles[STDIN_FILENO]) {
    876       if (InFile->ix == InFile->cnt  && (InFile->ix < 0 || !slow(InFile,NO))) {
    877          Chr = -1;
    878          return;
    879       }
    880       if ((Chr = InFile->buf[InFile->ix++]) == '\n')
    881          ++InFile->line;
    882    }
    883    else if (!isCell(val(Led))) {
    884       waitFd(NULL, STDIN_FILENO, -1);
    885       Chr = stdinByte();
    886    }
    887    else {
    888       static word dig;
    889 
    890       if (!isNum(Line))
    891          dig = isNum(Line = name(run(val(Led))))? unDig(Line) : '\n';
    892       else if ((dig >>= 8) == 0)
    893          dig = isNum(Line = cdr(numCell(Line)))? unDig(Line) : '\n';
    894       Chr = dig & 0xFF;
    895    }
    896 }
    897 
    898 static void getParse(void) {
    899    if ((Chr = Env.parser->dig & 0xFF) == 0xFF)
    900       Chr = -1;
    901    else if ((Env.parser->dig >>= 8) == 0) {
    902       Env.parser->dig =
    903          isNum(Env.parser->name = cdr(numCell(Env.parser->name))) ?
    904             unDig(Env.parser->name) : Env.parser->eof;
    905    }
    906 }
    907 
    908 void pushInFiles(inFrame *f) {
    909    if (InFile)
    910       InFile->next = Chr;
    911    Chr = (InFile = InFiles[f->fd])? InFile->next : -1;
    912    f->get = Env.get,  Env.get = getStdin;
    913    f->link = Env.inFrames,  Env.inFrames = f;
    914 }
    915 
    916 void pushOutFiles(outFrame *f) {
    917    OutFile = OutFiles[f->fd];
    918    f->put = Env.put,  Env.put = putStdout;
    919    f->link = Env.outFrames,  Env.outFrames = f;
    920 }
    921 
    922 void pushErrFiles(errFrame *f) {
    923    f->link = Env.errFrames,  Env.errFrames = f;
    924 }
    925 
    926 void pushCtlFiles(ctlFrame *f) {
    927    f->link = Env.ctlFrames,  Env.ctlFrames = f;
    928 }
    929 
    930 void popInFiles(void) {
    931    if (Env.inFrames->pid) {
    932       close(Env.inFrames->fd),  closeInFile(Env.inFrames->fd);
    933       if (Env.inFrames->pid > 1)
    934          while (waitpid(Env.inFrames->pid, NULL, 0) < 0) {
    935             if (errno != EINTR)
    936                closeErr();
    937             if (*Signal)
    938                sighandler(NULL);
    939          }
    940    }
    941    else if (InFile)
    942       InFile->next = Chr;
    943    Env.get = Env.inFrames->get;
    944    Chr =
    945       (InFile = InFiles[(Env.inFrames = Env.inFrames->link)? Env.inFrames->fd : STDIN_FILENO])?
    946          InFile->next : -1;
    947 }
    948 
    949 void popOutFiles(void) {
    950    flush(OutFile);
    951    if (Env.outFrames->pid) {
    952       close(Env.outFrames->fd),  closeOutFile(Env.outFrames->fd);
    953       if (Env.outFrames->pid > 1)
    954          while (waitpid(Env.outFrames->pid, NULL, 0) < 0) {
    955             if (errno != EINTR)
    956                closeErr();
    957             if (*Signal)
    958                sighandler(NULL);
    959          }
    960    }
    961    Env.put = Env.outFrames->put;
    962    OutFile = OutFiles[(Env.outFrames = Env.outFrames->link)? Env.outFrames->fd : STDOUT_FILENO];
    963 }
    964 
    965 void popErrFiles(void) {
    966    dup2(Env.errFrames->fd, STDERR_FILENO);
    967    close(Env.errFrames->fd);
    968    Env.errFrames = Env.errFrames->link;
    969 }
    970 
    971 void popCtlFiles(void) {
    972    if (Env.ctlFrames->fd >= 0)
    973       close(Env.ctlFrames->fd);
    974    else
    975       lockFile(currFd(NULL, (char*)Env.ctlFrames), F_SETLK, F_UNLCK);
    976    Env.ctlFrames = Env.ctlFrames->link;
    977 }
    978 
    979 /* Get full char from input channel */
    980 int getChar(void) {
    981    int c;
    982 
    983    if ((c = Chr) == 0xFF)
    984       return TOP;
    985    if (c & 0x80) {
    986       Env.get();
    987       if ((c & 0x20) == 0)
    988          c &= 0x1F;
    989       else
    990          c = (c & 0xF) << 6 | Chr & 0x3F,  Env.get();
    991       if (Chr < 0)
    992          eofErr();
    993       c = c << 6 | Chr & 0x3F;
    994    }
    995    return c;
    996 }
    997 
    998 /* Skip White Space and Comments */
    999 static int skipc(int c) {
   1000    if (Chr < 0)
   1001       return Chr;
   1002    for (;;) {
   1003       while (Chr <= ' ') {
   1004          Env.get();
   1005          if (Chr < 0)
   1006             return Chr;
   1007       }
   1008       if (Chr != c)
   1009          return Chr;
   1010       Env.get();
   1011       while (Chr != '\n') {
   1012          if (Chr < 0)
   1013             return Chr;
   1014          Env.get();
   1015       }
   1016    }
   1017 }
   1018 
   1019 static void comment(void) {
   1020    Env.get();
   1021    if (Chr != '{') {
   1022       while (Chr != '\n') {
   1023          if (Chr < 0)
   1024             return;
   1025          Env.get();
   1026       }
   1027    }
   1028    else {
   1029       for (;;) {  // #{block-comment}# from Kriangkrai Soatthiyanont
   1030          Env.get();
   1031          if (Chr < 0)
   1032             return;
   1033          if (Chr == '}' && (Env.get(), Chr == '#'))
   1034             break;
   1035       }
   1036       Env.get();
   1037    }
   1038 }
   1039 
   1040 static int skip(void) {
   1041    for (;;) {
   1042       if (Chr < 0)
   1043          return Chr;
   1044       while (Chr <= ' ') {
   1045          Env.get();
   1046          if (Chr < 0)
   1047             return Chr;
   1048       }
   1049       if (Chr != '#')
   1050          return Chr;
   1051       comment();
   1052    }
   1053 }
   1054 
   1055 /* Test for escaped characters */
   1056 static bool testEsc(void) {
   1057    for (;;) {
   1058       if (Chr < 0)
   1059          return NO;
   1060       if (Chr == '^') {
   1061          Env.get();
   1062          if (Chr == '@')
   1063             badInput();
   1064          if (Chr == '?')
   1065             Chr = 127;
   1066          else
   1067             Chr &= 0x1F;
   1068          return YES;
   1069       }
   1070       if (Chr != '\\')
   1071          return YES;
   1072       if (Env.get(), Chr != '\n')
   1073          return YES;
   1074       do
   1075          Env.get();
   1076       while (Chr == ' '  ||  Chr == '\t');
   1077    }
   1078 }
   1079 
   1080 /* Try for anonymous symbol */
   1081 static any anonymous(any s) {
   1082    unsigned c;
   1083    unsigned long n;
   1084    heap *h;
   1085 
   1086    if ((c = symByte(s)) != '$')
   1087       return NULL;
   1088    n = 0;
   1089    while (c = symByte(NULL)) {
   1090       if (c < '0' || c > '9')
   1091          return NULL;
   1092       n = n * 10 + c - '0';
   1093    }
   1094    n *= sizeof(cell);
   1095    h = Heaps;
   1096    do
   1097       if ((any)n >= h->cells  &&  (any)n < h->cells + CELLS)
   1098          return symPtr((any)n);
   1099    while (h = h->next);
   1100    return NULL;
   1101 }
   1102 
   1103 /* Read an atom */
   1104 static any rdAtom(int c) {
   1105    int i;
   1106    any x, y, *h;
   1107    cell c1;
   1108 
   1109    i = 0,  Push(c1, y = box(c));
   1110    while (Chr > 0 && !strchr(Delim, Chr)) {
   1111       if (Chr == '\\')
   1112          Env.get();
   1113       byteSym(Chr, &i, &y);
   1114       Env.get();
   1115    }
   1116    y = Pop(c1);
   1117    if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N'))
   1118       return Nil;
   1119    if (x = symToNum(y, (int)unDig(val(Scl)) / 2, '.', 0))
   1120       return x;
   1121    if (x = anonymous(y))
   1122       return x;
   1123    if (x = findHash(y, h = Intern + ihash(y)))
   1124       return x;
   1125    x = consSym(Nil,y);
   1126    *h = cons(x,*h);
   1127    return x;
   1128 }
   1129 
   1130 /* Read a list */
   1131 static any rdList(void) {
   1132    any x;
   1133    cell c1;
   1134 
   1135    Env.get();
   1136    for (;;) {
   1137       if (skip() == ')') {
   1138          Env.get();
   1139          return Nil;
   1140       }
   1141       if (Chr == ']')
   1142          return Nil;
   1143       if (Chr != '~') {
   1144          Push(c1, x = cons(read0(NO),Nil));
   1145          break;
   1146       }
   1147       Env.get();
   1148       Push(c1, read0(NO));
   1149       if (isCell(x = data(c1) = EVAL(data(c1)))) {
   1150          while (isCell(cdr(x)))
   1151             x = cdr(x);
   1152          break;
   1153       }
   1154       drop(c1);
   1155    }
   1156    for (;;) {
   1157       if (skip() == ')') {
   1158          Env.get();
   1159          break;
   1160       }
   1161       if (Chr == ']')
   1162          break;
   1163       if (Chr == '.') {
   1164          Env.get();
   1165          if (strchr(Delim, Chr)) {
   1166             cdr(x) = skip()==')' || Chr==']'? data(c1) : read0(NO);
   1167             if (skip() == ')')
   1168                Env.get();
   1169             else if (Chr != ']')
   1170                err(NULL, x, "Bad dotted pair");
   1171             break;
   1172          }
   1173          x = cdr(x) = cons(rdAtom('.'), Nil);
   1174       }
   1175       else if (Chr != '~')
   1176          x = cdr(x) = cons(read0(NO), Nil);
   1177       else {
   1178          Env.get();
   1179          cdr(x) = read0(NO);
   1180          cdr(x) = EVAL(cdr(x));
   1181          while (isCell(cdr(x)))
   1182             x = cdr(x);
   1183       }
   1184    }
   1185    return Pop(c1);
   1186 }
   1187 
   1188 /* Read one expression */
   1189 static any read0(bool top) {
   1190    int i;
   1191    any x, y, *h;
   1192    cell c1;
   1193 
   1194    if (skip() < 0) {
   1195       if (top)
   1196          return Nil;
   1197       eofErr();
   1198    }
   1199    if (top && InFile)
   1200       InFile->src = InFile->line;
   1201    if (Chr == '(') {
   1202       x = rdList();
   1203       if (top  &&  Chr == ']')
   1204          Env.get();
   1205       return x;
   1206    }
   1207    if (Chr == '[') {
   1208       x = rdList();
   1209       if (Chr != ']')
   1210          err(NULL, x, "Super parentheses mismatch");
   1211       Env.get();
   1212       return x;
   1213    }
   1214    if (Chr == '\'') {
   1215       Env.get();
   1216       return cons(Quote, read0(top));
   1217    }
   1218    if (Chr == ',') {
   1219       Env.get();
   1220       x = read0(top);
   1221       if (val(Uni) != T) {
   1222          Push(c1, x);
   1223          if (isCell(y = idx(Uni, data(c1), 1)))
   1224             x = car(y);
   1225          drop(c1);
   1226       }
   1227       return x;
   1228    }
   1229    if (Chr == '`') {
   1230       Env.get();
   1231       Push(c1, read0(top));
   1232       x = EVAL(data(c1));
   1233       drop(c1);
   1234       return x;
   1235    }
   1236    if (Chr == '"') {
   1237       Env.get();
   1238       if (Chr == '"') {
   1239          Env.get();
   1240          return Nil;
   1241       }
   1242       if (!testEsc())
   1243          eofErr();
   1244       i = 0,  Push(c1, y = box(Chr));
   1245       while (Env.get(), Chr != '"') {
   1246          if (!testEsc())
   1247             eofErr();
   1248          byteSym(Chr, &i, &y);
   1249       }
   1250       y = Pop(c1),  Env.get();
   1251       if (x = findHash(y, h = Transient + ihash(y)))
   1252          return x;
   1253       x = consStr(y);
   1254       *h = cons(x,*h);
   1255       return x;
   1256    }
   1257    if (Chr == '{') {
   1258       Env.get();
   1259       if (Chr == '}') {
   1260          Env.get();
   1261          return consSym(Nil,Nil);
   1262       }
   1263       i = 0,  Push(c1, y = box(Chr));
   1264       while (Env.get(), Chr != '}') {
   1265          if (Chr < 0)
   1266             eofErr();
   1267          byteSym(Chr, &i, &y);
   1268       }
   1269       y = Pop(c1),  Env.get();
   1270       if (x = findHash(y, h = Extern + ehash(y)))
   1271          return x;
   1272       mkExt(x = consSym(Nil,y));
   1273       *h = cons(x,*h);
   1274       return x;
   1275    }
   1276    if (Chr == ')' || Chr == ']' || Chr == '~')
   1277       badInput();
   1278    if (Chr == '\\')
   1279       Env.get();
   1280    i = Chr;
   1281    Env.get();
   1282    return rdAtom(i);
   1283 }
   1284 
   1285 any read1(int end) {
   1286    if (!Chr)
   1287       Env.get();
   1288    if (Chr == end)
   1289       return Nil;
   1290    return read0(YES);
   1291 }
   1292 
   1293 /* Read one token */
   1294 any token(any x, int c) {
   1295    int i;
   1296    any y, *h;
   1297    cell c1;
   1298 
   1299    if (!Chr)
   1300       Env.get();
   1301    if (skipc(c) < 0)
   1302       return NULL;
   1303    if (Chr == '"') {
   1304       Env.get();
   1305       if (Chr == '"') {
   1306          Env.get();
   1307          return Nil;
   1308       }
   1309       if (!testEsc())
   1310          return Nil;
   1311       Push(c1, y =  cons(mkChar(Chr), Nil));
   1312       while (Env.get(), Chr != '"' && testEsc())
   1313          y = cdr(y) = cons(mkChar(Chr), Nil);
   1314       Env.get();
   1315       return Pop(c1);
   1316    }
   1317    if (Chr >= '0' && Chr <= '9') {
   1318       i = 0,  Push(c1, y = box(Chr));
   1319       while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.')
   1320          byteSym(Chr, &i, &y);
   1321       return symToNum(Pop(c1), (int)unDig(val(Scl)) / 2, '.', 0);
   1322    }
   1323    if (Chr != '+' && Chr != '-') {
   1324       char nm[bufSize(x)];
   1325 
   1326       bufString(x, nm);
   1327       if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) {
   1328          if (Chr == '\\')
   1329             Env.get();
   1330          i = 0,  Push(c1, y = box(Chr));
   1331          while (Env.get(),
   1332                Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' ||
   1333                Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) {
   1334             if (Chr == '\\')
   1335                Env.get();
   1336             byteSym(Chr, &i, &y);
   1337          }
   1338          y = Pop(c1);
   1339          if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N'))
   1340             return Nil;
   1341          if (x = findHash(y, h = Intern + ihash(y)))
   1342             return x;
   1343          x = consSym(Nil,y);
   1344          *h = cons(x,*h);
   1345          return x;
   1346       }
   1347    }
   1348    c = getChar();
   1349    Env.get();
   1350    return mkChar(c);
   1351 }
   1352 
   1353 // (read ['sym1 ['sym2]]) -> any
   1354 any doRead(any ex) {
   1355    any x;
   1356 
   1357    if (!isCell(x = cdr(ex)))
   1358       x = read1(0);
   1359    else {
   1360       cell c1;
   1361 
   1362       Push(c1, EVAL(car(x)));
   1363       NeedSym(ex, data(c1));
   1364       x = cdr(x),  x = EVAL(car(x));
   1365       NeedSym(ex,x);
   1366       x = token(data(c1), symChar(name(x))) ?: Nil;
   1367       drop(c1);
   1368    }
   1369    if (InFile == InFiles[STDIN_FILENO]  &&  Chr == '\n')
   1370       Chr = 0;
   1371    return x;
   1372 }
   1373 
   1374 static inline bool inReady(inFile *p) {
   1375    return p->ix < p->cnt;
   1376 }
   1377 
   1378 static bool isSet(int fd, fd_set *fds) {
   1379    inFile *p;
   1380 
   1381    if (fd >= InFDs || !(p = InFiles[fd]))
   1382       return FD_ISSET(fd, fds);
   1383    if (inReady(p))
   1384       return YES;
   1385    return FD_ISSET(fd, fds) && slow(p,YES) >= 0;
   1386 }
   1387 
   1388 long waitFd(any ex, int fd, long ms) {
   1389    any x, taskSave;
   1390    cell c1, c2, c3;
   1391    int i, j, m, n;
   1392    long t;
   1393    fd_set rdSet, wrSet;
   1394    struct timeval *tp, tv;
   1395 #ifndef __linux__
   1396    struct timeval tt;
   1397 #endif
   1398 
   1399    taskSave = Env.task;
   1400    Push(c1, val(At));
   1401    Save(c2);
   1402    do {
   1403       if (ms >= 0)
   1404          t = ms,  tp = &tv;
   1405       else
   1406          t = LONG_MAX,  tp = NULL;
   1407       FD_ZERO(&rdSet);
   1408       FD_ZERO(&wrSet);
   1409       m = 0;
   1410       if (fd >= 0) {
   1411          if (fd < InFDs  &&  InFiles[fd]  &&  inReady(InFiles[fd]))
   1412             tp = &tv,  t = 0;
   1413          else
   1414             FD_SET(m = fd, &rdSet);
   1415       }
   1416       for (x = data(c2) = Env.task = val(Run); isCell(x); x = cdr(x)) {
   1417          if (!memq(car(x), taskSave)) {
   1418             if (isNeg(caar(x))) {
   1419                if ((n = (int)unDig(cadar(x)) / 2) < t)
   1420                   tp = &tv,  t = n;
   1421             }
   1422             else if ((n = (int)unDig(caar(x)) / 2) != fd) {
   1423                if (n < InFDs  &&  InFiles[n]  &&  inReady(InFiles[n]))
   1424                   tp = &tv,  t = 0;
   1425                else {
   1426                   FD_SET(n, &rdSet);
   1427                   if (n > m)
   1428                      m = n;
   1429                }
   1430             }
   1431          }
   1432       }
   1433       if (Hear  &&  Hear != fd  &&  InFiles[Hear]) {
   1434          if (inReady(InFiles[Hear]))
   1435             tp = &tv,  t = 0;
   1436          else {
   1437             FD_SET(Hear, &rdSet);
   1438             if (Hear > m)
   1439                m = Hear;
   1440          }
   1441       }
   1442       if (Spkr) {
   1443          FD_SET(Spkr, &rdSet);
   1444          if (Spkr > m)
   1445             m = Spkr;
   1446          for (i = 0; i < Children; ++i) {
   1447             if (Child[i].pid) {
   1448                FD_SET(Child[i].hear, &rdSet);
   1449                if (Child[i].hear > m)
   1450                   m = Child[i].hear;
   1451                if (Child[i].cnt) {
   1452                   FD_SET(Child[i].tell, &wrSet);
   1453                   if (Child[i].tell > m)
   1454                      m = Child[i].tell;
   1455                }
   1456             }
   1457          }
   1458       }
   1459       if (tp) {
   1460          tv.tv_sec = t / 1000;
   1461          tv.tv_usec = t % 1000 * 1000;
   1462 #ifndef __linux__
   1463          gettimeofday(&tt,NULL);
   1464          t = tt.tv_sec*1000 + tt.tv_usec/1000;
   1465 #endif
   1466       }
   1467       while (select(m+1, &rdSet, &wrSet, NULL, tp) < 0) {
   1468          if (errno != EINTR) {
   1469             val(Run) = Nil;
   1470             selectErr(ex);
   1471          }
   1472          if (*Signal)
   1473             sighandler(ex);
   1474       }
   1475       if (tp) {
   1476 #ifdef __linux__
   1477          t -= tv.tv_sec*1000 + tv.tv_usec/1000;
   1478 #else
   1479          gettimeofday(&tt,NULL);
   1480          t = tt.tv_sec*1000 + tt.tv_usec/1000 - t;
   1481 #endif
   1482          if (ms > 0  &&  (ms -= t) < 0)
   1483             ms = 0;
   1484       }
   1485       if (Spkr) {
   1486          ++Env.protect;
   1487          for (i = 0; i < Children; ++i) {
   1488             if (Child[i].pid) {
   1489                if (FD_ISSET(Child[i].hear, &rdSet)) {
   1490                   if ((m = rdBytes(Child[i].hear, (byte*)&n, sizeof(int), YES)) >= 0) {
   1491                      byte buf[PIPE_BUF - sizeof(int)];
   1492 
   1493                      if (m == 0) {
   1494                         clsChild(i);
   1495                         continue;
   1496                      }
   1497                      if (n == 0) {
   1498                         if (Child[i].pid == Talking)
   1499                            Talking = 0;
   1500                      }
   1501                      else {
   1502                         pid_t pid = n >> 16;
   1503 
   1504                         n &= 0xFFFF;
   1505                         if (rdBytes(Child[i].hear, buf, n, NO)) {
   1506                            for (j = 0; j < Children; ++j)
   1507                               if (j != i && Child[j].pid && (!pid || pid == Child[j].pid))
   1508                                  wrChild(j, buf, n);
   1509                         }
   1510                         else {
   1511                            clsChild(i);
   1512                            continue;
   1513                         }
   1514                      }
   1515                   }
   1516                }
   1517                if (FD_ISSET(Child[i].tell, &wrSet)) {
   1518                   n = *(int*)(Child[i].buf + Child[i].ofs);
   1519                   if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) {
   1520                      Child[i].ofs += sizeof(int) + n;
   1521                      if (2 * Child[i].ofs >= Child[i].cnt) {
   1522                         if (Child[i].cnt -= Child[i].ofs) {
   1523                            memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt);
   1524                            Child[i].buf = alloc(Child[i].buf, Child[i].cnt);
   1525                         }
   1526                         Child[i].ofs = 0;
   1527                      }
   1528                   }
   1529                   else
   1530                      clsChild(i);
   1531                }
   1532             }
   1533          }
   1534          if (!Talking  &&  FD_ISSET(Spkr,&rdSet)  &&
   1535                   rdBytes(Spkr, (byte*)&m, sizeof(int), YES) > 0  &&
   1536                   Child[m].pid ) {
   1537             Talking = Child[m].pid;
   1538             wrChild(m, TBuf, sizeof(TBuf));
   1539          }
   1540          --Env.protect;
   1541       }
   1542       if (Hear && Hear != fd && isSet(Hear, &rdSet)) {
   1543          if ((data(c3) = rdHear()) == NULL)
   1544             close(Hear),  closeInFile(Hear),  closeOutFile(Hear),  Hear = 0;
   1545          else if (data(c3) == T)
   1546             Sync = YES;
   1547          else {
   1548             Save(c3);
   1549             evList(data(c3));
   1550             drop(c3);
   1551          }
   1552       }
   1553       for (x = data(c2); isCell(x); x = cdr(x)) {
   1554          if (!memq(car(x), taskSave)) {
   1555             if (isNeg(caar(x))) {
   1556                if ((n = (int)(unDig(cadar(x)) / 2 - t)) > 0)
   1557                   setDig(cadar(x), (long)2*n);
   1558                else {
   1559                   setDig(cadar(x), unDig(caar(x)));
   1560                   val(At) = caar(x);
   1561                   prog(cddar(x));
   1562                }
   1563             }
   1564             else if ((n = (int)unDig(caar(x)) / 2) != fd) {
   1565                if (isSet(n, &rdSet)) {
   1566                   val(At) = caar(x);
   1567                   prog(cdar(x));
   1568                }
   1569             }
   1570          }
   1571       }
   1572       if (*Signal)
   1573          sighandler(ex);
   1574    } while (ms  &&  fd >= 0 && !isSet(fd, &rdSet));
   1575    Env.task = taskSave;
   1576    val(At) = Pop(c1);
   1577    return ms;
   1578 }
   1579 
   1580 // (wait ['cnt] . prg) -> any
   1581 any doWait(any ex) {
   1582    any x, y;
   1583    long ms;
   1584 
   1585    x = cdr(ex);
   1586    ms = isNil(y = EVAL(car(x)))? -1 : xCnt(ex,y);
   1587    x = cdr(x);
   1588    while (isNil(y = prog(x)))
   1589       if (!(ms = waitFd(ex, -1, ms)))
   1590          return prog(x);
   1591    return y;
   1592 }
   1593 
   1594 // (sync) -> flg
   1595 any doSync(any ex) {
   1596    byte *p;
   1597    int n, cnt;
   1598 
   1599    if (!Mic || !Hear)
   1600       return Nil;
   1601    if (Sync)
   1602       return T;
   1603    p = (byte*)&Slot;
   1604    cnt = sizeof(int);
   1605    for (;;) {
   1606       if ((n = write(Mic, p, cnt)) >= 0) {
   1607          if ((cnt -= n) == 0)
   1608             break;
   1609          p += n;
   1610       }
   1611       else {
   1612          if (errno != EINTR)
   1613             writeErr("sync");
   1614          if (*Signal)
   1615             sighandler(ex);
   1616       }
   1617    }
   1618    Sync = NO;
   1619    do
   1620       waitFd(ex, -1, -1);
   1621    while (!Sync);
   1622    return T;
   1623 }
   1624 
   1625 // (hear 'cnt) -> cnt
   1626 any doHear(any ex) {
   1627    any x;
   1628    int fd;
   1629 
   1630    x = cdr(ex),  x = EVAL(car(x));
   1631    if ((fd = (int)xCnt(ex,x)) < 0 || fd >= InFDs || !InFiles[fd])
   1632       badFd(ex,x);
   1633    if (Hear)
   1634       close(Hear),  closeInFile(Hear),  closeOutFile(Hear);
   1635    Hear = fd;
   1636    return x;
   1637 }
   1638 
   1639 // (tell ['cnt] 'sym ['any ..]) -> any
   1640 any doTell(any x) {
   1641    any y;
   1642    int pid;
   1643    ptr pbSave, ppSave;
   1644    byte buf[PIPE_BUF];
   1645 
   1646    if (!Tell && !Children)
   1647       return Nil;
   1648    if (!isCell(x = cdr(x))) {
   1649       unsync();
   1650       return Nil;
   1651    }
   1652    pid = 0;
   1653    if (isNum(y = EVAL(car(x)))) {
   1654       pid = (int)unDig(y)/2;
   1655       x = cdr(x),  y = EVAL(car(x));
   1656    }
   1657    tellBeg(&pbSave, &ppSave, buf);
   1658    while (prTell(y), isCell(x = cdr(x)))
   1659       y = EVAL(car(x));
   1660    tellEnd(&pbSave, &ppSave, pid);
   1661    return y;
   1662 }
   1663 
   1664 // (poll 'cnt) -> cnt | NIL
   1665 any doPoll(any ex) {
   1666    any x;
   1667    int fd;
   1668    inFile *p;
   1669    fd_set fdSet;
   1670    struct timeval tv;
   1671 
   1672    x = cdr(ex),  x = EVAL(car(x));
   1673    if ((fd = (int)xCnt(ex,x)) < 0  ||  fd >= InFDs)
   1674       badFd(ex,x);
   1675    if (!(p = InFiles[fd]))
   1676       return Nil;
   1677    do {
   1678       if (inReady(p))
   1679          return x;
   1680       FD_ZERO(&fdSet);
   1681       FD_SET(fd, &fdSet);
   1682       tv.tv_sec = tv.tv_usec = 0;
   1683       while (select(fd+1, &fdSet, NULL, NULL, &tv) < 0)
   1684          if (errno != EINTR)
   1685             selectErr(ex);
   1686       if (!FD_ISSET(fd, &fdSet))
   1687          return Nil;
   1688    } while (slow(p,YES) < 0);
   1689    return x;
   1690 }
   1691 
   1692 // (key ['cnt]) -> sym
   1693 any doKey(any ex) {
   1694    any x;
   1695    int c, d;
   1696 
   1697    flushAll();
   1698    setRaw();
   1699    x = cdr(ex);
   1700    if (!waitFd(ex, STDIN_FILENO, isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x)))
   1701       return Nil;
   1702    if ((c = stdinByte()) == 0xFF)
   1703       c = TOP;
   1704    else if (c & 0x80) {
   1705       d = stdinByte();
   1706       if ((c & 0x20) == 0)
   1707          c = (c & 0x1F) << 6 | d & 0x3F;
   1708       else
   1709          c = ((c & 0xF) << 6 | d & 0x3F) << 6 | stdinByte() & 0x3F;
   1710    }
   1711    return mkChar(c);
   1712 }
   1713 
   1714 // (peek) -> sym
   1715 any doPeek(any ex __attribute__((unused))) {
   1716    if (!Chr)
   1717       Env.get();
   1718    return Chr<0? Nil : mkChar(Chr);
   1719 }
   1720 
   1721 // (char) -> sym
   1722 // (char 'cnt) -> sym
   1723 // (char T) -> sym
   1724 // (char 'sym) -> cnt
   1725 any doChar(any ex) {
   1726    any x = cdr(ex);
   1727    if (!isCell(x)) {
   1728       if (!Chr)
   1729          Env.get();
   1730       x = Chr<0? Nil : mkChar(getChar());
   1731       Env.get();
   1732       return x;
   1733    }
   1734    if (isNum(x = EVAL(car(x))))
   1735       return IsZero(x)? Nil : mkChar(unDig(x) / 2);
   1736    if (isSym(x))
   1737       return x == T? mkChar(TOP) : boxCnt(symChar(name(x)));
   1738    atomError(ex,x);
   1739 }
   1740 
   1741 // (skip ['any]) -> sym
   1742 any doSkip(any x) {
   1743    x = evSym(cdr(x));
   1744    return skipc(symChar(name(x)))<0? Nil : mkChar(Chr);
   1745 }
   1746 
   1747 // (eol) -> flg
   1748 any doEol(any ex __attribute__((unused))) {
   1749    return Chr=='\n' || Chr<=0? T : Nil;
   1750 }
   1751 
   1752 // (eof ['flg]) -> flg
   1753 any doEof(any x) {
   1754    x = cdr(x);
   1755    if (!isNil(EVAL(car(x)))) {
   1756       Chr = -1;
   1757       return T;
   1758    }
   1759    if (!Chr)
   1760       Env.get();
   1761    return Chr < 0? T : Nil;
   1762 }
   1763 
   1764 // (from 'any ..) -> sym
   1765 any doFrom(any x) {
   1766    int i, j, ac = length(x = cdr(x)), p[ac];
   1767    cell c[ac];
   1768    char *av[ac];
   1769 
   1770    if (ac == 0)
   1771       return Nil;
   1772    for (i = 0;;) {
   1773       Push(c[i], evSym(x));
   1774       av[i] = alloc(NULL, bufSize(data(c[i]))),  bufString(data(c[i]), av[i]);
   1775       p[i] = 0;
   1776       if (++i == ac)
   1777          break;
   1778       x = cdr(x);
   1779    }
   1780    if (!Chr)
   1781       Env.get();
   1782    while (Chr >= 0) {
   1783       for (i = 0; i < ac; ++i) {
   1784          for (;;) {
   1785             if (av[i][p[i]] == (byte)Chr) {
   1786                if (av[i][++p[i]])
   1787                   break;
   1788                Env.get();
   1789                x = data(c[i]);
   1790                goto done;
   1791             }
   1792             if (!p[i])
   1793                break;
   1794             for (j = 1; --p[i]; ++j)
   1795                if (memcmp(av[i], av[i]+j, p[i]) == 0)
   1796                   break;
   1797          }
   1798       }
   1799       Env.get();
   1800    }
   1801    x = Nil;
   1802 done:
   1803    i = 0;  do
   1804       free(av[i]);
   1805    while (++i < ac);
   1806    drop(c[0]);
   1807    return x;
   1808 }
   1809 
   1810 // (till 'any ['flg]) -> lst|sym
   1811 any doTill(any ex) {
   1812    any x;
   1813    int i;
   1814    cell c1;
   1815 
   1816    x = evSym(cdr(ex));
   1817    {
   1818       char buf[bufSize(x)];
   1819 
   1820       bufString(x, buf);
   1821       if (!Chr)
   1822          Env.get();
   1823       if (Chr < 0 || strchr(buf,Chr))
   1824          return Nil;
   1825       x = cddr(ex);
   1826       if (isNil(EVAL(car(x)))) {
   1827          Push(c1, x = cons(mkChar(getChar()), Nil));
   1828          while (Env.get(), Chr > 0 && !strchr(buf,Chr))
   1829             x = cdr(x) = cons(mkChar(getChar()), Nil);
   1830          return Pop(c1);
   1831       }
   1832       Push(c1, boxChar(getChar(), &i, &x));
   1833       while (Env.get(), Chr > 0 && !strchr(buf,Chr))
   1834          charSym(getChar(), &i, &x);
   1835       return consStr(Pop(c1));
   1836    }
   1837 }
   1838 
   1839 bool eol(void) {
   1840    if (Chr < 0)
   1841       return YES;
   1842    if (Chr == '\n') {
   1843       Chr = 0;
   1844       return YES;
   1845    }
   1846    if (Chr == '\r') {
   1847       Env.get();
   1848       if (Chr == '\n')
   1849          Chr = 0;
   1850       return YES;
   1851    }
   1852    return NO;
   1853 }
   1854 
   1855 // (line 'flg ['cnt ..]) -> lst|sym
   1856 any doLine(any ex) {
   1857    any x, y, z;
   1858    bool pack;
   1859    int i, n;
   1860    cell c1;
   1861 
   1862    if (!Chr)
   1863       Env.get();
   1864    if (eol())
   1865       return Nil;
   1866    x = cdr(ex);
   1867    if (pack = !isNil(EVAL(car(x))))
   1868       Push(c1, boxChar(getChar(), &i, &z));
   1869    else
   1870       Push(c1, cons(mkChar(getChar()), Nil));
   1871    if (!isCell(x = cdr(x)))
   1872       y = data(c1);
   1873    else {
   1874       if (!pack)
   1875          z = data(c1);
   1876       data(c1) = y = cons(data(c1), Nil);
   1877       for (;;) {
   1878          n = (int)evCnt(ex,x);
   1879          while (--n) {
   1880             if (Env.get(), eol()) {
   1881                if (pack)
   1882                   car(y) = consStr(car(y));
   1883                return Pop(c1);
   1884             }
   1885             if (pack)
   1886                charSym(getChar(), &i, &z);
   1887             else
   1888                z = cdr(z) = cons(mkChar(getChar()), Nil);
   1889          }
   1890          if (pack)
   1891             car(y) = consStr(car(y));
   1892          if (!isCell(x = cdr(x))) {
   1893             pack = NO;
   1894             break;
   1895          }
   1896          if (Env.get(), eol())
   1897             return Pop(c1);
   1898          y = cdr(y) = cons(
   1899             pack? boxChar(getChar(), &i, &z) : (z = cons(mkChar(getChar()), Nil)),
   1900             Nil );
   1901       }
   1902    }
   1903    for (;;) {
   1904       if (Env.get(), eol())
   1905          return pack? consStr(Pop(c1)) : Pop(c1);
   1906       if (pack)
   1907          charSym(getChar(), &i, &z);
   1908       else
   1909          y = cdr(y) = cons(mkChar(getChar()), Nil);
   1910    }
   1911 }
   1912 
   1913 // (lines 'any ..) -> cnt
   1914 any doLines(any x) {
   1915    any y;
   1916    int c, cnt = 0;
   1917    bool flg = NO;
   1918    FILE *fp;
   1919 
   1920    for (x = cdr(x); isCell(x); x = cdr(x)) {
   1921       y = evSym(x);
   1922       {
   1923          char nm[pathSize(y)];
   1924 
   1925          pathString(y, nm);
   1926          if (fp = fopen(nm, "r")) {
   1927             flg = YES;
   1928             while ((c = getc_unlocked(fp)) >= 0)
   1929                if (c == '\n')
   1930                   ++cnt;
   1931             fclose(fp);
   1932          }
   1933       }
   1934    }
   1935    return flg? boxCnt(cnt) : Nil;
   1936 }
   1937 
   1938 static any parse(any x, bool skp, any s) {
   1939    int c;
   1940    parseFrame *save, parser;
   1941    void (*getSave)(void);
   1942    cell c1;
   1943 
   1944    save = Env.parser;
   1945    Env.parser = &parser;
   1946    parser.dig = unDig(parser.name = name(x));
   1947    parser.eof = s? 0xFF : 0xFF5D0A;
   1948    getSave = Env.get,  Env.get = getParse,  c = Chr,  Chr = 0;
   1949    Push(c1, Env.parser->name);
   1950    if (skp)
   1951       getParse();
   1952    if (!s)
   1953       x = rdList();
   1954    else {
   1955       any y;
   1956       cell c2;
   1957 
   1958       if (!(x = token(s,0)))
   1959          return Nil;
   1960       Push(c2, y = cons(x,Nil));
   1961       while (x = token(s,0))
   1962          y = cdr(y) = cons(x,Nil);
   1963       x = Pop(c2);
   1964    }
   1965    drop(c1);
   1966    Chr = c,  Env.get = getSave,  Env.parser = save;
   1967    return x;
   1968 }
   1969 
   1970 static void putString(int c) {
   1971    if (StrP)
   1972       byteSym(c, &StrI, &StrP);
   1973    else
   1974       StrI = 0,  data(StrCell) = StrP = box(c & 0xFF);
   1975 }
   1976 
   1977 void begString(void) {
   1978    StrP = NULL;
   1979    Push(StrCell,Nil);
   1980    PutSave = Env.put,  Env.put = putString;
   1981 }
   1982 
   1983 any endString(void) {
   1984    Env.put = PutSave;
   1985    drop(StrCell);
   1986    return StrP? consStr(data(StrCell)) : Nil;
   1987 }
   1988 
   1989 // (any 'sym) -> any
   1990 any doAny(any ex) {
   1991    any x;
   1992 
   1993    x = cdr(ex),  x = EVAL(car(x));
   1994    NeedSym(ex,x);
   1995    if (!isNil(x)) {
   1996       int c;
   1997       parseFrame *save, parser;
   1998       void (*getSave)(void);
   1999       cell c1;
   2000 
   2001       save = Env.parser;
   2002       Env.parser = &parser;
   2003       parser.dig = unDig(parser.name = name(x));
   2004       parser.eof = 0xFF20;
   2005       getSave = Env.get,  Env.get = getParse,  c = Chr,  Chr = 0;
   2006       Push(c1, Env.parser->name);
   2007       getParse();
   2008       x = read0(YES);
   2009       drop(c1);
   2010       Chr = c,  Env.get = getSave,  Env.parser = save;
   2011    }
   2012    return x;
   2013 }
   2014 
   2015 // (sym 'any) -> sym
   2016 any doSym(any x) {
   2017    x = EVAL(cadr(x));
   2018    begString();
   2019    print(x);
   2020    return endString();
   2021 }
   2022 
   2023 // (str 'sym ['sym1]) -> lst
   2024 // (str 'lst) -> sym
   2025 any doStr(any ex) {
   2026    any x;
   2027    cell c1, c2;
   2028 
   2029    x = cdr(ex);
   2030    if (isNil(x = EVAL(car(x))))
   2031       return Nil;
   2032    if (isNum(x))
   2033       argError(ex,x);
   2034    if (isSym(x)) {
   2035       if (!isCell(cddr(ex)))
   2036          return parse(x, NO, NULL);
   2037       Push(c1, x);
   2038       Push(c2, evSym(cddr(ex)));
   2039       x = parse(x, NO, data(c2));
   2040       drop(c1);
   2041       return x;
   2042    }
   2043    begString();
   2044    while (print(car(x)), isCell(x = cdr(x)))
   2045       space();
   2046    return endString();
   2047 }
   2048 
   2049 any load(any ex, int pr, any x) {
   2050    cell c1, c2;
   2051    inFrame f;
   2052 
   2053    if (isSym(x) && firstByte(x) == '-') {
   2054       Push(c1, parse(x, YES, NULL));
   2055       x = evList(data(c1));
   2056       drop(c1);
   2057       return x;
   2058    }
   2059    rdOpen(ex, x, &f);
   2060    pushInFiles(&f);
   2061    doHide(Nil);
   2062    x = Nil;
   2063    for (;;) {
   2064       if (InFile != InFiles[STDIN_FILENO])
   2065          data(c1) = read1(0);
   2066       else {
   2067          if (pr && !Chr)
   2068             prin(run(val(Prompt))), Env.put(pr), space(), flushAll();
   2069          data(c1) = read1(isatty(STDIN_FILENO)? '\n' : 0);
   2070          while (Chr > 0) {
   2071             if (Chr == '\n') {
   2072                Chr = 0;
   2073                break;
   2074             }
   2075             if (Chr == '#')
   2076                comment();
   2077             else {
   2078                if (Chr > ' ')
   2079                   break;
   2080                Env.get();
   2081             }
   2082          }
   2083       }
   2084       if (isNil(data(c1))) {
   2085          popInFiles();
   2086          doHide(Nil);
   2087          return x;
   2088       }
   2089       Save(c1);
   2090       if (InFile != InFiles[STDIN_FILENO] || Chr || !pr)
   2091          x = EVAL(data(c1));
   2092       else {
   2093          flushAll();
   2094          Push(c2, val(At));
   2095          x = val(At) = EVAL(data(c1));
   2096          val(At3) = val(At2),  val(At2) = data(c2);
   2097          outString("-> "),  flushAll(),  print1(x),  newline();
   2098       }
   2099       drop(c1);
   2100    }
   2101 }
   2102 
   2103 // (load 'any ..) -> any
   2104 any doLoad(any ex) {
   2105    any x, y;
   2106 
   2107    x = cdr(ex);
   2108    do {
   2109       if ((y = EVAL(car(x))) != T)
   2110          y = load(ex, '>', y);
   2111       else
   2112          y = loadAll(ex);
   2113    } while (isCell(x = cdr(x)));
   2114    return y;
   2115 }
   2116 
   2117 // (in 'any . prg) -> any
   2118 any doIn(any ex) {
   2119    any x;
   2120    inFrame f;
   2121 
   2122    x = cdr(ex),  x = EVAL(car(x));
   2123    rdOpen(ex, x, &f);
   2124    pushInFiles(&f);
   2125    x = prog(cddr(ex));
   2126    popInFiles();
   2127    return x;
   2128 }
   2129 
   2130 // (out 'any . prg) -> any
   2131 any doOut(any ex) {
   2132    any x;
   2133    outFrame f;
   2134 
   2135    x = cdr(ex),  x = EVAL(car(x));
   2136    wrOpen(ex, x, &f);
   2137    pushOutFiles(&f);
   2138    x = prog(cddr(ex));
   2139    popOutFiles();
   2140    return x;
   2141 }
   2142 
   2143 // (err 'sym . prg) -> any
   2144 any doErr(any ex) {
   2145    any x;
   2146    errFrame f;
   2147 
   2148    x = cdr(ex),  x = EVAL(car(x));
   2149    erOpen(ex,x,&f);
   2150    pushErrFiles(&f);
   2151    x = prog(cddr(ex));
   2152    popErrFiles();
   2153    return x;
   2154 }
   2155 
   2156 // (ctl 'sym . prg) -> any
   2157 any doCtl(any ex) {
   2158    any x;
   2159    ctlFrame f;
   2160 
   2161    x = cdr(ex),  x = EVAL(car(x));
   2162    ctOpen(ex,x,&f);
   2163    pushCtlFiles(&f);
   2164    x = prog(cddr(ex));
   2165    popCtlFiles();
   2166    return x;
   2167 }
   2168 
   2169 // (pipe exe) -> cnt
   2170 // (pipe exe . prg) -> any
   2171 any doPipe(any ex) {
   2172    any x;
   2173    union {
   2174       inFrame in;
   2175       outFrame out;
   2176    } f;
   2177    int pfd[2];
   2178 
   2179    if (pipe(pfd) < 0)
   2180       err(ex, NULL, "Can't pipe");
   2181    closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]);
   2182    if ((f.in.pid = forkLisp(ex)) == 0) {
   2183       if (isCell(cddr(ex)))
   2184          setpgid(0,0);
   2185       close(pfd[0]);
   2186       if (pfd[1] != STDOUT_FILENO)
   2187          dup2(pfd[1], STDOUT_FILENO),  close(pfd[1]);
   2188       wrOpen(ex, Nil, &f.out);
   2189       pushOutFiles(&f.out);
   2190       OutFile->tty = NO;
   2191       val(Run) = Nil;
   2192       EVAL(cadr(ex));
   2193       bye(0);
   2194    }
   2195    close(pfd[1]);
   2196    initInFile(f.in.fd = pfd[0], NULL);
   2197    if (!isCell(cddr(ex)))
   2198       return boxCnt(pfd[0]);
   2199    setpgid(f.in.pid,0);
   2200    pushInFiles(&f.in);
   2201    x = prog(cddr(ex));
   2202    popInFiles();
   2203    return x;
   2204 }
   2205 
   2206 // (open 'any ['flg]) -> cnt | NIL
   2207 any doOpen(any ex) {
   2208    any x = evSym(cdr(ex));
   2209    char nm[pathSize(x)];
   2210    int fd;
   2211 
   2212    pathString(x, nm);
   2213    x = caddr(ex),  x = EVAL(x);
   2214    while ((fd = open(nm, isNil(x)? O_CREAT|O_RDWR : O_RDONLY, 0666)) < 0) {
   2215       if (errno != EINTR)
   2216          return Nil;
   2217       if (*Signal)
   2218          sighandler(ex);
   2219    }
   2220    closeOnExec(ex, fd);
   2221    initInFile(fd, strdup(nm)), initOutFile(fd);
   2222    return boxCnt(fd);
   2223 }
   2224 
   2225 // (close 'cnt) -> cnt | NIL
   2226 any doClose(any ex) {
   2227    any x;
   2228    int fd;
   2229 
   2230    x = cdr(ex),  x = EVAL(car(x)),  fd = (int)xCnt(ex,x);
   2231    while (close(fd)) {
   2232       if (errno != EINTR)
   2233          return Nil;
   2234       if (*Signal)
   2235          sighandler(ex);
   2236    }
   2237    closeInFile(fd),  closeOutFile(fd);
   2238    return x;
   2239 }
   2240 
   2241 // (echo ['cnt ['cnt]] | ['sym ..]) -> sym
   2242 any doEcho(any ex) {
   2243    any x, y;
   2244    long cnt;
   2245 
   2246    x = cdr(ex),  y = EVAL(car(x));
   2247    if (!Chr)
   2248       Env.get();
   2249    if (isNil(y) && !isCell(cdr(x))) {
   2250       while (Chr >= 0)
   2251          Env.put(Chr),  Env.get();
   2252       return T;
   2253    }
   2254    if (isSym(y)) {
   2255       int m, n, i, j, ac = length(x), p[ac], om, op;
   2256       cell c[ac];
   2257       char *av[ac];
   2258 
   2259       for (i = 0;;) {
   2260          Push(c[i], y);
   2261          av[i] = alloc(NULL, bufSize(y)),  bufString(y, av[i]);
   2262          p[i] = 0;
   2263          if (++i == ac)
   2264             break;
   2265          y = evSym(x = cdr(x));
   2266       }
   2267       m = -1;
   2268       while (Chr >= 0) {
   2269          if ((om = m) >= 0)
   2270             op = p[m];
   2271          for (i = 0; i < ac; ++i) {
   2272             for (;;) {
   2273                if (av[i][p[i]] == (byte)Chr) {
   2274                   if (av[i][++p[i]]) {
   2275                      if (m < 0  ||  p[i] > p[m])
   2276                         m = i;
   2277                      break;
   2278                   }
   2279                   if (om >= 0)
   2280                      for (j = 0, n = op-p[i]; j <= n; ++j)
   2281                         Env.put(av[om][j]);
   2282                   Chr = 0;
   2283                   x = data(c[i]);
   2284                   goto done;
   2285                }
   2286                if (!p[i])
   2287                   break;
   2288                for (j = 1; --p[i]; ++j)
   2289                   if (memcmp(av[i], av[i]+j, p[i]) == 0)
   2290                      break;
   2291                if (m == i)
   2292                   for (m = -1, j = 0; j < ac; ++j)
   2293                      if (p[j] && (m < 0 || p[j] > p[m]))
   2294                         m = j;
   2295             }
   2296          }
   2297          if (m < 0) {
   2298             if (om >= 0)
   2299                for (i = 0; i < op; ++i)
   2300                   Env.put(av[om][i]);
   2301             Env.put(Chr);
   2302          }
   2303          else if (om >= 0)
   2304             for (i = 0, n = op-p[m]; i <= n; ++i)
   2305                Env.put(av[om][i]);
   2306          Env.get();
   2307       }
   2308       x = Nil;
   2309    done:
   2310       i = 0;  do
   2311          free(av[i]);
   2312       while (++i < ac);
   2313       drop(c[0]);
   2314       return x;
   2315    }
   2316    if (isCell(x = cdr(x))) {
   2317       for (cnt = xCnt(ex,y), y = EVAL(car(x)); --cnt >= 0; Env.get())
   2318          if (Chr < 0)
   2319             return Nil;
   2320    }
   2321    if ((cnt = xCnt(ex,y)) > 0) {
   2322       for (;;) {
   2323          if (Chr < 0)
   2324             return Nil;
   2325          Env.put(Chr);
   2326          if (!--cnt)
   2327             break;
   2328          Env.get();
   2329       }
   2330    }
   2331    Chr = 0;
   2332    return T;
   2333 }
   2334 
   2335 /*** Printing ***/
   2336 void putStdout(int c) {
   2337    if (OutFile) {
   2338       if (OutFile->ix == BUFSIZ) {
   2339          OutFile->ix = 0;
   2340          wrBytes(OutFile->fd, OutFile->buf, BUFSIZ);
   2341       }
   2342       if ((OutFile->buf[OutFile->ix++] = c) == '\n' && OutFile->tty) {
   2343          int n = OutFile->ix;
   2344 
   2345          OutFile->ix = 0;
   2346          wrBytes(OutFile->fd, OutFile->buf, n);
   2347       }
   2348    }
   2349 }
   2350 
   2351 void newline(void) {Env.put('\n');}
   2352 void space(void) {Env.put(' ');}
   2353 
   2354 void outWord(word n) {
   2355    if (n > 9)
   2356       outWord(n / 10);
   2357    Env.put('0' + n % 10);
   2358 }
   2359 
   2360 void outString(char *s) {
   2361    while (*s)
   2362       Env.put(*s++);
   2363 }
   2364 
   2365 static void outSym(int c) {
   2366    do
   2367       Env.put(c);
   2368    while (c = symByte(NULL));
   2369 }
   2370 
   2371 void outName(any s) {outSym(symByte(name(s)));}
   2372 
   2373 void outNum(any x) {
   2374    if (isNum(cdr(numCell(x)))) {
   2375       cell c1;
   2376 
   2377       Push(c1, numToSym(x, 0, 0, 0));
   2378       outName(data(c1));
   2379       drop(c1);
   2380    }
   2381    else {
   2382       char *p, buf[BITS/2];
   2383 
   2384       sprintf(p = buf, "%ld", unBox(x));
   2385       do
   2386          Env.put(*p++);
   2387       while (*p);
   2388    }
   2389 }
   2390 
   2391 /* Print one expression */
   2392 void print(any x) {
   2393    cell c1;
   2394 
   2395    Push(c1,x);
   2396    print1(x);
   2397    drop(c1);
   2398 }
   2399 
   2400 void print1(any x) {
   2401    if (*Signal)
   2402       sighandler(NULL);
   2403    if (isNum(x))
   2404       outNum(x);
   2405    else if (isNil(x))
   2406       outString("NIL");
   2407    else if (isSym(x)) {
   2408       int c;
   2409       any y;
   2410 
   2411       if (!(c = symByte(y = name(x))))
   2412          Env.put('$'),  outWord(num(x)/sizeof(cell));
   2413       else if (isExt(x))
   2414          Env.put('{'),  outSym(c),  Env.put('}');
   2415       else if (hashed(x, Intern[ihash(y)])) {
   2416          if (unDig(y) == '.')
   2417             Env.put('\\'),  Env.put('.');
   2418          else {
   2419             do {
   2420                if (c == '\\' || strchr(Delim, c))
   2421                   Env.put('\\');
   2422                Env.put(c);
   2423             } while (c = symByte(NULL));
   2424          }
   2425       }
   2426       else {
   2427          bool tsm = isCell(val(Tsm)) && Env.put == putStdout && OutFile->tty;
   2428 
   2429          if (!tsm)
   2430             Env.put('"');
   2431          else {
   2432             outName(car(val(Tsm)));
   2433             c = symByte(y);
   2434          }
   2435          do {
   2436             if (c == '\\'  ||  c == '^'  ||  !tsm && c == '"')
   2437                Env.put('\\');
   2438             else if (c == 127)
   2439                Env.put('^'),  c = '?';
   2440             else if (c < ' ')
   2441                Env.put('^'),  c |= 0x40;
   2442             Env.put(c);
   2443          } while (c = symByte(NULL));
   2444          if (!tsm)
   2445             Env.put('"');
   2446          else
   2447             outName(cdr(val(Tsm)));
   2448       }
   2449    }
   2450    else if (car(x) == Quote  &&  x != cdr(x))
   2451       Env.put('\''),  print1(cdr(x));
   2452    else {
   2453       any y;
   2454 
   2455       Env.put('(');
   2456       if ((y = circ(x)) == NULL) {
   2457          while (print1(car(x)), !isNil(x = cdr(x))) {
   2458             if (!isCell(x)) {
   2459                outString(" . ");
   2460                print1(x);
   2461                break;
   2462             }
   2463             space();
   2464          }
   2465       }
   2466       else if (y == x) {
   2467          do
   2468             print1(car(x)),  space();
   2469          while (y != (x = cdr(x)));
   2470          Env.put('.');
   2471       }
   2472       else {
   2473          do
   2474             print1(car(x)),  space();
   2475          while (y != (x = cdr(x)));
   2476          outString(". (");
   2477          do
   2478             print1(car(x)),  space();
   2479          while (y != (x = cdr(x)));
   2480          outString(".)");
   2481       }
   2482       Env.put(')');
   2483    }
   2484 }
   2485 
   2486 void prin(any x) {
   2487    cell c1;
   2488 
   2489    Push(c1,x);
   2490    prin1(x);
   2491    drop(c1);
   2492 }
   2493 
   2494 void prin1(any x) {
   2495    if (*Signal)
   2496       sighandler(NULL);
   2497    if (!isNil(x)) {
   2498       if (isNum(x))
   2499          outNum(x);
   2500       else if (isSym(x)) {
   2501          if (isExt(x))
   2502             Env.put('{');
   2503          outName(x);
   2504          if (isExt(x))
   2505             Env.put('}');
   2506       }
   2507       else {
   2508          while (prin1(car(x)), !isNil(x = cdr(x))) {
   2509             if (!isCell(x)) {
   2510                prin1(x);
   2511                break;
   2512             }
   2513          }
   2514       }
   2515    }
   2516 }
   2517 
   2518 // (prin 'any ..) -> any
   2519 any doPrin(any x) {
   2520    any y = Nil;
   2521 
   2522    while (isCell(x = cdr(x)))
   2523       prin(y = EVAL(car(x)));
   2524    return y;
   2525 }
   2526 
   2527 // (prinl 'any ..) -> any
   2528 any doPrinl(any x) {
   2529    any y = Nil;
   2530 
   2531    while (isCell(x = cdr(x)))
   2532       prin(y = EVAL(car(x)));
   2533    newline();
   2534    return y;
   2535 }
   2536 
   2537 // (space ['cnt]) -> cnt
   2538 any doSpace(any ex) {
   2539    any x;
   2540    int n;
   2541 
   2542    if (isNil(x = EVAL(cadr(ex)))) {
   2543       Env.put(' ');
   2544       return One;
   2545    }
   2546    for (n = xCnt(ex,x); n > 0; --n)
   2547       Env.put(' ');
   2548    return x;
   2549 }
   2550 
   2551 // (print 'any ..) -> any
   2552 any doPrint(any x) {
   2553    any y;
   2554 
   2555    x = cdr(x),  print(y = EVAL(car(x)));
   2556    while (isCell(x = cdr(x)))
   2557       space(),  print(y = EVAL(car(x)));
   2558    return y;
   2559 }
   2560 
   2561 // (printsp 'any ..) -> any
   2562 any doPrintsp(any x) {
   2563    any y;
   2564 
   2565    x = cdr(x);
   2566    do
   2567       print(y = EVAL(car(x))),  space();
   2568    while (isCell(x = cdr(x)));
   2569    return y;
   2570 }
   2571 
   2572 // (println 'any ..) -> any
   2573 any doPrintln(any x) {
   2574    any y;
   2575 
   2576    x = cdr(x),  print(y = EVAL(car(x)));
   2577    while (isCell(x = cdr(x)))
   2578       space(),  print(y = EVAL(car(x)));
   2579    newline();
   2580    return y;
   2581 }
   2582 
   2583 // (flush) -> flg
   2584 any doFlush(any ex __attribute__((unused))) {
   2585    return flush(OutFile)? T : Nil;
   2586 }
   2587 
   2588 // (rewind) -> flg
   2589 any doRewind(any ex __attribute__((unused))) {
   2590    if (!OutFile)
   2591       return Nil;
   2592    OutFile->ix = 0;
   2593    return lseek(OutFile->fd, 0L, SEEK_SET) || ftruncate(OutFile->fd, 0)? Nil : T;
   2594 }
   2595 
   2596 // (ext 'cnt . prg) -> any
   2597 any doExt(any ex) {
   2598    int extn;
   2599    any x;
   2600 
   2601    x = cdr(ex);
   2602    extn = ExtN,  ExtN = (int)evCnt(ex,x);
   2603    x = prog(cddr(ex));
   2604    ExtN = extn;
   2605    return x;
   2606 }
   2607 
   2608 // (rd ['sym]) -> any
   2609 // (rd 'cnt) -> num | NIL
   2610 any doRd(any x) {
   2611    long cnt;
   2612    int n, i;
   2613    cell c1;
   2614 
   2615    x = cdr(x),  x = EVAL(car(x));
   2616    if (!isNum(x)) {
   2617       Push(c1,x);
   2618       getBin = getBinary;
   2619       x = binRead(ExtN) ?: data(c1);
   2620       drop(c1);
   2621       return x;
   2622    }
   2623    if ((cnt = unBox(x)) < 0) {
   2624       if ((n = getBinary()) < 0)
   2625          return Nil;
   2626       i = 0,  Push(c1, x = box(n));
   2627       while (++cnt) {
   2628          if ((n = getBinary()) < 0)
   2629             return Nil;
   2630          byteSym(n, &i, &x);
   2631       }
   2632       zapZero(data(c1));
   2633       digMul2(data(c1));
   2634    }
   2635    else {
   2636       if ((n = getBinary()) < 0)
   2637          return Nil;
   2638       i = 0,  Push(c1, x = box(n+n));
   2639       while (--cnt) {
   2640          if ((n = getBinary()) < 0)
   2641             return Nil;
   2642          digMul(data(c1), 256);
   2643          setDig(data(c1), unDig(data(c1)) | n+n);
   2644       }
   2645       zapZero(data(c1));
   2646    }
   2647    return Pop(c1);
   2648 }
   2649 
   2650 // (pr 'any ..) -> any
   2651 any doPr(any x) {
   2652    any y;
   2653 
   2654    x = cdr(x);
   2655    do
   2656       pr(ExtN, y = EVAL(car(x)));
   2657    while (isCell(x = cdr(x)));
   2658    return y;
   2659 }
   2660 
   2661 // (wr 'cnt ..) -> cnt
   2662 any doWr(any x) {
   2663    any y;
   2664 
   2665    x = cdr(x);
   2666    do
   2667       putStdout(unDig(y = EVAL(car(x))) / 2);
   2668    while (isCell(x = cdr(x)));
   2669    return y;
   2670 }
   2671 
   2672 /*** DB-I/O ***/
   2673 #define BLKSIZE 64  // DB block unit size
   2674 #define BLK 6
   2675 #define TAGMASK (BLKSIZE-1)
   2676 #define BLKMASK (~TAGMASK)
   2677 #define EXTERN64 65536
   2678 
   2679 static int F, Files, *BlkShift, *BlkFile, *BlkSize, *Fluse, MaxBlkSize;
   2680 static FILE *Jnl, *Log;
   2681 static adr BlkIndex, BlkLink;
   2682 static adr *Marks;
   2683 static byte *Locks, *Ptr, **Mark;
   2684 static byte *Block, *IniBlk;  // 01 00 00 00 00 00 NIL 0
   2685 
   2686 static adr getAdr(byte *p) {
   2687    return (adr)p[0] | (adr)p[1]<<8 | (adr)p[2]<<16 |
   2688                            (adr)p[3]<<24 | (adr)p[4]<<32 | (adr)p[5]<<40;
   2689 }
   2690 
   2691 static void setAdr(adr n, byte *p) {
   2692    p[0] = (byte)n,  p[1] = (byte)(n >> 8),  p[2] = (byte)(n >> 16);
   2693    p[3] = (byte)(n >> 24),  p[4] = (byte)(n >> 32),  p[5] = (byte)(n >> 40);
   2694 }
   2695 
   2696 static void dbfErr(any ex) {err(ex, NULL, "Bad DB file");}
   2697 static void dbErr(char *s) {err(NULL, NULL, "DB %s: %s", s, strerror(errno));}
   2698 static void jnlErr(any ex) {err(ex, NULL, "Bad Journal");}
   2699 static void fsyncErr(any ex, char *s) {err(ex, NULL, "%s fsync error: %s", s, strerror(errno));}
   2700 static void truncErr(any ex) {err(ex, NULL, "Log truncate error: %s", strerror(errno));}
   2701 static void ignLog(void) {fprintf(stderr, "Discarding incomplete transaction.\n");}
   2702 
   2703 any new64(adr n, any x) {
   2704    int c, i;
   2705    adr w = 0;
   2706 
   2707    do {
   2708       if ((c = n & 0x3F) > 11)
   2709          c += 5;
   2710       if (c > 42)
   2711          c += 6;
   2712       w = w << 8 | c + '0';
   2713    } while (n >>= 6);
   2714    if (i = F) {
   2715       ++i;
   2716       w = w << 8 | '-';
   2717       do {
   2718          if ((c = i & 0x3F) > 11)
   2719             c += 5;
   2720          if (c > 42)
   2721             c += 6;
   2722          w = w << 8 | c + '0';
   2723       } while (i >>= 6);
   2724    }
   2725    return hi(w)? consNum(num(w), consNum(hi(w), x)) : consNum(num(w), x);
   2726 }
   2727 
   2728 adr blk64(any x) {
   2729    int c;
   2730    adr n, w;
   2731 
   2732    F = 0;
   2733    n = 0;
   2734    if (isNum(x)) {
   2735       w = unDig(x);
   2736       if (isNum(x = cdr(numCell(x))))
   2737          w |= (adr)unDig(x) << BITS;
   2738       do {
   2739          if ((c = w & 0xFF) == '-')
   2740             F = n-1,  n = 0;
   2741          else {
   2742             if ((c -= '0') > 42)
   2743                c -= 6;
   2744             if (c > 11)
   2745                c -= 5;
   2746             n = n << 6 | c;
   2747          }
   2748       } while (w >>= 8);
   2749    }
   2750    return n;
   2751 }
   2752 
   2753 any extOffs(int offs, any x) {
   2754    int f = F;
   2755    adr n = blk64(x);
   2756 
   2757    if (offs != -EXTERN64) {
   2758       if ((F += offs) < 0)
   2759          err(NULL, NULL, "%d: Bad DB offset", F);
   2760       x = new64(n, Nil);
   2761    }
   2762    else {  // Undocumented 64-bit DB export
   2763       adr w = n & 0xFFFFF | (F & 0xFF) << 20;
   2764 
   2765       w |= ((n >>= 20) & 0xFFF) << 28;
   2766       w |= (adr)(F >> 8) << 40 | (n >> 12) << 48;
   2767       x = hi(w)? consNum(num(w), consNum(hi(w), Nil)) : consNum(num(w), Nil);
   2768    }
   2769    F = f;
   2770    return x;
   2771 }
   2772 
   2773 /* DB Record Locking */
   2774 static void dbLock(int cmd, int typ, int f, off_t len) {
   2775    struct flock fl;
   2776 
   2777    fl.l_type = typ;
   2778    fl.l_whence = SEEK_SET;
   2779    fl.l_start = 0;
   2780    fl.l_len = len;
   2781    while (fcntl(BlkFile[f], cmd, &fl) < 0  &&  typ != F_UNLCK)
   2782       if (errno != EINTR)
   2783          lockErr();
   2784 }
   2785 
   2786 static inline void rdLock(void) {
   2787    if (val(Solo) != T)
   2788       dbLock(F_SETLKW, F_RDLCK, 0, 1);
   2789 }
   2790 
   2791 static inline void wrLock(void) {
   2792    if (val(Solo) != T)
   2793       dbLock(F_SETLKW, F_WRLCK, 0, 1);
   2794 }
   2795 
   2796 static inline void rwUnlock(off_t len) {
   2797    if (val(Solo) != T) {
   2798       if (len == 0) {
   2799          int f;
   2800 
   2801          for (f = 1; f < Files; ++f)
   2802             if (Locks[f])
   2803                dbLock(F_SETLK, F_UNLCK, f, 0),  Locks[f] = 0;
   2804          val(Solo) = Zero;
   2805       }
   2806       dbLock(F_SETLK, F_UNLCK, 0, len);
   2807    }
   2808 }
   2809 
   2810 static pid_t tryLock(off_t n, off_t len) {
   2811    struct flock fl;
   2812 
   2813    for (;;) {
   2814       fl.l_type = F_WRLCK;
   2815       fl.l_whence = SEEK_SET;
   2816       fl.l_start = n;
   2817       fl.l_len = len;
   2818       if (fcntl(BlkFile[F], F_SETLK, &fl) >= 0) {
   2819          Locks[F] = 1;
   2820          if (!n)
   2821             val(Solo) = T;
   2822          else if (val(Solo) != T)
   2823             val(Solo) = Nil;
   2824          return 0;
   2825       }
   2826       if (errno != EINTR  &&  errno != EACCES  &&  errno != EAGAIN)
   2827          lockErr();
   2828       while (fcntl(BlkFile[F], F_GETLK, &fl) < 0)
   2829          if (errno != EINTR)
   2830             lockErr();
   2831       if (fl.l_type != F_UNLCK)
   2832          return fl.l_pid;
   2833    }
   2834 }
   2835 
   2836 static void blkPeek(off_t pos, void *buf, int siz) {
   2837    if (pread(BlkFile[F], buf, siz, pos) != (ssize_t)siz)
   2838       dbErr("read");
   2839 }
   2840 
   2841 static void blkPoke(off_t pos, void *buf, int siz) {
   2842    if (pwrite(BlkFile[F], buf, siz, pos) != (ssize_t)siz)
   2843       dbErr("write");
   2844    if (Jnl) {
   2845       byte a[BLK+2];
   2846 
   2847       putc_unlocked(siz == BlkSize[F]? BLKSIZE : siz, Jnl);
   2848       a[0] = (byte)F,  a[1] = (byte)(F >> 8),  setAdr(pos >> BlkShift[F], a+2);
   2849       if (fwrite(a, BLK+2, 1, Jnl) != 1 || fwrite(buf, siz, 1, Jnl) != 1)
   2850          writeErr("Journal");
   2851    }
   2852 }
   2853 
   2854 static void rdBlock(adr n) {
   2855    blkPeek((BlkIndex = n) << BlkShift[F], Block, BlkSize[F]);
   2856    BlkLink = getAdr(Block) & BLKMASK;
   2857    Ptr = Block + BLK;
   2858 }
   2859 
   2860 static void logBlock(void) {
   2861    byte a[BLK+2];
   2862 
   2863    a[0] = (byte)F,  a[1] = (byte)(F >> 8),  setAdr(BlkIndex, a+2);
   2864    if (fwrite(a, BLK+2, 1, Log) != 1 || fwrite(Block, BlkSize[F], 1, Log) != 1)
   2865       writeErr("Log");
   2866 }
   2867 
   2868 static void wrBlock(void) {blkPoke(BlkIndex << BlkShift[F], Block, BlkSize[F]);}
   2869 
   2870 static adr newBlock(void) {
   2871    adr n;
   2872    byte buf[2*BLK];
   2873 
   2874    blkPeek(0, buf, 2*BLK);  // Get Free, Next
   2875    if ((n = getAdr(buf)) && Fluse[F]) {
   2876       blkPeek(n << BlkShift[F], buf, BLK);  // Get free link
   2877       --Fluse[F];
   2878    }
   2879    else if ((n = getAdr(buf+BLK)) != 281474976710592LL)
   2880       setAdr(n + BLKSIZE, buf+BLK);  // Increment next
   2881    else
   2882       err(NULL, NULL, "DB Oversize");
   2883    blkPoke(0, buf, 2*BLK);
   2884    setAdr(0, IniBlk),  blkPoke(n << BlkShift[F], IniBlk, BlkSize[F]);
   2885    return n;
   2886 }
   2887 
   2888 any newId(any ex, int i) {
   2889    adr n;
   2890 
   2891    if ((F = i-1) >= Files)
   2892       dbfErr(ex);
   2893    if (!Log)
   2894       ++Env.protect;
   2895    wrLock();
   2896    if (Jnl)
   2897       lockFile(fileno(Jnl), F_SETLKW, F_WRLCK);
   2898    n = newBlock();
   2899    if (Jnl)
   2900       fflush(Jnl),  lockFile(fileno(Jnl), F_SETLK, F_UNLCK);
   2901    rwUnlock(1);
   2902    if (!Log)
   2903       --Env.protect;
   2904    return new64(n/BLKSIZE, At2);  // dirty
   2905 }
   2906 
   2907 bool isLife(any x) {
   2908    adr n;
   2909    byte buf[2*BLK];
   2910 
   2911    if ((n = blk64(name(x))*BLKSIZE) > 0) {
   2912       if (F < Files) {
   2913          for (x = tail1(x); !isSym(x); x = cdr(cellPtr(x)));
   2914          if (x == At || x == At2)
   2915             return YES;
   2916          if (x != At3) {
   2917             blkPeek(0, buf, 2*BLK);  // Get Next
   2918             if (n < getAdr(buf+BLK)) {
   2919                blkPeek(n << BlkShift[F], buf, BLK);
   2920                if ((buf[0] & TAGMASK) == 1)
   2921                   return YES;
   2922             }
   2923          }
   2924       }
   2925       else if (!isNil(val(Ext)))
   2926          return YES;
   2927    }
   2928    return NO;
   2929 }
   2930 
   2931 static void cleanUp(adr n) {
   2932    adr p, fr;
   2933    byte buf[BLK];
   2934 
   2935    blkPeek(0, buf, BLK),  fr = getAdr(buf);  // Get Free
   2936    setAdr(n, buf),  blkPoke(0, buf, BLK);    // Set new
   2937    for (;;) {
   2938       p = n << BlkShift[F];
   2939       blkPeek(p, buf, BLK);  // Get block link
   2940       buf[0] &= BLKMASK;  // Clear Tag
   2941       if ((n = getAdr(buf)) == 0)
   2942          break;
   2943       blkPoke(p, buf, BLK);
   2944    }
   2945    setAdr(fr, buf),  blkPoke(p, buf, BLK);  // Append old free list
   2946 }
   2947 
   2948 static int getBlock(void) {
   2949    if (Ptr == Block+BlkSize[F]) {
   2950       if (!BlkLink)
   2951          return 0;
   2952       rdBlock(BlkLink);
   2953    }
   2954    return *Ptr++;
   2955 }
   2956 
   2957 static void putBlock(int c) {
   2958    if (Ptr == Block+BlkSize[F]) {
   2959       if (BlkLink)
   2960          wrBlock(),  rdBlock(BlkLink);
   2961       else {
   2962          adr n = newBlock();
   2963          int cnt = Block[0];  // Link must be 0
   2964 
   2965          setAdr(n | cnt, Block);
   2966          wrBlock();
   2967          BlkIndex = n;
   2968          if (cnt < TAGMASK)
   2969             ++cnt;
   2970          setAdr(cnt, Block);
   2971          Ptr = Block + BLK;
   2972       }
   2973    }
   2974    *Ptr++ = (byte)c;
   2975 }
   2976 
   2977 // Test for existing transaction
   2978 static bool transaction(void) {
   2979    byte a[BLK];
   2980 
   2981    fseek(Log, 0L, SEEK_SET);
   2982    if (fread(a, 2, 1, Log) == 0) {
   2983       if (!feof(Log))
   2984          ignLog();
   2985       return NO;
   2986    }
   2987    for (;;) {
   2988       if (a[0] == 0xFF && a[1] == 0xFF)
   2989          return YES;
   2990       if ((F = a[0] | a[1]<<8) >= Files  ||
   2991             fread(a, BLK, 1, Log) != 1  ||
   2992             fseek(Log, BlkSize[F], SEEK_CUR) != 0  ||
   2993             fread(a, 2, 1, Log) != 1 ) {
   2994          ignLog();
   2995          return NO;
   2996       }
   2997    }
   2998 }
   2999 
   3000 static void restore(any ex) {
   3001    byte dirty[Files], a[BLK], buf[MaxBlkSize];
   3002 
   3003    fprintf(stderr, "Last transaction not completed: Rollback\n");
   3004    fseek(Log, 0L, SEEK_SET);
   3005    for (F = 0; F < Files; ++F)
   3006       dirty[F] = 0;
   3007    for (;;) {
   3008       if (fread(a, 2, 1, Log) == 0)
   3009          jnlErr(ex);
   3010       if (a[0] == 0xFF && a[1] == 0xFF)
   3011          break;
   3012       if ((F = a[0] | a[1]<<8) >= Files  ||
   3013             fread(a, BLK, 1, Log) != 1  ||
   3014             fread(buf, BlkSize[F], 1, Log) != 1 )
   3015          jnlErr(ex);
   3016       if (pwrite(BlkFile[F], buf, BlkSize[F], getAdr(a) << BlkShift[F]) != (ssize_t)BlkSize[F])
   3017          dbErr("write");
   3018       dirty[F] = 1;
   3019    }
   3020    for (F = 0; F < Files; ++F)
   3021       if (dirty[F] && fsync(BlkFile[F]) < 0)
   3022          fsyncErr(ex, "DB");
   3023 }
   3024 
   3025 // (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T
   3026 any doPool(any ex) {
   3027    any x;
   3028    byte buf[2*BLK+1];
   3029    cell c1, c2, c3, c4;
   3030 
   3031    x = cdr(ex),  Push(c1, evSym(x));  // db
   3032    x = cdr(x),  Push(c2, EVAL(car(x)));  // lst
   3033    NeedLst(ex,data(c2));
   3034    x = cdr(x),  Push(c3, evSym(x));  // sym2
   3035    Push(c4, evSym(cdr(x)));  // sym3
   3036    val(Solo) = Zero;
   3037    if (Files) {
   3038       doRollback(Nil);
   3039       for (F = 0; F < Files; ++F) {
   3040          if (Marks)
   3041             free(Mark[F]);
   3042          if (close(BlkFile[F]) < 0)
   3043             closeErr();
   3044       }
   3045       free(Mark), Mark = NULL, free(Marks), Marks = NULL;
   3046       Files = 0;
   3047       if (Jnl)
   3048          fclose(Jnl),  Jnl = NULL;
   3049       if (Log)
   3050          fclose(Log),  Log = NULL;
   3051    }
   3052    if (!isNil(data(c1))) {
   3053       x = data(c2);
   3054       Files = length(x) ?: 1;
   3055       BlkShift = alloc(BlkShift, Files * sizeof(int));
   3056       BlkFile = alloc(BlkFile, Files * sizeof(int));
   3057       BlkSize = alloc(BlkSize, Files * sizeof(int));
   3058       Fluse = alloc(Fluse, Files * sizeof(int));
   3059       Locks = alloc(Locks, Files),  memset(Locks, 0, Files);
   3060       MaxBlkSize = 0;
   3061       for (F = 0; F < Files; ++F) {
   3062          char nm[pathSize(data(c1)) + 8];
   3063 
   3064          pathString(data(c1), nm);
   3065          if (isCell(x))
   3066             sprintf(nm + strlen(nm), "%d", F+1);
   3067          BlkShift[F] = isNum(car(x))? (int)unDig(car(x))/2 : 2;
   3068          if ((BlkFile[F] = open(nm, O_RDWR)) >= 0) {
   3069             blkPeek(0, buf, 2*BLK+1);  // Get block shift
   3070             BlkSize[F] = BLKSIZE << (BlkShift[F] = (int)buf[2*BLK]);
   3071          }
   3072          else {
   3073             if (errno != ENOENT  ||
   3074                      (BlkFile[F] = open(nm, O_CREAT|O_EXCL|O_RDWR, 0666)) < 0) {
   3075                Files = F;
   3076                openErr(ex, nm);
   3077             }
   3078             BlkSize[F] = BLKSIZE << BlkShift[F];
   3079             setAdr(0, buf);  // Free
   3080             if (F)
   3081                setAdr(BLKSIZE, buf+BLK);  // Next
   3082             else {
   3083                byte blk[BlkSize[0]];
   3084 
   3085                setAdr(2*BLKSIZE, buf+BLK);  // Next
   3086                memset(blk, 0, BlkSize[0]);
   3087                setAdr(1, blk),  blkPoke(BlkSize[0], blk, BlkSize[0]);
   3088             }
   3089             buf[2*BLK] = (byte)BlkShift[F];
   3090             blkPoke(0, buf, 2*BLK+1);
   3091          }
   3092          closeOnExec(ex, BlkFile[F]);
   3093          if (BlkSize[F] > MaxBlkSize)
   3094             MaxBlkSize = BlkSize[F];
   3095          Fluse[F] = -1;
   3096          x = cdr(x);
   3097       }
   3098       Block = alloc(Block, MaxBlkSize);
   3099       IniBlk = alloc(IniBlk, MaxBlkSize);
   3100       memset(IniBlk, 0, MaxBlkSize);
   3101       if (!isNil(data(c3))) {
   3102          char nm[pathSize(data(c3))];
   3103 
   3104          pathString(data(c3), nm);
   3105          if (!(Jnl = fopen(nm, "a")))
   3106             openErr(ex, nm);
   3107          closeOnExec(ex, fileno(Jnl));
   3108       }
   3109       if (!isNil(data(c4))) {
   3110          char nm[pathSize(data(c4))];
   3111 
   3112          pathString(data(c4), nm);
   3113          if (!(Log = fopen(nm, "a+")))
   3114             openErr(ex, nm);
   3115          closeOnExec(ex, fileno(Log));
   3116          if (transaction())
   3117             restore(ex);
   3118          fseek(Log, 0L, SEEK_SET);
   3119          if (ftruncate(fileno(Log), 0))
   3120             truncErr(ex);
   3121       }
   3122    }
   3123    drop(c1);
   3124    return T;
   3125 }
   3126 
   3127 // (journal 'any ..) -> T
   3128 any doJournal(any ex) {
   3129    any x, y;
   3130    int siz;
   3131    FILE *fp;
   3132    byte a[BLK], buf[MaxBlkSize];
   3133 
   3134    for (x = cdr(ex); isCell(x); x = cdr(x)) {
   3135       y = evSym(x);
   3136       {
   3137          char nm[pathSize(y)];
   3138 
   3139          pathString(y, nm);
   3140          if (!(fp = fopen(nm, "r")))
   3141             openErr(ex, nm);
   3142          while ((siz = getc_unlocked(fp)) >= 0) {
   3143             if (fread(a, 2, 1, fp) != 1)
   3144                jnlErr(ex);
   3145             if ((F = a[0] | a[1]<<8) >= Files)
   3146                dbfErr(ex);
   3147             if (siz == BLKSIZE)
   3148                siz = BlkSize[F];
   3149             if (fread(a, BLK, 1, fp) != 1 || fread(buf, siz, 1, fp) != 1)
   3150                jnlErr(ex);
   3151             blkPoke(getAdr(a) << BlkShift[F], buf, siz);
   3152          }
   3153          fclose(fp);
   3154       }
   3155    }
   3156    return T;
   3157 }
   3158 
   3159 static any mkId(adr n) {
   3160    any x, y, *h;
   3161 
   3162    x = new64(n, Nil);
   3163    if (y = findHash(x, h = Extern + ehash(x)))
   3164       return y;
   3165    mkExt(y = consSym(Nil,x));
   3166    *h = cons(y,*h);
   3167    return y;
   3168 }
   3169 
   3170 // (id 'num ['num]) -> sym
   3171 // (id 'sym [NIL]) -> num
   3172 // (id 'sym T) -> (num . num)
   3173 any doId(any ex) {
   3174    any x, y;
   3175    adr n;
   3176    cell c1;
   3177 
   3178    x = cdr(ex);
   3179    if (isNum(y = EVAL(car(x)))) {
   3180       x = cdr(x);
   3181       if (isNil(x = EVAL(car(x)))) {
   3182          F = 0;
   3183          return mkId(unBoxWord2(y));
   3184       }
   3185       F = (int)unDig(y)/2 - 1;
   3186       NeedNum(ex,x);
   3187       return mkId(unBoxWord2(x));
   3188    }
   3189    NeedExt(ex,y);
   3190    n = blk64(name(y));
   3191    x = cdr(x);
   3192    if (isNil(EVAL(car(x))))
   3193       return boxWord2(n);
   3194    Push(c1, boxWord2(n));
   3195    data(c1) = cons(box((F + 1) * 2), data(c1));
   3196    return Pop(c1);
   3197 }
   3198 
   3199 // (seq 'cnt|sym1) -> sym | NIL
   3200 any doSeq(any ex) {
   3201    any x;
   3202    adr n, next;
   3203    byte buf[2*BLK];
   3204 
   3205    x = cdr(ex);
   3206    if (isNum(x = EVAL(car(x)))) {
   3207       F = (int)unDig(x)/2 - 1;
   3208       n = 0;
   3209    }
   3210    else {
   3211       NeedExt(ex,x);
   3212       n = blk64(name(x))*BLKSIZE;
   3213    }
   3214    if (F >= Files)
   3215       dbfErr(ex);
   3216    rdLock();
   3217    blkPeek(0, buf, 2*BLK),  next = getAdr(buf+BLK);  // Get Next
   3218    while ((n += BLKSIZE) < next) {
   3219       blkPeek(n << BlkShift[F], buf, BLK);
   3220       if ((buf[0] & TAGMASK) == 1) {
   3221          rwUnlock(1);
   3222          return mkId(n/BLKSIZE);
   3223       }
   3224    }
   3225    rwUnlock(1);
   3226    return Nil;
   3227 }
   3228 
   3229 // (lieu 'any) -> sym | NIL
   3230 any doLieu(any x) {
   3231    any y;
   3232 
   3233    x = cdr(x);
   3234    if (!isSym(x = EVAL(car(x))) || !isExt(x))
   3235       return Nil;
   3236    for (y = tail1(x); !isSym(y); y = cdr(cellPtr(y)));
   3237    return y == At || y == At2? x : Nil;
   3238 }
   3239 
   3240 // (lock ['sym]) -> cnt | NIL
   3241 any doLock(any ex) {
   3242    any x;
   3243    pid_t n;
   3244    off_t blk;
   3245 
   3246    x = cdr(ex);
   3247    if (isNil(x = EVAL(car(x))))
   3248       F = 0,  n = tryLock(0,0);
   3249    else {
   3250       NeedExt(ex,x);
   3251       blk = blk64(name(x));
   3252       if (F >= Files)
   3253          dbfErr(ex);
   3254       n = tryLock(blk * BlkSize[F], 1);
   3255    }
   3256    return n? boxCnt(n) : Nil;
   3257 }
   3258 
   3259 int dbSize(any ex, any x) {
   3260    int n;
   3261 
   3262    db(ex,x,1);
   3263    n = BLK + 1 + binSize(val(x));
   3264    for (x = tail1(x);  isCell(x);  x = cdr(x)) {
   3265       if (isSym(car(x)))
   3266          n += binSize(car(x)) + 2;
   3267       else
   3268          n += binSize(cdar(x)) + binSize(caar(x));
   3269    }
   3270    return n;
   3271 }
   3272 
   3273 
   3274 void db(any ex, any s, int a) {
   3275    any x, y, *p;
   3276 
   3277    if (!isNum(x = tail1(s))) {
   3278       if (a == 1)
   3279          return;
   3280       while (!isNum(x = cdr(x)));
   3281    }
   3282    p = &cdr(numCell(x));
   3283    while (isNum(*p))
   3284       p = &cdr(numCell(*p));
   3285    if (!isSym(*p))
   3286       p = &car(*p);
   3287    if (*p != At3) {  // not deleted
   3288       if (*p == At2) {  // dirty
   3289          if (a == 3) {
   3290             *p = At3;  // deleted
   3291             val(s) = Nil;
   3292             tail(s) = ext(x);
   3293          }
   3294       }
   3295       else if (isNil(*p) || a > 1) {
   3296          if (a == 3) {
   3297             *p = At3;  // deleted
   3298             val(s) = Nil;
   3299             tail(s) = ext(x);
   3300          }
   3301          else if (*p == At)
   3302             *p = At2;  // loaded -> dirty
   3303          else {  // NIL & 1 | 2
   3304             adr n;
   3305             cell c[1];
   3306 
   3307             Push(c[0],s);
   3308             n = blk64(x);
   3309             if (F < Files) {
   3310                rdLock();
   3311                rdBlock(n*BLKSIZE);
   3312                if ((Block[0] & TAGMASK) != 1)
   3313                   err(ex, s, "Bad ID");
   3314                *p  =  a == 1? At : At2;  // loaded : dirty
   3315                getBin = getBlock;
   3316                val(s) = binRead(0);
   3317                if (!isNil(y = binRead(0))) {
   3318                   tail(s) = ext(x = cons(y,x));
   3319                   if ((y = binRead(0)) != T)
   3320                      car(x) = cons(y,car(x));
   3321                   while (!isNil(y = binRead(0))) {
   3322                      cdr(x) = cons(y,cdr(x));
   3323                      if ((y = binRead(0)) != T)
   3324                         cadr(x) = cons(y,cadr(x));
   3325                      x = cdr(x);
   3326                   }
   3327                }
   3328                rwUnlock(1);
   3329             }
   3330             else {
   3331                if (!isCell(y = val(Ext)) || F < unBox(caar(y)))
   3332                   dbfErr(ex);
   3333                while (isCell(cdr(y)) && F >= unBox(caadr(y)))
   3334                   y = cdr(y);
   3335                y = apply(ex, cdar(y), NO, 1, c);  // ((Obj) ..)
   3336                *p = At;  // loaded
   3337                val(s) = car(y);
   3338                if (!isCell(y = cdr(y)))
   3339                   tail(s) = ext(x);
   3340                else {
   3341                   tail(s) = ext(y);
   3342                   while (isCell(cdr(y)))
   3343                      y = cdr(y);
   3344                   cdr(y) = x;
   3345                }
   3346             }
   3347             drop(c[0]);
   3348          }
   3349       }
   3350    }
   3351 }
   3352 
   3353 // (commit ['any] [exe1] [exe2]) -> flg
   3354 any doCommit(any ex) {
   3355    bool note;
   3356    int i, extn;
   3357    adr n;
   3358    cell c1;
   3359    any x, y, z;
   3360    ptr pbSave, ppSave;
   3361    byte dirty[Files], buf[PIPE_BUF];
   3362 
   3363    x = cdr(ex),  Push(c1, EVAL(car(x)));
   3364    if (!Log)
   3365       ++Env.protect;
   3366    wrLock();
   3367    if (Jnl)
   3368       lockFile(fileno(Jnl), F_SETLKW, F_WRLCK);
   3369    if (Log) {
   3370       for (F = 0; F < Files; ++F)
   3371          dirty[F] = 0,  Fluse[F] = 0;
   3372       for (i = 0; i < EHASH; ++i) {  // Save objects
   3373          for (x = Extern[i];  isCell(x);  x = cdr(x)) {
   3374             for (y = tail1(car(x)); isCell(y); y = cdr(y));
   3375             z = numCell(y);
   3376             while (isNum(cdr(z)))
   3377                z = numCell(cdr(z));
   3378             if (cdr(z) == At2 || cdr(z) == At3) {  // dirty or deleted
   3379                n = blk64(y);
   3380                if (F < Files) {
   3381                   rdBlock(n*BLKSIZE);
   3382                   while (logBlock(), BlkLink)
   3383                      rdBlock(BlkLink);
   3384                   dirty[F] = 1;
   3385                   if (cdr(z) != At3)
   3386                      ++Fluse[F];
   3387                }
   3388             }
   3389          }
   3390       }
   3391       for (F = 0; F < Files; ++F) {
   3392          if (i = Fluse[F]) {
   3393             rdBlock(0);                               // Save Block 0
   3394             while (logBlock(),  BlkLink && --i >= 0)  // and free list
   3395                rdBlock(BlkLink);
   3396          }
   3397       }
   3398       putc_unlocked(0xFF, Log),  putc_unlocked(0xFF, Log);
   3399       fflush(Log);
   3400       if (fsync(fileno(Log)) < 0)
   3401          fsyncErr(ex, "Transaction");
   3402    }
   3403    x = cddr(ex),  EVAL(car(x));
   3404    if (data(c1) == T)
   3405       note = NO,  extn = EXTERN64;  // Undocumented 64-bit DB export
   3406    else {
   3407       extn = 0;
   3408       if (note = !isNil(data(c1)) && (Tell || Children))
   3409          tellBeg(&pbSave, &ppSave, buf),  prTell(data(c1));
   3410    }
   3411    for (i = 0; i < EHASH; ++i) {
   3412       for (x = Extern[i];  isCell(x);  x = cdr(x)) {
   3413          for (y = tail1(car(x)); isCell(y); y = cdr(y));
   3414          z = numCell(y);
   3415          while (isNum(cdr(z)))
   3416             z = numCell(cdr(z));
   3417          if (cdr(z) == At2) {  // dirty
   3418             n = blk64(y);
   3419             if (F < Files) {
   3420                rdBlock(n*BLKSIZE);
   3421                Block[0] |= 1;  // Might be new
   3422                putBin = putBlock;
   3423                binPrint(extn, val(y = car(x)));
   3424                for (y = tail1(y);  isCell(y);  y = cdr(y)) {
   3425                   if (isCell(car(y))) {
   3426                      if (!isNil(cdar(y)))
   3427                         binPrint(extn, cdar(y)), binPrint(extn, caar(y));
   3428                   }
   3429                   else {
   3430                      if (!isNil(car(y)))
   3431                         binPrint(extn, car(y)), binPrint(extn, T);
   3432                   }
   3433                }
   3434                putBlock(NIX);
   3435                setAdr(Block[0] & TAGMASK, Block);  // Clear Link
   3436                wrBlock();
   3437                if (BlkLink)
   3438                   cleanUp(BlkLink);
   3439                cdr(z) = At;  // loaded
   3440                if (note) {
   3441                   if (PipePtr >= PipeBuf + PIPE_BUF - 12) {  // EXTERN <2+1+7> END
   3442                      tellEnd(&pbSave, &ppSave, 0);
   3443                      tellBeg(&pbSave, &ppSave, buf),  prTell(data(c1));
   3444                   }
   3445                   prTell(car(x));
   3446                }
   3447             }
   3448          }
   3449          else if (cdr(z) == At3) {  // deleted
   3450             n = blk64(y);
   3451             if (F < Files) {
   3452                cleanUp(n*BLKSIZE);
   3453                if (note) {
   3454                   if (PipePtr >= PipeBuf + PIPE_BUF - 12) {  // EXTERN <2+1+7> END
   3455                      tellEnd(&pbSave, &ppSave, 0);
   3456                      tellBeg(&pbSave, &ppSave, buf),  prTell(data(c1));
   3457                   }
   3458                   prTell(car(x));
   3459                }
   3460             }
   3461             cdr(z) = Nil;
   3462          }
   3463       }
   3464    }
   3465    if (note)
   3466       tellEnd(&pbSave, &ppSave, 0);
   3467    x = cdddr(ex),  EVAL(car(x));
   3468    if (Jnl)
   3469       fflush(Jnl),  lockFile(fileno(Jnl), F_SETLK, F_UNLCK);
   3470    if (isCell(x = val(Zap))) {
   3471       outFile f, *oSave;
   3472       char nm[pathSize(y = cdr(x))];
   3473 
   3474       pathString(y, nm);
   3475       if ((f.fd = open(nm, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0)
   3476          openErr(ex, nm);
   3477       f.ix = 0;
   3478       f.tty = NO;
   3479       putBin = putStdout;
   3480       oSave = OutFile,  OutFile = &f;
   3481       for (y = car(x); isCell(y); y = cdr(y))
   3482          binPrint(0, car(y));
   3483       flush(&f);
   3484       close(f.fd);
   3485       car(x) = Nil;
   3486       OutFile = oSave;
   3487    }
   3488    if (Log) {
   3489       for (F = 0; F < Files; ++F)
   3490          if (dirty[F] && fsync(BlkFile[F]) < 0)
   3491             fsyncErr(ex, "DB");
   3492       fseek(Log, 0L, SEEK_SET);
   3493       if (ftruncate(fileno(Log), 0))
   3494          truncErr(ex);
   3495    }
   3496    rwUnlock(0);  // Unlock all
   3497    unsync();
   3498    if (!Log)
   3499       --Env.protect;
   3500    for (F = 0; F < Files; ++F)
   3501       Fluse[F] = -1;
   3502    drop(c1);
   3503    return T;
   3504 }
   3505 
   3506 // (rollback) -> T
   3507 any doRollback(any x) {
   3508    int i;
   3509    any y, z;
   3510 
   3511    for (i = 0; i < EHASH; ++i) {
   3512       for (x = Extern[i];  isCell(x);  x = cdr(x)) {
   3513          val(y = car(x)) = Nil;
   3514          for (z = tail1(y); isCell(z); z = cdr(z));
   3515          tail(y) = ext(z);
   3516          z = numCell(z);
   3517          while (isNum(cdr(z)))
   3518             z = numCell(cdr(z));
   3519          cdr(z) = Nil;
   3520       }
   3521    }
   3522    if (isCell(x = val(Zap)))
   3523       car(x) = Nil;
   3524    rwUnlock(0);  // Unlock all
   3525    unsync();
   3526    return T;
   3527 }
   3528 
   3529 // (mark 'sym|0 ['NIL | 'T | '0]) -> flg
   3530 any doMark(any ex) {
   3531    any x, y;
   3532    adr n, m;
   3533    int b;
   3534    byte *p;
   3535 
   3536    x = cdr(ex);
   3537    if (isNum(y = EVAL(car(x)))) {
   3538       if (Marks) {
   3539          for (F = 0; F < Files; ++F)
   3540             free(Mark[F]);
   3541          free(Mark), Mark = NULL, free(Marks), Marks = NULL;
   3542       }
   3543       return Nil;
   3544    }
   3545    NeedExt(ex,y);
   3546    n = blk64(name(y));
   3547    if (F >= Files)
   3548       dbfErr(ex);
   3549    if (!Marks) {
   3550       Marks = alloc(Marks, Files * sizeof(adr));
   3551       memset(Marks, 0, Files * sizeof(adr));
   3552       Mark = alloc(Mark, Files * sizeof(byte*));
   3553       memset(Mark, 0, Files * sizeof(byte*));
   3554    }
   3555    b = 1 << (n & 7);
   3556    if ((n >>= 3) >= Marks[F]) {
   3557       m = Marks[F],  Marks[F] = n + 1;
   3558       Mark[F] = alloc(Mark[F], Marks[F]);
   3559       memset(Mark[F] + m, 0, Marks[F] - m);
   3560    }
   3561    p = Mark[F] + n;
   3562    x = cdr(x);
   3563    y = *p & b? T : Nil;  // Old value
   3564    if (!isNil(x = EVAL(car(x)))) {
   3565       if (isNum(x))
   3566          *p &= ~b;  // Clear mark
   3567       else
   3568          *p |= b;  // Set mark
   3569    }
   3570    return y;
   3571 }
   3572 
   3573 // (free 'cnt) -> (sym . lst)
   3574 any doFree(any x) {
   3575    byte buf[2*BLK];
   3576    cell c1;
   3577 
   3578    if ((F = (int)evCnt(x, cdr(x)) - 1) >= Files)
   3579       dbfErr(x);
   3580    rdLock();
   3581    blkPeek(0, buf, 2*BLK);  // Get Free, Next
   3582    Push(c1, x = cons(mkId(getAdr(buf+BLK)/BLKSIZE), Nil));  // Next
   3583    BlkLink = getAdr(buf);  // Free
   3584    while (BlkLink) {
   3585       x = cdr(x) = cons(mkId(BlkLink/BLKSIZE), Nil);
   3586       rdBlock(BlkLink);
   3587    }
   3588    rwUnlock(1);
   3589    return Pop(c1);
   3590 }
   3591 
   3592 // (dbck ['cnt] 'flg) -> any
   3593 any doDbck(any ex) {
   3594    any x, y;
   3595    bool flg;
   3596    int i;
   3597    FILE *jnl = Jnl;
   3598    adr next, p, cnt;
   3599    word2 blks, syms;
   3600    byte buf[2*BLK];
   3601    cell c1;
   3602 
   3603    F = 0;
   3604    x = cdr(ex);
   3605    if (isNum(y = EVAL(car(x)))) {
   3606       if ((F = (int)unDig(y)/2 - 1) >= Files)
   3607          dbfErr(ex);
   3608       x = cdr(x),  y = EVAL(car(x));
   3609    }
   3610    flg = !isNil(y);
   3611    cnt = BLKSIZE;
   3612    blks = syms = 0;
   3613    ++Env.protect;
   3614    wrLock();
   3615    if (Jnl)
   3616       lockFile(fileno(Jnl), F_SETLKW, F_WRLCK);
   3617    blkPeek(0, buf, 2*BLK);  // Get Free, Next
   3618    BlkLink = getAdr(buf);
   3619    next = getAdr(buf+BLK);
   3620    Jnl = NULL;
   3621    while (BlkLink) {  // Check free list
   3622       rdBlock(BlkLink);
   3623       if ((cnt += BLKSIZE) > next) {
   3624          x = mkStr("Circular free list");
   3625          goto done;
   3626       }
   3627       Block[0] |= TAGMASK,  wrBlock();  // Mark free list
   3628    }
   3629    Jnl = jnl;
   3630    for (p = BLKSIZE;  p != next;  p += BLKSIZE) {  // Check all chains
   3631       if (rdBlock(p), (Block[0] & TAGMASK) == 0) {
   3632          cnt += BLKSIZE;
   3633          memcpy(Block, buf, BLK);  // Insert into free list
   3634          wrBlock();
   3635          setAdr(p, buf),  blkPoke(0, buf, BLK);
   3636       }
   3637       else if ((Block[0] & TAGMASK) == 1) {
   3638          ++blks, ++syms;
   3639          cnt += BLKSIZE;
   3640          for (i = 2;  BlkLink;  cnt += BLKSIZE) {
   3641             ++blks;
   3642             rdBlock(BlkLink);
   3643             if ((Block[0] & TAGMASK) != i) {
   3644                x = mkStr("Bad chain");
   3645                goto done;
   3646             }
   3647             if (i < TAGMASK)
   3648                ++i;
   3649          }
   3650       }
   3651    }
   3652    BlkLink = getAdr(buf);  // Unmark free list
   3653    Jnl = NULL;
   3654    while (BlkLink) {
   3655       rdBlock(BlkLink);
   3656       if (Block[0] & TAGMASK)
   3657          Block[0] &= BLKMASK,  wrBlock();
   3658    }
   3659    if (cnt != next)
   3660       x = mkStr("Bad count");
   3661    else if (!flg)
   3662       x = Nil;
   3663    else {
   3664       Push(c1, boxWord2(syms));
   3665       data(c1) = cons(boxWord2(blks), data(c1));
   3666       x = Pop(c1);
   3667    }
   3668 done:
   3669    if (Jnl = jnl)
   3670       fflush(Jnl),  lockFile(fileno(Jnl), F_SETLK, F_UNLCK);
   3671    rwUnlock(1);
   3672    --Env.protect;
   3673    return x;
   3674 }
	picolisp Unnamed repository; edit this file to name it for gitweb.
	git clone https://logand.com/git/picolisp.git/
	Log \| Files \| Refs \| README \| LICENSE