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

main.c (30419B)
      1 /* 23jun13abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 #include "vers.h"
      7 
      8 #ifdef __CYGWIN__
      9 #define O_ASYNC FASYNC
     10 #endif
     11 
     12 /* Globals */
     13 int Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN;
     14 char **AV, *AV0, *Home;
     15 child *Child;
     16 heap *Heaps;
     17 cell *Avail;
     18 stkEnv Env;
     19 catchFrame *CatchPtr;
     20 struct termios OrgTermio, *Termio;
     21 int InFDs, OutFDs;
     22 inFile *InFile, **InFiles;
     23 outFile *OutFile, **OutFiles;
     24 int (*getBin)(void);
     25 void (*putBin)(int);
     26 any TheKey, TheCls, Thrown;
     27 any Alarm, Sigio, Line, Zero, One;
     28 any Intern[IHASH], Transient[IHASH], Extern[EHASH];
     29 any ApplyArgs, ApplyBody, DbVal, DbTail;
     30 any Nil, DB, Meth, Quote, T;
     31 any Solo, PPid, Pid, At, At2, At3, This, Prompt, Dbg, Zap, Ext, Scl, Class;
     32 any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye;
     33 bool Break;
     34 sig_atomic_t Signal[NSIG];
     35 
     36 static int TtyPid;
     37 static word2 USec;
     38 static struct timeval Tv;
     39 static bool Tio, Jam;
     40 static jmp_buf ErrRst;
     41 static void finish(int) __attribute__ ((noreturn));
     42 static struct rlimit ULim = {RLIM_INFINITY, RLIM_INFINITY};
     43 
     44 
     45 /*** System ***/
     46 static void finish(int n) {
     47    setCooked();
     48    exit(n);
     49 }
     50 
     51 void giveup(char *msg) {
     52    fprintf(stderr, "%d %s\n", (int)getpid(), msg);
     53    finish(1);
     54 }
     55 
     56 void bye(int n) {
     57    static bool flg;
     58 
     59    if (!flg) {
     60       flg = YES;
     61       unwind(NULL);
     62       prog(val(Bye));
     63    }
     64    flushAll();
     65    finish(n);
     66 }
     67 
     68 void execError(char *s) {
     69    fprintf(stderr, "%s: Can't exec\n", s);
     70    exit(127);
     71 }
     72 
     73 /* Install interrupting signal */
     74 static void iSignal(int n, void (*foo)(int)) {
     75    struct sigaction act, old;
     76 
     77    act.sa_handler = foo;
     78    sigemptyset(&act.sa_mask);
     79    act.sa_flags = 0;
     80    sigaction(n, &act, &old);
     81 }
     82 
     83 /* Signal handler */
     84 void sighandler(any ex) {
     85    int i;
     86    bool flg;
     87 
     88    if (!Env.protect) {
     89       Env.protect = 1;
     90       do {
     91          if (Signal[SIGIO]) {
     92             --Signal[0], --Signal[SIGIO];
     93             run(Sigio);
     94          }
     95          else if (Signal[SIGUSR1]) {
     96             --Signal[0], --Signal[SIGUSR1];
     97             run(val(Sig1));
     98          }
     99          else if (Signal[SIGUSR2]) {
    100             --Signal[0], --Signal[SIGUSR2];
    101             run(val(Sig2));
    102          }
    103          else if (Signal[SIGALRM]) {
    104             --Signal[0], --Signal[SIGALRM];
    105             run(Alarm);
    106          }
    107          else if (Signal[SIGINT]) {
    108             --Signal[0], --Signal[SIGINT];
    109             if (Repl < 2)
    110                brkLoad(ex ?: Nil);
    111          }
    112          else if (Signal[SIGHUP]) {
    113             --Signal[0], --Signal[SIGHUP];
    114             run(val(Hup));
    115          }
    116          else if (Signal[SIGTERM]) {
    117             for (flg = NO, i = 0; i < Children; ++i)
    118                if (Child[i].pid  &&  kill(Child[i].pid, SIGTERM) == 0)
    119                   flg = YES;
    120             if (flg)
    121                break;
    122             Signal[0] = 0,  bye(0);
    123          }
    124       } while (*Signal);
    125       Env.protect = 0;
    126    }
    127 }
    128 
    129 static void sig(int n) {
    130    if (TtyPid)
    131       kill(TtyPid, n);
    132    else
    133       ++Signal[n], ++Signal[0];
    134 }
    135 
    136 static void sigTerm(int n) {
    137    if (TtyPid)
    138       kill(TtyPid, n);
    139    else
    140       ++Signal[SIGTERM], ++Signal[0];
    141 }
    142 
    143 static void sigChld(int n __attribute__((unused))) {
    144    int e, stat;
    145    pid_t pid;
    146 
    147    e = errno;
    148    while ((pid = waitpid(0, &stat, WNOHANG)) > 0)
    149       if (WIFSIGNALED(stat))
    150          fprintf(stderr, "%d SIG-%d\n", (int)pid, WTERMSIG(stat));
    151    errno = e;
    152 }
    153 
    154 static void tcSet(struct termios *p) {
    155    if (Termio)
    156       while (tcsetattr(STDIN_FILENO, TCSADRAIN, p)  &&  errno == EINTR);
    157 }
    158 
    159 static void sigTermStop(int n __attribute__((unused))) {
    160    sigset_t mask;
    161 
    162    tcSet(&OrgTermio);
    163    sigemptyset(&mask);
    164    sigaddset(&mask, SIGTSTP);
    165    sigprocmask(SIG_UNBLOCK, &mask, NULL);
    166    signal(SIGTSTP, SIG_DFL),  raise(SIGTSTP),  signal(SIGTSTP, sigTermStop);
    167    tcSet(Termio);
    168 }
    169 
    170 void setRaw(void) {
    171    if (Tio && !Termio) {
    172       *(Termio = malloc(sizeof(struct termios))) = OrgTermio;
    173       Termio->c_iflag = 0;
    174       Termio->c_lflag = ISIG;
    175       Termio->c_cc[VMIN] = 1;
    176       Termio->c_cc[VTIME] = 0;
    177       tcSet(Termio);
    178       if (signal(SIGTSTP,SIG_IGN) == SIG_DFL)
    179          signal(SIGTSTP, sigTermStop);
    180    }
    181 }
    182 
    183 void setCooked(void) {
    184    tcSet(&OrgTermio);
    185    free(Termio),  Termio = NULL;
    186 }
    187 
    188 // (raw ['flg]) -> flg
    189 any doRaw(any x) {
    190    if (!isCell(x = cdr(x)))
    191       return Termio? T : Nil;
    192    if (isNil(EVAL(car(x)))) {
    193       setCooked();
    194       return Nil;
    195    }
    196    setRaw();
    197    return T;
    198 }
    199 
    200 // (alarm 'cnt . prg) -> cnt
    201 any doAlarm(any x) {
    202    int n = alarm((int)evCnt(x,cdr(x)));
    203    Alarm = cddr(x);
    204    return boxCnt(n);
    205 }
    206 
    207 // (sigio 'cnt . prg) -> cnt
    208 any doSigio(any ex) {
    209    any x = EVAL(cadr(ex));
    210    int fd = (int)xCnt(ex,x);
    211 
    212    Sigio = cddr(ex);
    213    fcntl(fd, F_SETOWN, unBox(val(Pid)));
    214    fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | O_NONBLOCK|O_ASYNC);
    215    return x;
    216 }
    217 
    218 // (protect . prg) -> any
    219 any doProtect(any x) {
    220    ++Env.protect;
    221    x = prog(cdr(x));
    222    --Env.protect;
    223    return x;
    224 }
    225 
    226 /* Allocate memory */
    227 void *alloc(void *p, size_t siz) {
    228    if (!(p = realloc(p,siz)))
    229       giveup("No memory");
    230    return p;
    231 }
    232 
    233 /* Allocate cell heap */
    234 void heapAlloc(void) {
    235    heap *h;
    236    cell *p;
    237 
    238    h = (heap*)alloc(NULL, sizeof(heap));
    239    h->next = Heaps,  Heaps = h;
    240    p = h->cells + CELLS-1;
    241    do
    242       Free(p);
    243    while (--p >= h->cells);
    244 }
    245 
    246 // (heap 'flg) -> cnt
    247 any doHeap(any x) {
    248    long n = 0;
    249 
    250    x = cdr(x);
    251    if (isNil(EVAL(car(x)))) {
    252       heap *h = Heaps;
    253       do
    254          ++n;
    255       while (h = h->next);
    256       return boxCnt(n);
    257    }
    258    for (x = Avail;  x;  x = car(x))
    259       ++n;
    260    return boxCnt(n / CELLS);
    261 }
    262 
    263 // (adr 'var) -> num
    264 // (adr 'num) -> var
    265 any doAdr(any x) {
    266    x = cdr(x);
    267    if (isNum(x = EVAL(car(x))))
    268       return (any)(unDig(x) * WORD);
    269    return box(num(x) / WORD);
    270 }
    271 
    272 // (env ['lst] | ['sym 'val] ..) -> lst
    273 any doEnv(any x) {
    274    int i;
    275    bindFrame *p;
    276    cell c1, c2;
    277 
    278    Push(c1, Nil);
    279    if (!isCell(x = cdr(x))) {
    280       for (p = Break? Env.bind->link : Env.bind;  p;  p = p->link) {
    281          if (p->i == 0) {
    282             for (i = p->cnt;  --i >= 0;) {
    283                for (x = data(c1); ; x = cdr(x)) {
    284                   if (!isCell(x)) {
    285                      data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1));
    286                      break;
    287                   }
    288                   if (caar(x) == p->bnd[i].sym)
    289                      break;
    290                }
    291             }
    292          }
    293       }
    294    }
    295    else {
    296       do {
    297          Push(c2, EVAL(car(x)));
    298          if (isCell(data(c2))) {
    299             do
    300                data(c1) = cons(
    301                   isCell(car(data(c2)))?
    302                      cons(caar(data(c2)), cdar(data(c2))) :
    303                      cons(car(data(c2)), val(car(data(c2)))),
    304                   data(c1) );
    305             while (isCell(data(c2) = cdr(data(c2))));
    306          }
    307          else if (!isNil(data(c2))) {
    308             x = cdr(x);
    309             data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1));
    310          }
    311          drop(c2);
    312       }
    313       while (isCell(x = cdr(x)));
    314    }
    315    return Pop(c1);
    316 }
    317 
    318 // (up [cnt] sym ['val]) -> any
    319 any doUp(any x) {
    320    any y, *val;
    321    int cnt, i;
    322    bindFrame *p;
    323 
    324    x = cdr(x);
    325    if (!isNum(y = car(x)))
    326       cnt = 1;
    327    else
    328       cnt = (int)unBox(y),  x = cdr(x),  y = car(x);
    329    for (p = Break? Env.bind->link : Env.bind, val = &val(y);  p;  p = p->link) {
    330       if (p->i <= 0) {
    331          for (i = 0;  i < p->cnt;  ++i)
    332             if (p->bnd[i].sym == y) {
    333                if (!--cnt) {
    334                   if (isCell(x = cdr(x)))
    335                      return p->bnd[i].val = EVAL(car(x));
    336                   return p->bnd[i].val;
    337                }
    338                val = &p->bnd[i].val;
    339             }
    340       }
    341    }
    342    if (isCell(x = cdr(x)))
    343       return *val = EVAL(car(x));
    344    return *val;
    345 }
    346 
    347 // (sys 'any ['any]) -> sym
    348 any doSys(any x) {
    349    any y;
    350 
    351    y = evSym(x = cdr(x));
    352    {
    353       char nm[bufSize(y)];
    354 
    355       bufString(y,nm);
    356       if (!isCell(x = cdr(x)))
    357          return mkStr(getenv(nm));
    358       y = evSym(x);
    359       {
    360          char val[bufSize(y)];
    361 
    362          bufString(y,val);
    363          return setenv(nm,val,1)? Nil : y;
    364       }
    365    }
    366 }
    367 
    368 /*** Primitives ***/
    369 any circ(any x) {
    370    any y = x;
    371 
    372    for (;;) {
    373       *(word*)&car(y) |= 1;
    374       if (!isCell(y = cdr(y))) {
    375          do
    376             *(word*)&car(x) &= ~1;
    377          while (isCell(x = cdr(x)));
    378          return NULL;
    379       }
    380       if (num(car(y)) & 1) {
    381          while (x != y)
    382             *(word*)&car(x) &= ~1,  x = cdr(x);
    383          do
    384             *(word*)&car(x) &= ~1;
    385          while (y != (x = cdr(x)));
    386          return y;
    387       }
    388    }
    389 }
    390 
    391 /* Comparisons */
    392 bool equal(any x, any y) {
    393    any a, b;
    394    bool res;
    395 
    396    for (;;) {
    397       if (x == y)
    398          return YES;
    399       if (isNum(x)) {
    400          if (!isNum(y)  ||  unDig(x) != unDig(y))
    401             return NO;
    402          x = cdr(numCell(x)),  y = cdr(numCell(y));
    403          continue;
    404       }
    405       if (isSym(x)) {
    406          if (!isSym(y)  || !isNum(x = name(x))  ||  !isNum(y = name(y)))
    407             return NO;
    408          continue;
    409       }
    410       if (!isCell(y))
    411          return NO;
    412       a = x, b = y;
    413       res = NO;
    414       for (;;) {
    415          if (!equal(car(x), (any)(num(car(y)) & ~1)))
    416             break;
    417          if (!isCell(cdr(x))) {
    418             res = equal(cdr(x), cdr(y));
    419             break;
    420          }
    421          if (!isCell(cdr(y)))
    422             break;
    423          *(word*)&car(x) |= 1,  x = cdr(x),  y = cdr(y);
    424          if (num(car(x)) & 1) {
    425             for (;;) {
    426                if (a == x) {
    427                   if (b == y) {
    428                      for (;;) {
    429                         a = cdr(a);
    430                         if ((b = cdr(b)) == y) {
    431                            res = a == x;
    432                            break;
    433                         }
    434                         if (a == x) {
    435                            res = YES;
    436                            break;
    437                         }
    438                      }
    439                   }
    440                   break;
    441                }
    442                if (b == y) {
    443                   res = NO;
    444                   break;
    445                }
    446                *(word*)&car(a) &= ~1,  a = cdr(a),  b = cdr(b);
    447             }
    448             do
    449                *(word*)&car(a) &= ~1,  a = cdr(a);
    450             while (a != x);
    451             return res;
    452          }
    453       }
    454       while (a != x)
    455          *(word*)&car(a) &= ~1,  a = cdr(a);
    456       return res;
    457    }
    458 }
    459 
    460 int compare(any x, any y) {
    461    any a, b;
    462 
    463    if (x == y)
    464       return 0;
    465    if (isNil(x))
    466       return -1;
    467    if (x == T)
    468       return +1;
    469    if (isNum(x)) {
    470       if (!isNum(y))
    471          return isNil(y)? +1 : -1;
    472       return bigCompare(x,y);
    473    }
    474    if (isSym(x)) {
    475       int b1, b2;
    476       word n1, n2;
    477 
    478       if (isNum(y) || isNil(y))
    479          return +1;
    480       if (isCell(y) || y == T)
    481          return -1;
    482       if (!isNum(a = name(x)))
    483          return !isNum(name(y))? (long)x - (long)y : -1;
    484       if (!isNum(b = name(y)))
    485          return +1;
    486       n1 = unDig(a), n2 = unDig(b);
    487       for (;;) {
    488          if ((b1 = n1 & 0xFF) != (b2 = n2 & 0xFF))
    489             return b1 - b2;
    490          if ((n1 >>= 8) == 0) {
    491             if ((n2 >>= 8) != 0)
    492                return -1;
    493             if (!isNum(a = cdr(numCell(a))))
    494                return !isNum(b = cdr(numCell(b)))? 0 : -1;
    495             if (!isNum(b = cdr(numCell(b))))
    496                return +1;
    497             n1 = unDig(a), n2 = unDig(b);
    498          }
    499          else if ((n2 >>= 8) == 0)
    500             return +1;
    501       }
    502    }
    503    if (!isCell(y))
    504       return y == T? -1 : +1;
    505    a = x, b = y;
    506    for (;;) {
    507       int n;
    508 
    509       if (n = compare(car(x),car(y)))
    510          return n;
    511       if (!isCell(x = cdr(x)))
    512          return compare(x, cdr(y));
    513       if (!isCell(y = cdr(y)))
    514          return y == T? -1 : +1;
    515       if (x == a && y == b)
    516          return 0;
    517    }
    518 }
    519 
    520 int binSize(any x) {
    521    if (isNum(x)) {
    522       int n = numBytes(x);
    523 
    524       if (n < 63)
    525          return n + 1;
    526       return n + 2 + (n - 63) / 255;
    527    }
    528    else if (isNil(x))
    529       return 1;
    530    else if (isSym(x))
    531       return binSize(name(x));
    532    else {
    533       any y = x;
    534       int n = 2;
    535 
    536       while (n += binSize(car(x)), !isNil(x = cdr(x))) {
    537          if (x == y)
    538             return n + 1;
    539          if (!isCell(x))
    540             return n + binSize(x);
    541       }
    542       return n;
    543    }
    544 }
    545 
    546 /*** Error handling ***/
    547 void err(any ex, any x, char *fmt, ...) {
    548    va_list ap;
    549    char msg[240];
    550    outFrame f;
    551    cell c1;
    552 
    553    va_start(ap,fmt);
    554    vsnprintf(msg, sizeof(msg), fmt, ap);
    555    va_end(ap);
    556    val(Up) = ex ?: Nil;
    557    if (x)
    558       Push(c1, x);
    559    if (msg[0]) {
    560       any y;
    561       catchFrame *p;
    562 
    563       val(Msg) = mkStr(msg);
    564       for (p = CatchPtr;  p;  p = p->link)
    565          if (y = p->tag)
    566             while (isCell(y)) {
    567                if (subStr(car(y), val(Msg))) {
    568                   Thrown = isNil(car(y))? val(Msg) : car(y);
    569                   unwind(p);
    570                   longjmp(p->rst, 1);
    571                }
    572                y = cdr(y);
    573             }
    574    }
    575    Chr = ExtN = 0;
    576    Break = NO;
    577    Alarm = Line = Nil;
    578    f.pid = 0,  f.fd = STDERR_FILENO,  pushOutFiles(&f);
    579    if (InFile && InFile->name) {
    580       Env.put('[');
    581       outString(InFile->name), Env.put(':'), outWord(InFile->src);
    582       Env.put(']'), space();
    583    }
    584    if (ex)
    585       outString("!? "), print(ex), newline();
    586    if (x)
    587       print(x), outString(" -- ");
    588    if (msg[0]) {
    589       outString(msg), newline();
    590       if (!isNil(val(Err)) && !Jam)
    591          Jam = YES,  prog(val(Err)),  Jam = NO;
    592       if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO))
    593          bye(1);
    594       load(NULL, '?', Nil);
    595    }
    596    unwind(NULL);
    597    Env.stack = NULL;
    598    Env.protect = Env.trace = 0;
    599    Env.next = -1;
    600    Env.task = Nil;
    601    Env.make = Env.yoke = NULL;
    602    Env.parser = NULL;
    603    longjmp(ErrRst, +1);
    604 }
    605 
    606 // (quit ['any ['any]])
    607 any doQuit(any x) {
    608    any y;
    609 
    610    x = cdr(x),  y = evSym(x);
    611    {
    612       char msg[bufSize(y)];
    613 
    614       bufString(y, msg);
    615       x = isCell(x = cdr(x))?  EVAL(car(x)) : NULL;
    616       err(NULL, x, "%s", msg);
    617    }
    618 }
    619 
    620 void argError(any ex, any x) {err(ex, x, "Bad argument");}
    621 void numError(any ex, any x) {err(ex, x, "Number expected");}
    622 void cntError(any ex, any x) {err(ex, x, "Small number expected");}
    623 void symError(any ex, any x) {err(ex, x, "Symbol expected");}
    624 void extError(any ex, any x) {err(ex, x, "External symbol expected");}
    625 void pairError(any ex, any x) {err(ex, x, "Cons pair expected");}
    626 void atomError(any ex, any x) {err(ex, x, "Atom expected");}
    627 void lstError(any ex, any x) {err(ex, x, "List expected");}
    628 void varError(any ex, any x) {err(ex, x, "Variable expected");}
    629 void protError(any ex, any x) {err(ex, x, "Protected symbol");}
    630 
    631 void pipeError(any ex, char *s) {err(ex, NULL, "Pipe %s error", s);}
    632 
    633 void unwind(catchFrame *catch) {
    634    any x;
    635    int i, j, n;
    636    bindFrame *p;
    637    catchFrame *q;
    638 
    639    while (q = CatchPtr) {
    640       while (p = Env.bind) {
    641          if ((i = p->i) < 0) {
    642             j = i, n = 0;
    643             while (++n, ++j && (p = p->link))
    644                if (p->i >= 0 || p->i < i)
    645                   --j;
    646             do {
    647                for (p = Env.bind, j = n;  --j;  p = p->link);
    648                if (p->i < 0  &&  ((p->i -= i) > 0? (p->i = 0) : p->i) == 0)
    649                   for (j = p->cnt;  --j >= 0;) {
    650                      x = val(p->bnd[j].sym);
    651                      val(p->bnd[j].sym) = p->bnd[j].val;
    652                      p->bnd[j].val = x;
    653                   }
    654             } while (--n);
    655          }
    656          if (Env.bind == q->env.bind)
    657             break;
    658          if (Env.bind->i == 0)
    659             for (i = Env.bind->cnt;  --i >= 0;)
    660                val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
    661          Env.bind = Env.bind->link;
    662       }
    663       while (Env.inFrames != q->env.inFrames)
    664          popInFiles();
    665       while (Env.outFrames != q->env.outFrames)
    666          popOutFiles();
    667       while (Env.errFrames != q->env.errFrames)
    668          popErrFiles();
    669       while (Env.ctlFrames != q->env.ctlFrames)
    670          popCtlFiles();
    671       Env = q->env;
    672       EVAL(q->fin);
    673       CatchPtr = q->link;
    674       if (q == catch)
    675          return;
    676    }
    677    while (Env.bind) {
    678       if (Env.bind->i == 0)
    679          for (i = Env.bind->cnt;  --i >= 0;)
    680             val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
    681       Env.bind = Env.bind->link;
    682    }
    683    while (Env.inFrames)
    684       popInFiles();
    685    while (Env.outFrames)
    686       popOutFiles();
    687    while (Env.errFrames)
    688       popErrFiles();
    689    while (Env.ctlFrames)
    690       popCtlFiles();
    691 }
    692 
    693 /*** Evaluation ***/
    694 any evExpr(any expr, any x) {
    695    any y = car(expr);
    696    struct {  // bindFrame
    697       struct bindFrame *link;
    698       int i, cnt;
    699       struct {any sym; any val;} bnd[length(y)+2];
    700    } f;
    701 
    702    f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    703    f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1;
    704    f.cnt = 1,  f.bnd[0].sym = At,  f.bnd[0].val = val(At);
    705    while (isCell(y)) {
    706       f.bnd[f.cnt].sym = car(y);
    707       f.bnd[f.cnt].val = EVAL(car(x));
    708       ++f.cnt, x = cdr(x), y = cdr(y);
    709    }
    710    if (isNil(y)) {
    711       do {
    712          x = val(f.bnd[--f.i].sym);
    713          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    714          f.bnd[f.i].val = x;
    715       } while (f.i);
    716       x = prog(cdr(expr));
    717    }
    718    else if (y != At) {
    719       f.bnd[f.cnt].sym = y,  f.bnd[f.cnt++].val = val(y),  val(y) = x;
    720       do {
    721          x = val(f.bnd[--f.i].sym);
    722          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    723          f.bnd[f.i].val = x;
    724       } while (f.i);
    725       x = prog(cdr(expr));
    726    }
    727    else {
    728       int n, cnt;
    729       cell *arg;
    730       cell c[n = cnt = length(x)];
    731 
    732       while (--n >= 0)
    733          Push(c[n], EVAL(car(x))),  x = cdr(x);
    734       do {
    735          x = val(f.bnd[--f.i].sym);
    736          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    737          f.bnd[f.i].val = x;
    738       } while (f.i);
    739       n = Env.next,  Env.next = cnt;
    740       arg = Env.arg,  Env.arg = c;
    741       x = prog(cdr(expr));
    742       if (cnt)
    743          drop(c[cnt-1]);
    744       Env.arg = arg,  Env.next = n;
    745    }
    746    while (--f.cnt >= 0)
    747       val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    748    Env.bind = f.link;
    749    return x;
    750 }
    751 
    752 any funq(any x) {
    753    any y;
    754 
    755    if (isSym(x))
    756       return Nil;
    757    if (isNum(x))
    758       return (unDig(x)&3) || isNum(cdr(numCell(x)))? Nil : x;
    759    for (y = cdr(x); isCell(y); y = cdr(y)) {
    760       if (y == x)
    761          return Nil;
    762       if (isCell(car(y))) {
    763          if (isNum(caar(y))) {
    764             if (isCell(cdr(y)))
    765                return Nil;
    766          }
    767          else if (isNil(caar(y)) || caar(y) == T)
    768             return Nil;
    769       }
    770       else if (!isNil(cdr(y)))
    771          return Nil;
    772    }
    773    if (!isNil(y))
    774       return Nil;
    775    if (isNil(x = car(x)))
    776       return T;
    777    for (y = x; isCell(y);)
    778       if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y)==T || x==(y=cdr(y)))
    779          return Nil;
    780    return isNum(y) || y==T? Nil : x;
    781 }
    782 
    783 bool sharedLib(any x) {
    784    void *h;
    785    char *p, nm[bufSize(x)];
    786 
    787    bufString(x, nm);
    788    if (!(p = strchr(nm,':'))  ||  p == nm  ||  p[1] == '\0')
    789       return NO;
    790    *p++ = '\0';
    791    {
    792       int n = Home? strlen(Home) : 0;
    793 #ifndef __CYGWIN__
    794       char buf[n + strlen(nm) + 4 + 1];
    795 #else
    796       char buf[n + strlen(nm) + 4 + 4 + 1];
    797 #endif
    798 
    799       if (strchr(nm,'/'))
    800          strcpy(buf, nm);
    801       else {
    802          if (n)
    803             memcpy(buf, Home, n);
    804          strcpy(buf + n, "lib/"),  strcpy(buf + n + 4, nm);
    805 #ifdef __CYGWIN__
    806          strcpy(buf + n + 4 + strlen(nm), ".dll");
    807 #endif
    808       }
    809       if (!(h = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL))  ||  !(h = dlsym(h,p)))
    810          return NO;
    811       val(x) = box(num(h));
    812    }
    813    return YES;
    814 }
    815 
    816 void undefined(any x, any ex) {
    817    if (!sharedLib(x))
    818       err(ex, x, "Undefined");
    819 }
    820 
    821 static any evList2(any foo, any ex) {
    822    cell c1;
    823 
    824    Push(c1, foo);
    825    if (isCell(foo)) {
    826       foo = evExpr(foo, cdr(ex));
    827       drop(c1);
    828       return foo;
    829    }
    830    for (;;) {
    831       if (isNil(val(foo)))
    832          undefined(foo,ex);
    833       if (*Signal)
    834          sighandler(ex);
    835       if (isNum(foo = val(foo))) {
    836          foo = evSubr(foo,ex);
    837          drop(c1);
    838          return foo;
    839       }
    840       if (isCell(foo)) {
    841          foo = evExpr(foo, cdr(ex));
    842          drop(c1);
    843          return foo;
    844       }
    845    }
    846 }
    847 
    848 /* Evaluate a list */
    849 any evList(any ex) {
    850    any foo;
    851 
    852    if (!isSym(foo = car(ex))) {
    853       if (isNum(foo))
    854          return ex;
    855       if (*Signal)
    856          sighandler(ex);
    857       if (isNum(foo = evList(foo)))
    858          return evSubr(foo,ex);
    859       return evList2(foo,ex);
    860    }
    861    for (;;) {
    862       if (isNil(val(foo)))
    863          undefined(foo,ex);
    864       if (*Signal)
    865          sighandler(ex);
    866       if (isNum(foo = val(foo)))
    867          return evSubr(foo,ex);
    868       if (isCell(foo))
    869          return evExpr(foo, cdr(ex));
    870    }
    871 }
    872 
    873 /* Evaluate any to sym */
    874 any evSym(any x) {return xSym(EVAL(car(x)));}
    875 
    876 any xSym(any x) {
    877    int i;
    878    any nm;
    879    cell c1, c2;
    880 
    881    if (isSym(x))
    882       return x;
    883    Push(c1,x);
    884    nm = NULL,  pack(x, &i, &nm, &c2);
    885    drop(c1);
    886    return nm? consStr(data(c2)) : Nil;
    887 }
    888 
    889 /* Evaluate count */
    890 long evCnt(any ex, any x) {return xCnt(ex, EVAL(car(x)));}
    891 
    892 long xCnt(any ex, any x) {
    893    NeedCnt(ex,x);
    894    return unBox(x);
    895 }
    896 
    897 /* Evaluate double */
    898 double evDouble(any ex, any x) {
    899    x = EVAL(car(x));
    900    NeedNum(ex,x);
    901    return numToDouble(x);
    902 }
    903 
    904 // (args) -> flg
    905 any doArgs(any ex __attribute__((unused))) {
    906    return Env.next > 0? T : Nil;
    907 }
    908 
    909 // (next) -> any
    910 any doNext(any ex __attribute__((unused))) {
    911    if (Env.next > 0)
    912       return data(Env.arg[--Env.next]);
    913    if (Env.next == 0)
    914       Env.next = -1;
    915    return Nil;
    916 }
    917 
    918 // (arg ['cnt]) -> any
    919 any doArg(any ex) {
    920    long n;
    921 
    922    if (Env.next < 0)
    923       return Nil;
    924    if (!isCell(cdr(ex)))
    925       return data(Env.arg[Env.next]);
    926    if ((n = evCnt(ex,cdr(ex))) > 0  &&  n <= Env.next)
    927       return data(Env.arg[Env.next - n]);
    928    return Nil;
    929 }
    930 
    931 // (rest) -> lst
    932 any doRest(any x) {
    933    int i;
    934    cell c1;
    935 
    936    if ((i = Env.next) <= 0)
    937       return Nil;
    938    Push(c1, x = cons(data(Env.arg[--i]), Nil));
    939    while (i)
    940       x = cdr(x) = cons(data(Env.arg[--i]), Nil);
    941    return Pop(c1);
    942 }
    943 
    944 static struct tm *TM;
    945 
    946 any mkDat(int y, int m, int d) {
    947    int n;
    948    static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31};
    949 
    950    if (m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400))
    951       return Nil;
    952    n = (12*y + m - 3) / 12;
    953    return boxCnt((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d);
    954 }
    955 
    956 // (date ['T]) -> dat
    957 // (date 'dat) -> (y m d)
    958 // (date 'y 'm 'd) -> dat | NIL
    959 // (date '(y m d)) -> dat | NIL
    960 any doDate(any ex) {
    961    any x, z;
    962    int y, m, d, n;
    963    cell c1;
    964 
    965    if (!isCell(x = cdr(ex))) {
    966       gettimeofday(&Tv,NULL);
    967       TM = localtime(&Tv.tv_sec);
    968       return mkDat(TM->tm_year+1900,  TM->tm_mon+1,  TM->tm_mday);
    969    }
    970    if ((z = EVAL(car(x))) == T) {
    971       gettimeofday(&Tv,NULL);
    972       TM = gmtime(&Tv.tv_sec);
    973       return mkDat(TM->tm_year+1900,  TM->tm_mon+1,  TM->tm_mday);
    974    }
    975    if (isNil(z))
    976       return Nil;
    977    if (isCell(z))
    978       return mkDat(xCnt(ex, car(z)),  xCnt(ex, cadr(z)),  xCnt(ex, caddr(z)));
    979    if (!isCell(x = cdr(x))) {
    980       n = xCnt(ex,z);
    981       y = (100*n - 20) / 3652425;
    982       n += (y - y/4);
    983       y = (100*n - 20) / 36525;
    984       n -= 36525*y / 100;
    985       m = (10*n - 5) / 306;
    986       d = (10*n - 306*m + 5) / 10;
    987       if (m < 10)
    988          m += 3;
    989       else
    990          ++y,  m -= 9;
    991       Push(c1, cons(boxCnt(d), Nil));
    992       data(c1) = cons(boxCnt(m), data(c1));
    993       data(c1) = cons(boxCnt(y), data(c1));
    994       return Pop(c1);
    995    }
    996    y = xCnt(ex,z);
    997    m = evCnt(ex,x);
    998    return mkDat(y, m, evCnt(ex,cdr(x)));
    999 }
   1000 
   1001 any mkTime(int h, int m, int s) {
   1002    if (h < 0 || h > 23  ||  m < 0 || m > 59  ||  s < 0 || s > 60)
   1003       return Nil;
   1004    return boxCnt(h * 3600 + m * 60 + s);
   1005 }
   1006 
   1007 // (time ['T]) -> tim
   1008 // (time 'tim) -> (h m s)
   1009 // (time 'h 'm ['s]) -> tim | NIL
   1010 // (time '(h m [s])) -> tim | NIL
   1011 any doTime(any ex) {
   1012    any x, z;
   1013    int h, m, s;
   1014    cell c1;
   1015    struct tm *p;
   1016 
   1017    if (!isCell(x = cdr(ex))) {
   1018       gettimeofday(&Tv,NULL);
   1019       p = localtime(&Tv.tv_sec);
   1020       return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec);
   1021    }
   1022    if ((z = EVAL(car(x))) == T)
   1023       return TM? boxCnt(TM->tm_hour * 3600 + TM->tm_min * 60 + TM->tm_sec) : Nil;
   1024    if (isNil(z))
   1025       return Nil;
   1026    if (isCell(z))
   1027       return mkTime(xCnt(ex, car(z)), xCnt(ex, cadr(z)), isCell(cddr(z))? xCnt(ex, caddr(z)) : 0);
   1028    if (!isCell(x = cdr(x))) {
   1029       s = xCnt(ex,z);
   1030       Push(c1, cons(boxCnt(s % 60), Nil));
   1031       data(c1) = cons(boxCnt(s / 60 % 60), data(c1));
   1032       data(c1) = cons(boxCnt(s / 3600), data(c1));
   1033       return Pop(c1);
   1034    }
   1035    h = xCnt(ex, z);
   1036    m = evCnt(ex, x);
   1037    return mkTime(h, m, isCell(cdr(x))? evCnt(ex, cdr(x)) : 0);
   1038 }
   1039 
   1040 // (usec ['flg]) -> num
   1041 any doUsec(any ex) {
   1042    if (!isNil(EVAL(cadr(ex))))
   1043       return boxCnt(Tv.tv_usec);
   1044    gettimeofday(&Tv,NULL);
   1045    return boxWord2((word2)Tv.tv_sec*1000000 + Tv.tv_usec - USec);
   1046 }
   1047 
   1048 // (pwd) -> sym
   1049 any doPwd(any x) {
   1050    char *p;
   1051 
   1052    if ((p = getcwd(NULL,0)) == NULL)
   1053       return Nil;
   1054    x = mkStr(p);
   1055    free(p);
   1056    return x;
   1057 }
   1058 
   1059 // (cd 'any) -> sym
   1060 any doCd(any x) {
   1061    x = evSym(cdr(x));
   1062    {
   1063       char *p, path[pathSize(x)];
   1064 
   1065       pathString(x, path);
   1066       if ((p = getcwd(NULL,0)) == NULL  ||  path[0] && chdir(path) < 0)
   1067          return Nil;
   1068       x = mkStr(p);
   1069       free(p);
   1070       return x;
   1071    }
   1072 }
   1073 
   1074 // (ctty 'sym|pid) -> flg
   1075 any doCtty(any ex) {
   1076    any x;
   1077 
   1078    if (isNum(x = EVAL(cadr(ex))))
   1079       TtyPid = unDig(x) / 2;
   1080    else {
   1081       if (!isSym(x))
   1082          argError(ex,x);
   1083       {
   1084          char tty[bufSize(x)];
   1085 
   1086          bufString(x, tty);
   1087          if (!freopen(tty,"r",stdin) || !freopen(tty,"w",stdout) || !freopen(tty,"w",stderr))
   1088             return Nil;
   1089          OutFiles[STDOUT_FILENO]->tty = YES;
   1090       }
   1091    }
   1092    return T;
   1093 }
   1094 
   1095 // (info 'any ['flg]) -> (cnt|T dat . tim)
   1096 any doInfo(any x) {
   1097    any y;
   1098    cell c1;
   1099    struct tm *p;
   1100    struct stat st;
   1101 
   1102    y = evSym(x = cdr(x));
   1103    {
   1104       char nm[pathSize(y)];
   1105 
   1106       pathString(y, nm);
   1107       x = cdr(x);
   1108       if ((isNil(EVAL(car(x)))? stat(nm, &st) : lstat(nm, &st)) < 0)
   1109          return Nil;
   1110       p = gmtime(&st.st_mtime);
   1111       Push(c1, boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec));
   1112       data(c1) = cons(mkDat(p->tm_year+1900,  p->tm_mon+1,  p->tm_mday), data(c1));
   1113       data(c1) = cons(S_ISDIR(st.st_mode)? T : boxWord2((word2)st.st_size), data(c1));
   1114       return Pop(c1);
   1115    }
   1116 }
   1117 
   1118 // (file) -> (sym1 sym2 . num) | NIL
   1119 any doFile(any ex __attribute__((unused))) {
   1120    char *s, *p;
   1121    cell c1;
   1122 
   1123    if (!InFile || !InFile->name)
   1124       return Nil;
   1125    Push(c1, boxCnt(InFile->src));
   1126    s = strdup(InFile->name);
   1127    if (p = strrchr(s, '/')) {
   1128       data(c1) = cons(mkStr(p+1), data(c1));
   1129       *(p+1) = '\0';
   1130       data(c1) = cons(mkStr(s), data(c1));
   1131    }
   1132    else {
   1133       data(c1) = cons(mkStr(s), data(c1));
   1134       data(c1) = cons(mkStr("./"), data(c1));
   1135    }
   1136    free(s);
   1137    return Pop(c1);
   1138 }
   1139 
   1140 // (dir ['any] ['flg]) -> lst
   1141 any doDir(any x) {
   1142    any y;
   1143    DIR *dp;
   1144    struct dirent *p;
   1145    cell c1;
   1146 
   1147    if (isNil(y = evSym(x = cdr(x))))
   1148       dp = opendir(".");
   1149    else {
   1150       char nm[pathSize(y)];
   1151 
   1152       pathString(y, nm);
   1153       dp = opendir(nm);
   1154    }
   1155    if (!dp)
   1156       return Nil;
   1157    x = cdr(x),  x = EVAL(car(x));
   1158    do {
   1159       if (!(p = readdir(dp))) {
   1160          closedir(dp);
   1161          return Nil;
   1162       }
   1163    } while (isNil(x) && p->d_name[0] == '.');
   1164    Push(c1, y = cons(mkStr(p->d_name), Nil));
   1165    while (p = readdir(dp))
   1166       if (!isNil(x) || p->d_name[0] != '.')
   1167          y = cdr(y) = cons(mkStr(p->d_name), Nil);
   1168    closedir(dp);
   1169    return Pop(c1);
   1170 }
   1171 
   1172 // (cmd ['any]) -> sym
   1173 any doCmd(any x) {
   1174    if (isNil(x = evSym(cdr(x))))
   1175       return mkStr(AV0);
   1176    bufString(x, AV0);
   1177    return x;
   1178 }
   1179 
   1180 // (argv [var ..] [. sym]) -> lst|sym
   1181 any doArgv(any ex) {
   1182    any x, y;
   1183    char **p;
   1184    cell c1;
   1185 
   1186    if (*(p = AV) && strcmp(*p,"-") == 0)
   1187       ++p;
   1188    if (isNil(x = cdr(ex))) {
   1189       if (!*p)
   1190          return Nil;
   1191       Push(c1, x = cons(mkStr(*p++), Nil));
   1192       while (*p)
   1193          x = cdr(x) = cons(mkStr(*p++), Nil);
   1194       return Pop(c1);
   1195    }
   1196    do {
   1197       if (!isCell(x)) {
   1198          NeedSym(ex,x);
   1199          CheckVar(ex,x);
   1200          if (!*p)
   1201             return val(x) = Nil;
   1202          Push(c1, y = cons(mkStr(*p++), Nil));
   1203          while (*p)
   1204             y = cdr(y) = cons(mkStr(*p++), Nil);
   1205          return val(x) = Pop(c1);
   1206       }
   1207       y = car(x);
   1208       NeedVar(ex,y);
   1209       CheckVar(ex,y);
   1210       val(y) = *p? mkStr(*p++) : Nil;
   1211    } while (!isNil(x = cdr(x)));
   1212    return val(y);
   1213 }
   1214 
   1215 // (opt) -> sym
   1216 any doOpt(any ex __attribute__((unused))) {
   1217    return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil;
   1218 }
   1219 
   1220 // (version ['flg]) -> lst
   1221 any doVersion(any x) {
   1222    int i;
   1223    cell c1;
   1224 
   1225    x = cdr(x);
   1226    if (isNil(EVAL(car(x)))) {
   1227       for (i = 0; i < 4; ++i) {
   1228          outWord((word)Version[i]);
   1229          Env.put(i == 3? ' ' : '.');
   1230       }
   1231       Env.put('C');
   1232       newline();
   1233    }
   1234    Push(c1, Nil);
   1235    i = 4;
   1236    do
   1237       data(c1) = cons(box(Version[--i] * 2), data(c1));
   1238    while (i);
   1239    return Pop(c1);
   1240 }
   1241 
   1242 any loadAll(any ex) {
   1243    any x = Nil;
   1244 
   1245    while (*AV  &&  strcmp(*AV,"-") != 0)
   1246       x = load(ex, 0, mkStr(*AV++));
   1247    return x;
   1248 }
   1249 
   1250 /*** Main ***/
   1251 static void init(int ac, char *av[]) {
   1252    char *p;
   1253    sigset_t sigs;
   1254 
   1255    AV0 = *av++;
   1256    AV = av;
   1257    heapAlloc();
   1258    initSymbols();
   1259    if (ac >= 2 && strcmp(av[ac-2], "+") == 0)
   1260       val(Dbg) = T,  av[ac-2] = NULL;
   1261    if (av[0] && *av[0] != '-' && (p = strrchr(av[0], '/')) && !(p == av[0]+1 && *av[0] == '.')) {
   1262       Home = malloc(p - av[0] + 2);
   1263       memcpy(Home, av[0], p - av[0] + 1);
   1264       Home[p - av[0] + 1] = '\0';
   1265    }
   1266    Env.get = getStdin;
   1267    InFile = initInFile(STDIN_FILENO, NULL);
   1268    Env.put = putStdout;
   1269    initOutFile(STDERR_FILENO);
   1270    OutFile = initOutFile(STDOUT_FILENO);
   1271    Env.task = Alarm = Sigio = Line = Nil;
   1272    setrlimit(RLIMIT_STACK, &ULim);
   1273    Tio = tcgetattr(STDIN_FILENO, &OrgTermio) == 0;
   1274    ApplyArgs = cons(cons(consSym(Nil,Nil), Nil), Nil);
   1275    ApplyBody = cons(Nil,Nil);
   1276    sigfillset(&sigs);
   1277    sigprocmask(SIG_UNBLOCK, &sigs, NULL);
   1278    iSignal(SIGHUP, sig);
   1279    iSignal(SIGINT, sigTerm);
   1280    iSignal(SIGUSR1, sig);
   1281    iSignal(SIGUSR2, sig);
   1282    iSignal(SIGALRM, sig);
   1283    iSignal(SIGTERM, sig);
   1284    iSignal(SIGIO, sig);
   1285    signal(SIGCHLD, sigChld);
   1286    signal(SIGPIPE, SIG_IGN);
   1287    signal(SIGTTIN, SIG_IGN);
   1288    signal(SIGTTOU, SIG_IGN);
   1289    gettimeofday(&Tv,NULL);
   1290    USec = (word2)Tv.tv_sec*1000000 + Tv.tv_usec;
   1291 }
   1292 
   1293 int MAIN(int ac, char *av[]) {
   1294    init(ac,av);
   1295    if (!setjmp(ErrRst)) {
   1296       loadAll(NULL);
   1297       ++Repl;
   1298       iSignal(SIGINT, sig);
   1299    }
   1300    for (;;)
   1301       load(NULL, ':', Nil);
   1302 }
	picolisp Unnamed repository; edit this file to name it for gitweb.
	git clone https://logand.com/git/picolisp.git/
	Log \| Files \| Refs \| README \| LICENSE