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

subr.c (37844B)
      1 /* 22jul13abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 // (car 'var) -> any
      8 any doCar(any ex) {
      9    any x = cdr(ex);
     10    x = EVAL(car(x));
     11    NeedVar(ex,x);
     12    return car(x);
     13 }
     14 
     15 // (cdr 'lst) -> any
     16 any doCdr(any ex) {
     17    any x = cdr(ex);
     18    x = EVAL(car(x));
     19    NeedLst(ex,x);
     20    return cdr(x);
     21 }
     22 
     23 any doCaar(any ex) {
     24    any x = cdr(ex);
     25    x = EVAL(car(x));
     26    NeedVar(ex,x);
     27    return caar(x);
     28 }
     29 
     30 any doCadr(any ex) {
     31    any x = cdr(ex);
     32    x = EVAL(car(x));
     33    NeedLst(ex,x);
     34    return cadr(x);
     35 }
     36 
     37 any doCdar(any ex) {
     38    any x = cdr(ex);
     39    x = EVAL(car(x));
     40    NeedVar(ex,x);
     41    return cdar(x);
     42 }
     43 
     44 any doCddr(any ex) {
     45    any x = cdr(ex);
     46    x = EVAL(car(x));
     47    NeedLst(ex,x);
     48    return cddr(x);
     49 }
     50 
     51 any doCaaar(any ex) {
     52    any x = cdr(ex);
     53    x = EVAL(car(x));
     54    NeedVar(ex,x);
     55    return caaar(x);
     56 }
     57 
     58 any doCaadr(any ex) {
     59    any x = cdr(ex);
     60    x = EVAL(car(x));
     61    NeedLst(ex,x);
     62    return caadr(x);
     63 }
     64 
     65 any doCadar(any ex) {
     66    any x = cdr(ex);
     67    x = EVAL(car(x));
     68    NeedVar(ex,x);
     69    return cadar(x);
     70 }
     71 
     72 any doCaddr(any ex) {
     73    any x = cdr(ex);
     74    x = EVAL(car(x));
     75    NeedLst(ex,x);
     76    return caddr(x);
     77 }
     78 
     79 any doCdaar(any ex) {
     80    any x = cdr(ex);
     81    x = EVAL(car(x));
     82    NeedVar(ex,x);
     83    return cdaar(x);
     84 }
     85 
     86 any doCdadr(any ex) {
     87    any x = cdr(ex);
     88    x = EVAL(car(x));
     89    NeedLst(ex,x);
     90    return cdadr(x);
     91 }
     92 
     93 any doCddar(any ex) {
     94    any x = cdr(ex);
     95    x = EVAL(car(x));
     96    NeedVar(ex,x);
     97    return cddar(x);
     98 }
     99 
    100 any doCdddr(any ex) {
    101    any x = cdr(ex);
    102    x = EVAL(car(x));
    103    NeedLst(ex,x);
    104    return cdddr(x);
    105 }
    106 
    107 any doCaaaar(any ex) {
    108    any x = cdr(ex);
    109    x = EVAL(car(x));
    110    NeedVar(ex,x);
    111    return caaaar(x);
    112 }
    113 
    114 any doCaaadr(any ex) {
    115    any x = cdr(ex);
    116    x = EVAL(car(x));
    117    NeedLst(ex,x);
    118    return caaadr(x);
    119 }
    120 
    121 any doCaadar(any ex) {
    122    any x = cdr(ex);
    123    x = EVAL(car(x));
    124    NeedVar(ex,x);
    125    return caadar(x);
    126 }
    127 
    128 any doCaaddr(any ex) {
    129    any x = cdr(ex);
    130    x = EVAL(car(x));
    131    NeedLst(ex,x);
    132    return caaddr(x);
    133 }
    134 
    135 any doCadaar(any ex) {
    136    any x = cdr(ex);
    137    x = EVAL(car(x));
    138    NeedVar(ex,x);
    139    return cadaar(x);
    140 }
    141 
    142 any doCadadr(any ex) {
    143    any x = cdr(ex);
    144    x = EVAL(car(x));
    145    NeedLst(ex,x);
    146    return cadadr(x);
    147 }
    148 
    149 any doCaddar(any ex) {
    150    any x = cdr(ex);
    151    x = EVAL(car(x));
    152    NeedVar(ex,x);
    153    return caddar(x);
    154 }
    155 
    156 any doCadddr(any ex) {
    157    any x = cdr(ex);
    158    x = EVAL(car(x));
    159    NeedLst(ex,x);
    160    return cadddr(x);
    161 }
    162 
    163 any doCdaaar(any ex) {
    164    any x = cdr(ex);
    165    x = EVAL(car(x));
    166    NeedVar(ex,x);
    167    return cdaaar(x);
    168 }
    169 
    170 any doCdaadr(any ex) {
    171    any x = cdr(ex);
    172    x = EVAL(car(x));
    173    NeedLst(ex,x);
    174    return cdaadr(x);
    175 }
    176 
    177 any doCdadar(any ex) {
    178    any x = cdr(ex);
    179    x = EVAL(car(x));
    180    NeedVar(ex,x);
    181    return cdadar(x);
    182 }
    183 
    184 any doCdaddr(any ex) {
    185    any x = cdr(ex);
    186    x = EVAL(car(x));
    187    NeedLst(ex,x);
    188    return cdaddr(x);
    189 }
    190 
    191 any doCddaar(any ex) {
    192    any x = cdr(ex);
    193    x = EVAL(car(x));
    194    NeedVar(ex,x);
    195    return cddaar(x);
    196 }
    197 
    198 any doCddadr(any ex) {
    199    any x = cdr(ex);
    200    x = EVAL(car(x));
    201    NeedLst(ex,x);
    202    return cddadr(x);
    203 }
    204 
    205 any doCdddar(any ex) {
    206    any x = cdr(ex);
    207    x = EVAL(car(x));
    208    NeedVar(ex,x);
    209    return cdddar(x);
    210 }
    211 
    212 any doCddddr(any ex) {
    213    any x = cdr(ex);
    214    x = EVAL(car(x));
    215    NeedLst(ex,x);
    216    return cddddr(x);
    217 }
    218 
    219 // (nth 'lst 'cnt ..) -> lst
    220 any doNth(any ex) {
    221    any x;
    222    cell c1;
    223 
    224    x = cdr(ex),  Push(c1, EVAL(car(x))),  x = cdr(x);
    225    for (;;) {
    226       if (!isCell(data(c1)))
    227          return Pop(c1);
    228       data(c1) = nth((int)evCnt(ex,x), data(c1));
    229       if (!isCell(x = cdr(x)))
    230          return Pop(c1);
    231       data(c1) = car(data(c1));
    232    }
    233 }
    234 
    235 // (con 'lst 'any) -> any
    236 any doCon(any ex) {
    237    any x;
    238    cell c1;
    239 
    240    x = cdr(ex),  Push(c1, EVAL(car(x)));
    241    NeedPair(ex,data(c1));
    242    x = cdr(x),  x = cdr(data(c1)) = EVAL(car(x));
    243    drop(c1);
    244    return x;
    245 }
    246 
    247 // (cons 'any ['any ..]) -> lst
    248 any doCons(any x) {
    249    any y;
    250    cell c1;
    251 
    252    x = cdr(x);
    253    Push(c1, y = cons(EVAL(car(x)),Nil));
    254    while (isCell(cdr(x = cdr(x))))
    255       y = cdr(y) = cons(EVAL(car(x)),Nil);
    256    cdr(y) = EVAL(car(x));
    257    return Pop(c1);
    258 }
    259 
    260 // (conc 'lst ..) -> lst
    261 any doConc(any x) {
    262    any y, z;
    263    cell c1;
    264 
    265    x = cdr(x),  Push(c1, y = EVAL(car(x)));
    266    while (isCell(x = cdr(x))) {
    267       z = EVAL(car(x));
    268       if (!isCell(y))
    269          y = data(c1) = z;
    270       else {
    271          while (isCell(cdr(y)))
    272             y = cdr(y);
    273          cdr(y) = z;
    274       }
    275    }
    276    return Pop(c1);
    277 }
    278 
    279 // (circ 'any ..) -> lst
    280 any doCirc(any x) {
    281    any y;
    282    cell c1;
    283 
    284    x = cdr(x);
    285    Push(c1, y = cons(EVAL(car(x)),Nil));
    286    while (isCell(x = cdr(x)))
    287       y = cdr(y) = cons(EVAL(car(x)),Nil);
    288    cdr(y) = data(c1);
    289    return Pop(c1);
    290 }
    291 
    292 // (rot 'lst ['cnt]) -> lst
    293 any doRot(any ex) {
    294    any x, y, z;
    295    int n;
    296    cell c1;
    297 
    298    x = cdr(ex),  Push(c1, y = EVAL(car(x)));
    299    if (isCell(y)) {
    300       n = isCell(x = cdr(x))? (int)evCnt(ex,x) : 0;
    301       x = car(y);
    302       while (--n  &&  isCell(y = cdr(y))  &&  y != data(c1))
    303          z = car(y),  car(y) = x,  x = z;
    304       car(data(c1)) = x;
    305    }
    306    return Pop(c1);
    307 }
    308 
    309 // (list 'any ['any ..]) -> lst
    310 any doList(any x) {
    311    any y;
    312    cell c1;
    313 
    314    x = cdr(x);
    315    Push(c1, y = cons(EVAL(car(x)),Nil));
    316    while (isCell(x = cdr(x)))
    317       y = cdr(y) = cons(EVAL(car(x)),Nil);
    318    return Pop(c1);
    319 }
    320 
    321 // (need 'cnt ['lst ['any]]) -> lst
    322 // (need 'cnt ['num|sym]) -> lst
    323 any doNeed(any ex) {
    324    int n;
    325    any x;
    326    cell c1, c2;
    327 
    328    n = (int)evCnt(ex, x = cdr(ex));
    329    x = cdr(x),  Push(c1, EVAL(car(x)));
    330    if (isCell(data(c1)) || isNil(data(c1)))
    331       Push(c2, EVAL(cadr(x)));
    332    else {
    333       Push(c2, data(c1));
    334       data(c1) = Nil;
    335    }
    336    x = data(c1);
    337    if (n > 0)
    338       for (n -= length(x); n > 0; --n)
    339          data(c1) = cons(data(c2), data(c1));
    340    else if (n) {
    341       if (!isCell(x))
    342          data(c1) = x = cons(data(c2),Nil);
    343       else
    344          while (isCell(cdr(x)))
    345             ++n,  x = cdr(x);
    346       while (++n < 0)
    347          x = cdr(x) = cons(data(c2),Nil);
    348    }
    349    return Pop(c1);
    350 }
    351 
    352 // (range 'num1 'num2 ['num3]) -> lst
    353 any doRange(any ex) {
    354    any x;
    355    cell c1, c2, c3, c4;
    356 
    357    x = cdr(ex),  Push(c1, EVAL(car(x)));  // Start value
    358    NeedNum(ex,data(c1));
    359    x = cdr(x),  Push(c2, EVAL(car(x)));  // End value
    360    NeedNum(ex,data(c2));
    361    x = cdr(x),  Push(c3, One);  // Increment
    362    if (!isNil(x = EVAL(car(x)))) {
    363       NeedNum(ex, data(c3) = x);
    364       if (IsZero(x) || isNeg(x))
    365          argError(ex,x);
    366    }
    367    Push(c4, x = cons(data(c1), Nil));
    368    if (bigCompare(data(c2), data(c1)) >= 0) {
    369       for (;;) {
    370          data(c1) = bigCopy(data(c1));
    371          if (!isNeg(data(c1)))
    372             bigAdd(data(c1), data(c3));
    373          else {
    374             bigSub(data(c1), data(c3));
    375             if (!IsZero(data(c1)))
    376                neg(data(c1));
    377          }
    378          if (bigCompare(data(c2), data(c1)) < 0)
    379             break;
    380          x = cdr(x) = cons(data(c1), Nil);
    381       }
    382    }
    383    else {
    384       for (;;) {
    385          data(c1) = bigCopy(data(c1));
    386          if (!isNeg(data(c1)))
    387             bigSub(data(c1), data(c3));
    388          else {
    389             bigAdd(data(c1), data(c3));
    390             if (!IsZero(data(c1)))
    391                neg(data(c1));
    392          }
    393          if (bigCompare(data(c2), data(c1)) > 0)
    394             break;
    395          x = cdr(x) = cons(data(c1),Nil);
    396       }
    397    }
    398    drop(c1);
    399    return data(c4);
    400 }
    401 
    402 // (full 'any) -> bool
    403 any doFull(any x) {
    404    x = cdr(x);
    405    for (x = EVAL(car(x)); isCell(x); x = cdr(x))
    406       if (isNil(car(x)))
    407          return Nil;
    408    return T;
    409 }
    410 
    411 // (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any
    412 any doMake(any x) {
    413    any *make, *yoke;
    414    cell c1;
    415 
    416    Push(c1, Nil);
    417    make = Env.make;
    418    yoke = Env.yoke;
    419    Env.make = Env.yoke = &data(c1);
    420    while (isCell(x = cdr(x)))
    421       if (isCell(car(x)))
    422          evList(car(x));
    423    Env.yoke = yoke;
    424    Env.make = make;
    425    return Pop(c1);
    426 }
    427 
    428 static void makeError(any ex) {err(ex, NULL, "Not making");}
    429 
    430 // (made ['lst1 ['lst2]]) -> lst
    431 any doMade(any x) {
    432    if (!Env.make)
    433       makeError(x);
    434    if (isCell(x = cdr(x))) {
    435       *Env.yoke = EVAL(car(x));
    436       if (x = cdr(x), !isCell(x = EVAL(car(x)))) {
    437          any y;
    438 
    439          x = *Env.yoke;
    440          while (isCell(y = cdr(x)))
    441             x = y;
    442       }
    443       Env.make = &cdr(x);
    444    }
    445    return *Env.yoke;
    446 }
    447 
    448 // (chain 'lst ..) -> lst
    449 any doChain(any x) {
    450    any y;
    451 
    452    if (!Env.make)
    453       makeError(x);
    454    x = cdr(x);
    455    do
    456       if (isCell(*Env.make = y = EVAL(car(x))))
    457          do
    458             Env.make = &cdr(*Env.make);
    459          while (isCell(*Env.make));
    460    while (isCell(x = cdr(x)));
    461    return y;
    462 }
    463 
    464 // (link 'any ..) -> any
    465 any doLink(any x) {
    466    any y;
    467 
    468    if (!Env.make)
    469       makeError(x);
    470    x = cdr(x);
    471    do {
    472       y = EVAL(car(x));
    473       Env.make = &cdr(*Env.make = cons(y, Nil));
    474    } while (isCell(x = cdr(x)));
    475    return y;
    476 }
    477 
    478 // (yoke 'any ..) -> any
    479 any doYoke(any x) {
    480    any y;
    481 
    482    if (!Env.make)
    483       makeError(x);
    484    x = cdr(x);
    485    do {
    486       y = EVAL(car(x));
    487       *Env.yoke = cons(y, *Env.yoke);
    488    } while (isCell(x = cdr(x)));
    489    while (isCell(*Env.make))
    490       Env.make = &cdr(*Env.make);
    491    return y;
    492 }
    493 
    494 // (copy 'any) -> any
    495 any doCopy(any x) {
    496    any y, z;
    497    cell c1;
    498 
    499    x = cdr(x);
    500    if (!isCell(x = EVAL(car(x))))
    501       return x;
    502    Push(c1, y = cons(car(x), cdr(z = x)));
    503    while (isCell(x = cdr(y))) {
    504       if (x == z) {
    505          cdr(y) = data(c1);
    506          break;
    507       }
    508       y = cdr(y) = cons(car(x), cdr(x));
    509    }
    510    return Pop(c1);
    511 }
    512 
    513 // (mix 'lst cnt|'any ..) -> lst
    514 any doMix(any x) {
    515    any y;
    516    cell c1, c2;
    517 
    518    x = cdr(x);
    519    if (!isCell(data(c1) = EVAL(car(x))) && !isNil(data(c1)))
    520       return data(c1);
    521    if (!isCell(x = cdr(x)))
    522       return Nil;
    523    Save(c1);
    524    Push(c2,
    525       y = cons(
    526          isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)),
    527          Nil ) );
    528    while (isCell(x = cdr(x)))
    529       y = cdr(y) = cons(
    530          isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)),
    531          Nil );
    532    drop(c1);
    533    return data(c2);
    534 }
    535 
    536 // (append 'lst ..) -> lst
    537 any doAppend(any x) {
    538    any y, z;
    539    cell c1;
    540 
    541    while (isCell(cdr(x = cdr(x)))) {
    542       if (isCell(y = EVAL(car(x)))) {
    543          Push(c1, z = cons(car(y), cdr(y)));
    544          while (isCell(y = cdr(z)))
    545             z = cdr(z) = cons(car(y), cdr(y));
    546          while (isCell(cdr(x = cdr(x)))) {
    547             for (y = EVAL(car(x)); isCell(y); y = cdr(z))
    548                z = cdr(z) = cons(car(y), cdr(y));
    549             cdr(z) = y;
    550          }
    551          cdr(z) = EVAL(car(x));
    552          return Pop(c1);
    553       }
    554    }
    555    return EVAL(car(x));
    556 }
    557 
    558 // (delete 'any 'lst) -> lst
    559 any doDelete(any x) {
    560    any y, z;
    561    cell c1, c2, c3;
    562 
    563    x = cdr(x),  Push(c1, y = EVAL(car(x)));
    564    x = cdr(x);
    565    if (!isCell(x = EVAL(car(x)))) {
    566       drop(c1);
    567       return x;
    568    }
    569    if (equal(y, car(x))) {
    570       drop(c1);
    571       return cdr(x);
    572    }
    573    Push(c2, x);
    574    Push(c3, z = cons(car(x), Nil));
    575    while (isCell(x = cdr(x))) {
    576       if (equal(y, car(x))) {
    577          cdr(z) = cdr(x);
    578          drop(c1);
    579          return data(c3);
    580       }
    581       z = cdr(z) = cons(car(x), Nil);
    582    }
    583    cdr(z) = x;
    584    drop(c1);
    585    return data(c3);
    586 }
    587 
    588 // (delq 'any 'lst) -> lst
    589 any doDelq(any x) {
    590    any y, z;
    591    cell c1, c2, c3;
    592 
    593    x = cdr(x),  Push(c1, y = EVAL(car(x)));
    594    x = cdr(x);
    595    if (!isCell(x = EVAL(car(x)))) {
    596       drop(c1);
    597       return x;
    598    }
    599    if (y == car(x)) {
    600       drop(c1);
    601       return cdr(x);
    602    }
    603    Push(c2, x);
    604    Push(c3, z = cons(car(x), Nil));
    605    while (isCell(x = cdr(x))) {
    606       if (y == car(x)) {
    607          cdr(z) = cdr(x);
    608          drop(c1);
    609          return data(c3);
    610       }
    611       z = cdr(z) = cons(car(x), Nil);
    612    }
    613    cdr(z) = x;
    614    drop(c1);
    615    return data(c3);
    616 }
    617 
    618 // (replace 'lst 'any1 'any2 ..) -> lst
    619 any doReplace(any x) {
    620    any y;
    621    int i, n = length(cdr(x = cdr(x))) + 1 & ~1;
    622    cell c1, c2, c[n];
    623 
    624    if (!isCell(data(c1) = EVAL(car(x))))
    625       return data(c1);
    626    Save(c1);
    627    for (i = 0; i < n; ++i)
    628       x = cdr(x),  Push(c[i], EVAL(car(x)));
    629    for (x = car(data(c1)), i = 0;  i < n;  i += 2)
    630       if (equal(x, data(c[i]))) {
    631          x = data(c[i+1]);
    632          break;
    633       }
    634    Push(c2, y = cons(x,Nil));
    635    while (isCell(data(c1) = cdr(data(c1)))) {
    636       for (x = car(data(c1)), i = 0;  i < n;  i += 2)
    637          if (equal(x, data(c[i]))) {
    638             x = data(c[i+1]);
    639             break;
    640          }
    641       y = cdr(y) = cons(x, Nil);
    642    }
    643    cdr(y) = data(c1);
    644    drop(c1);
    645    return data(c2);
    646 }
    647 
    648 // (strip 'any) -> any
    649 any doStrip(any x) {
    650    x = cdr(x),  x = EVAL(car(x));
    651    while (isCell(x)  &&  car(x) == Quote  && x != cdr(x))
    652       x = cdr(x);
    653    return x;
    654 }
    655 
    656 // (split 'lst 'any ..) -> lst
    657 any doSplit(any x) {
    658    any y;
    659    int i, n = length(cdr(x = cdr(x)));
    660    cell c1, c[n], res, sub;
    661 
    662    if (!isCell(data(c1) = EVAL(car(x))))
    663       return data(c1);
    664    Save(c1);
    665    for (i = 0; i < n; ++i)
    666       x = cdr(x),  Push(c[i], EVAL(car(x)));
    667    Push(res, x = Nil);
    668    Push(sub, y = Nil);
    669    do {
    670       for (i = 0;  i < n;  ++i) {
    671          if (equal(car(data(c1)), data(c[i]))) {
    672             if (isNil(x))
    673                x = data(res) = cons(data(sub), Nil);
    674             else
    675                x = cdr(x) = cons(data(sub), Nil);
    676             y = data(sub) = Nil;
    677             goto spl1;
    678          }
    679       }
    680       if (isNil(y))
    681          y = data(sub) = cons(car(data(c1)), Nil);
    682       else
    683          y = cdr(y) = cons(car(data(c1)), Nil);
    684 spl1: ;
    685    } while (isCell(data(c1) = cdr(data(c1))));
    686    y = cons(data(sub), Nil);
    687    drop(c1);
    688    if (isNil(x))
    689       return y;
    690    cdr(x) = y;
    691    return data(res);
    692 }
    693 
    694 // (reverse 'lst) -> lst
    695 any doReverse(any x) {
    696    any y;
    697    cell c1;
    698 
    699    x = cdr(x),  Push(c1, x = EVAL(car(x)));
    700    for (y = Nil; isCell(x); x = cdr(x))
    701       y = cons(car(x), y);
    702    drop(c1);
    703    return y;
    704 }
    705 
    706 // (flip 'lst ['cnt])) -> lst
    707 any doFlip(any ex) {
    708    any x, y, z;
    709    int n;
    710    cell c1;
    711 
    712    x = cdr(ex);
    713    if (!isCell(y = EVAL(car(x))) || !isCell(z = cdr(y)))
    714       return y;
    715    if (!isCell(x = cdr(x))) {
    716       cdr(y) = Nil;
    717       for (;;) {
    718          x = cdr(z),  cdr(z) = y;
    719          if (!isCell(x))
    720             return z;
    721          y = z,  z = x;
    722       }
    723    }
    724    Push(c1, y);
    725    n = (int)evCnt(ex,x) - 1;
    726    drop(c1);
    727    if (n <= 0)
    728       return y;
    729    cdr(y) = cdr(z),  cdr(z) = y;
    730    while (--n && isCell(x = cdr(y)))
    731       cdr(y) = cdr(x),  cdr(x) = z,  z = x;
    732    return z;
    733 }
    734 
    735 static any trim(any x) {
    736    any y;
    737 
    738    if (!isCell(x))
    739       return x;
    740    if (isNil(y = trim(cdr(x))) && isBlank(car(x)))
    741       return Nil;
    742    return cons(car(x),y);
    743 }
    744 
    745 // (trim 'lst) -> lst
    746 any doTrim(any x) {
    747    cell c1;
    748 
    749    x = cdr(x),  Push(c1, EVAL(car(x)));
    750    x = trim(data(c1));
    751    drop(c1);
    752    return x;
    753 }
    754 
    755 // (clip 'lst) -> lst
    756 any doClip(any x) {
    757    cell c1;
    758 
    759    x = cdr(x),  Push(c1, EVAL(car(x)));
    760    while (isCell(data(c1)) && isBlank(car(data(c1))))
    761       data(c1) = cdr(data(c1));
    762    x = trim(data(c1));
    763    drop(c1);
    764    return x;
    765 }
    766 
    767 // (head 'cnt|lst 'lst) -> lst
    768 any doHead(any ex) {
    769    long n;
    770    any x, y;
    771    cell c1, c2;
    772 
    773    x = cdr(ex);
    774    if (isNil(data(c1) = EVAL(car(x))))
    775       return Nil;
    776    x = cdr(x);
    777    if (isCell(data(c1))) {
    778       Save(c1);
    779       if (isCell(x = EVAL(car(x)))) {
    780          for (y = data(c1);  equal(car(y), car(x));  x = cdr(x))
    781             if (!isCell(y = cdr(y)))
    782                return Pop(c1);
    783       }
    784       drop(c1);
    785       return Nil;
    786    }
    787    if ((n = xCnt(ex,data(c1))) == 0)
    788       return Nil;
    789    if (!isCell(x = EVAL(car(x))))
    790       return x;
    791    if (n < 0  &&  (n += length(x)) <= 0)
    792       return Nil;
    793    Push(c1,x);
    794    Push(c2, x = cons(car(data(c1)), Nil));
    795    while (--n  &&  isCell(data(c1) = cdr(data(c1))))
    796       x = cdr(x) = cons(car(data(c1)), Nil);
    797    drop(c1);
    798    return data(c2);
    799 }
    800 
    801 // (tail 'cnt|lst 'lst) -> lst
    802 any doTail(any ex) {
    803    long n;
    804    any x, y;
    805    cell c1;
    806 
    807    x = cdr(ex);
    808    if (isNil(data(c1) = EVAL(car(x))))
    809       return Nil;
    810    x = cdr(x);
    811    if (isCell(data(c1))) {
    812       Save(c1);
    813       if (isCell(x = EVAL(car(x)))) {
    814          do
    815             if (equal(x,data(c1)))
    816                return Pop(c1);
    817          while (isCell(x = cdr(x)));
    818       }
    819       drop(c1);
    820       return Nil;
    821    }
    822    if ((n = xCnt(ex,data(c1))) == 0)
    823       return Nil;
    824    if (!isCell(x = EVAL(car(x))))
    825       return x;
    826    if (n < 0)
    827       return nth(1 - n, x);
    828    for (y = cdr(x);  --n;  y = cdr(y))
    829       if (!isCell(y))
    830          return x;
    831    while (isCell(y))
    832       x = cdr(x),  y = cdr(y);
    833    return x;
    834 }
    835 
    836 // (stem 'lst 'any ..) -> lst
    837 any doStem(any x) {
    838    int i, n = length(cdr(x = cdr(x)));
    839    cell c1, c[n];
    840 
    841    Push(c1, EVAL(car(x)));
    842    for (i = 0; i < n; ++i)
    843       x = cdr(x),  Push(c[i], EVAL(car(x)));
    844    for (x = data(c1); isCell(x); x = cdr(x)) {
    845       for (i = 0;  i < n;  ++i)
    846          if (equal(car(x), data(c[i]))) {
    847             data(c1) = cdr(x);
    848             break;
    849          }
    850    }
    851    return Pop(c1);
    852 }
    853 
    854 // (fin 'any) -> num|sym
    855 any doFin(any x) {
    856    x = cdr(x),  x = EVAL(car(x));
    857    while (isCell(x))
    858       x = cdr(x);
    859    return x;
    860 }
    861 
    862 // (last 'lst) -> any
    863 any doLast(any x) {
    864    x = cdr(x),  x = EVAL(car(x));
    865    if (!isCell(x))
    866       return x;
    867    while (isCell(cdr(x)))
    868       x = cdr(x);
    869    return car(x);
    870 }
    871 
    872 // (== 'any ..) -> flg
    873 any doEq(any x) {
    874    cell c1;
    875 
    876    x = cdr(x),  Push(c1, EVAL(car(x)));
    877    while (isCell(x = cdr(x)))
    878       if (data(c1) != EVAL(car(x))) {
    879          drop(c1);
    880          return Nil;
    881       }
    882    drop(c1);
    883    return T;
    884 }
    885 
    886 // (n== 'any ..) -> flg
    887 any doNEq(any x) {
    888    cell c1;
    889 
    890    x = cdr(x),  Push(c1, EVAL(car(x)));
    891    while (isCell(x = cdr(x)))
    892       if (data(c1) != EVAL(car(x))) {
    893          drop(c1);
    894          return T;
    895       }
    896    drop(c1);
    897    return Nil;
    898 }
    899 
    900 // (= 'any ..) -> flg
    901 any doEqual(any x) {
    902    cell c1;
    903 
    904    x = cdr(x),  Push(c1, EVAL(car(x)));
    905    while (isCell(x = cdr(x)))
    906       if (!equal(data(c1), EVAL(car(x)))) {
    907          drop(c1);
    908          return Nil;
    909       }
    910    drop(c1);
    911    return T;
    912 }
    913 
    914 // (<> 'any ..) -> flg
    915 any doNEqual(any x) {
    916    cell c1;
    917 
    918    x = cdr(x),  Push(c1, EVAL(car(x)));
    919    while (isCell(x = cdr(x)))
    920       if (!equal(data(c1), EVAL(car(x)))) {
    921          drop(c1);
    922          return T;
    923       }
    924    drop(c1);
    925    return Nil;
    926 }
    927 
    928 // (=0 'any) -> 0 | NIL
    929 any doEq0(any x) {
    930    x = cdr(x);
    931    return isNum(x = EVAL(car(x))) && IsZero(x)? x : Nil;
    932 }
    933 
    934 // (=T 'any) -> flg
    935 any doEqT(any x) {
    936    x = cdr(x);
    937    return T == EVAL(car(x))? T : Nil;
    938 }
    939 
    940 // (n0 'any) -> flg
    941 any doNEq0(any x) {
    942    x = cdr(x);
    943    return isNum(x = EVAL(car(x))) && IsZero(x)? Nil : T;
    944 }
    945 
    946 // (nT 'any) -> flg
    947 any doNEqT(any x) {
    948    x = cdr(x);
    949    return T == EVAL(car(x))? Nil : T;
    950 }
    951 
    952 // (< 'any ..) -> flg
    953 any doLt(any x) {
    954    any y;
    955    cell c1;
    956 
    957    x = cdr(x),  Push(c1, EVAL(car(x)));
    958    while (isCell(x = cdr(x))) {
    959       y = EVAL(car(x));
    960       if (compare(data(c1), y) >= 0) {
    961          drop(c1);
    962          return Nil;
    963       }
    964       data(c1) = y;
    965    }
    966    drop(c1);
    967    return T;
    968 }
    969 
    970 // (<= 'any ..) -> flg
    971 any doLe(any x) {
    972    any y;
    973    cell c1;
    974 
    975    x = cdr(x),  Push(c1, EVAL(car(x)));
    976    while (isCell(x = cdr(x))) {
    977       y = EVAL(car(x));
    978       if (compare(data(c1), y) > 0) {
    979          drop(c1);
    980          return Nil;
    981       }
    982       data(c1) = y;
    983    }
    984    drop(c1);
    985    return T;
    986 }
    987 
    988 // (> 'any ..) -> flg
    989 any doGt(any x) {
    990    any y;
    991    cell c1;
    992 
    993    x = cdr(x),  Push(c1, EVAL(car(x)));
    994    while (isCell(x = cdr(x))) {
    995       y = EVAL(car(x));
    996       if (compare(data(c1), y) <= 0) {
    997          drop(c1);
    998          return Nil;
    999       }
   1000       data(c1) = y;
   1001    }
   1002    drop(c1);
   1003    return T;
   1004 }
   1005 
   1006 // (>= 'any ..) -> flg
   1007 any doGe(any x) {
   1008    any y;
   1009    cell c1;
   1010 
   1011    x = cdr(x),  Push(c1, EVAL(car(x)));
   1012    while (isCell(x = cdr(x))) {
   1013       y = EVAL(car(x));
   1014       if (compare(data(c1), y) < 0) {
   1015          drop(c1);
   1016          return Nil;
   1017       }
   1018       data(c1) = y;
   1019    }
   1020    drop(c1);
   1021    return T;
   1022 }
   1023 
   1024 // (max 'any ..) -> any
   1025 any doMax(any x) {
   1026    any y;
   1027    cell c1;
   1028 
   1029    x = cdr(x),  Push(c1, EVAL(car(x)));
   1030    while (isCell(x = cdr(x)))
   1031       if (compare(y = EVAL(car(x)), data(c1)) > 0)
   1032          data(c1) = y;
   1033    return Pop(c1);
   1034 }
   1035 
   1036 // (min 'any ..) -> any
   1037 any doMin(any x) {
   1038    any y;
   1039    cell c1;
   1040 
   1041    x = cdr(x),  Push(c1, EVAL(car(x)));
   1042    while (isCell(x = cdr(x)))
   1043       if (compare(y = EVAL(car(x)), data(c1)) < 0)
   1044          data(c1) = y;
   1045    return Pop(c1);
   1046 }
   1047 
   1048 // (atom 'any) -> flg
   1049 any doAtom(any x) {
   1050    x = cdr(x);
   1051    return !isCell(EVAL(car(x)))? T : Nil;
   1052 }
   1053 
   1054 // (pair 'any) -> any
   1055 any doPair(any x) {
   1056    x = cdr(x);
   1057    return isCell(x = EVAL(car(x)))? x : Nil;
   1058 }
   1059 
   1060 // (circ? 'any) -> any
   1061 any doCircQ(any x) {
   1062    x = cdr(x);
   1063    return isCell(x = EVAL(car(x))) && (x = circ(x))? x : Nil;
   1064 }
   1065 
   1066 // (lst? 'any) -> flg
   1067 any doLstQ(any x) {
   1068    x = cdr(x);
   1069    return isCell(x = EVAL(car(x))) || isNil(x)? T : Nil;
   1070 }
   1071 
   1072 // (num? 'any) -> num | NIL
   1073 any doNumQ(any x) {
   1074    x = cdr(x);
   1075    return isNum(x = EVAL(car(x)))? x : Nil;
   1076 }
   1077 
   1078 // (sym? 'any) -> flg
   1079 any doSymQ(any x) {
   1080    x = cdr(x);
   1081    return isSym(EVAL(car(x)))? T : Nil;
   1082 }
   1083 
   1084 // (flg? 'any) -> flg
   1085 any doFlgQ(any x) {
   1086    x = cdr(x);
   1087    return isNil(x = EVAL(car(x))) || x==T? T : Nil;
   1088 }
   1089 
   1090 // (member 'any 'lst) -> any
   1091 any doMember(any x) {
   1092    cell c1;
   1093 
   1094    x = cdr(x),  Push(c1, EVAL(car(x)));
   1095    x = cdr(x),  x = EVAL(car(x));
   1096    return member(Pop(c1), x) ?: Nil;
   1097 }
   1098 
   1099 // (memq 'any 'lst) -> any
   1100 any doMemq(any x) {
   1101    cell c1;
   1102 
   1103    x = cdr(x),  Push(c1, EVAL(car(x)));
   1104    x = cdr(x),  x = EVAL(car(x));
   1105    return memq(Pop(c1), x) ?: Nil;
   1106 }
   1107 
   1108 // (mmeq 'lst 'lst) -> any
   1109 any doMmeq(any x) {
   1110    any y, z;
   1111    cell c1;
   1112 
   1113    x = cdr(x),  Push(c1, EVAL(car(x)));
   1114    x = cdr(x),  y = EVAL(car(x));
   1115    for (x = Pop(c1);  isCell(x);  x = cdr(x))
   1116       if (z = memq(car(x), y))
   1117          return z;
   1118    return Nil;
   1119 }
   1120 
   1121 // (sect 'lst 'lst) -> lst
   1122 any doSect(any x) {
   1123    cell c1, c2, c3;
   1124 
   1125    x = cdr(x),  Push(c1, EVAL(car(x)));
   1126    x = cdr(x),  Push(c2, EVAL(car(x)));
   1127    Push(c3, x = Nil);
   1128    while (isCell(data(c1))) {
   1129       if (member(car(data(c1)), data(c2)))
   1130          if (isNil(x))
   1131             x = data(c3) = cons(car(data(c1)), Nil);
   1132          else
   1133             x = cdr(x) = cons(car(data(c1)), Nil);
   1134       data(c1) = cdr(data(c1));
   1135    }
   1136    drop(c1);
   1137    return data(c3);
   1138 }
   1139 
   1140 // (diff 'lst 'lst) -> lst
   1141 any doDiff(any x) {
   1142    cell c1, c2, c3;
   1143 
   1144    x = cdr(x),  Push(c1, EVAL(car(x)));
   1145    x = cdr(x),  Push(c2, EVAL(car(x)));
   1146    Push(c3, x = Nil);
   1147    while (isCell(data(c1))) {
   1148       if (!member(car(data(c1)), data(c2)))
   1149          if (isNil(x))
   1150             x = data(c3) = cons(car(data(c1)), Nil);
   1151          else
   1152             x = cdr(x) = cons(car(data(c1)), Nil);
   1153       data(c1) = cdr(data(c1));
   1154    }
   1155    drop(c1);
   1156    return data(c3);
   1157 }
   1158 
   1159 // (index 'any 'lst) -> cnt | NIL
   1160 any doIndex(any x) {
   1161    int n;
   1162    cell c1;
   1163 
   1164    x = cdr(x),  Push(c1, EVAL(car(x)));
   1165    x = cdr(x),  x = EVAL(car(x));
   1166    return (n = indx(Pop(c1), x))? boxCnt(n) : Nil;
   1167 }
   1168 
   1169 // (offset 'lst1 'lst2) -> cnt | NIL
   1170 any doOffset(any x) {
   1171    int n;
   1172    any y;
   1173    cell c1;
   1174 
   1175    x = cdr(x),  Push(c1, EVAL(car(x)));
   1176    x = cdr(x),  y = EVAL(car(x));
   1177    for (n = 1, x = Pop(c1);  isCell(y);  ++n, y = cdr(y))
   1178       if (equal(x,y))
   1179          return boxCnt(n);
   1180    return Nil;
   1181 }
   1182 
   1183 // (prior 'lst1 'lst2) -> lst | NIL
   1184 any doPrior(any x) {
   1185    any y;
   1186    cell c1;
   1187 
   1188    x = cdr(x),  Push(c1, EVAL(car(x)));
   1189    x = cdr(x),  y = EVAL(car(x));
   1190    if ((x = Pop(c1)) != y)
   1191       while (isCell(y)) {
   1192          if (x == cdr(y))
   1193             return y;
   1194          y = cdr(y);
   1195       }
   1196    return Nil;
   1197 }
   1198 
   1199 // (length 'any) -> cnt | T
   1200 any doLength(any x) {
   1201    int n, c;
   1202    any y;
   1203 
   1204    if (isNum(x = EVAL(cadr(x))))
   1205       return numToSym(x, 0, -1, 0);
   1206    if (isSym(x)) {
   1207       for (n = 0, c = symChar(name(x));  c;  ++n, c = symChar(NULL));
   1208       return boxCnt(n);
   1209    }
   1210    for (n = 0, y = x;;) {
   1211       ++n;
   1212       *(word*)&car(y) |= 1;
   1213       if (!isCell(y = cdr(y))) {
   1214          do
   1215             *(word*)&car(x) &= ~1;
   1216          while (isCell(x = cdr(x)));
   1217          return boxCnt(n);
   1218       }
   1219       if (num(car(y)) & 1) {
   1220          while (x != y)
   1221             *(word*)&car(x) &= ~1,  x = cdr(x);
   1222          do
   1223             *(word*)&car(x) &= ~1;
   1224          while (y != (x = cdr(x)));
   1225          return T;
   1226       }
   1227    }
   1228 }
   1229 
   1230 static int size(any x) {
   1231    int n;
   1232    any y;
   1233 
   1234    for (n = 0, y = x;;) {
   1235       ++n;
   1236       if (isCell(car(y)))
   1237          n += size(car(y));
   1238       *(word*)&car(y) |= 1;
   1239       if (!isCell(y = cdr(y))) {
   1240          do
   1241             *(word*)&car(x) &= ~1;
   1242          while (isCell(x = cdr(x)));
   1243          return n;
   1244       }
   1245       if (num(car(y)) & 1) {
   1246          while (x != y)
   1247             *(word*)&car(x) &= ~1,  x = cdr(x);
   1248          do
   1249             *(word*)&car(x) &= ~1;
   1250          while (y != (x = cdr(x)));
   1251          return n;
   1252       }
   1253    }
   1254 }
   1255 
   1256 // (size 'any) -> cnt
   1257 any doSize(any ex) {
   1258    any x = cdr(ex);
   1259 
   1260    if (isNum(x = EVAL(car(x))))
   1261       return boxCnt(numBytes(x));
   1262    if (!isSym(x))
   1263       return boxCnt(size(x));
   1264    if (isExt(x))
   1265       return boxCnt(dbSize(ex,x));
   1266    return isNum(x = name(x))? boxCnt(numBytes(x)) : Zero;
   1267 }
   1268 
   1269 // (bytes 'any) -> cnt
   1270 any doBytes(any x) {
   1271    return boxCnt(binSize(EVAL(cadr(x))));
   1272 }
   1273 
   1274 // (assoc 'any 'lst) -> lst
   1275 any doAssoc(any x) {
   1276    any y;
   1277    cell c1;
   1278 
   1279    x = cdr(x),  Push(c1, EVAL(car(x)));
   1280    x = cdr(x),  y = EVAL(car(x));
   1281    for (x = Pop(c1);  isCell(y);  y = cdr(y))
   1282       if (isCell(car(y)) && equal(x,caar(y)))
   1283          return car(y);
   1284    return Nil;
   1285 }
   1286 
   1287 // (asoq 'any 'lst) -> lst
   1288 any doAsoq(any x) {
   1289    any y;
   1290    cell c1;
   1291 
   1292    x = cdr(x),  Push(c1, EVAL(car(x)));
   1293    x = cdr(x),  y = EVAL(car(x));
   1294    for (x = Pop(c1);  isCell(y);  y = cdr(y))
   1295       if (isCell(car(y)) && x == caar(y))
   1296          return car(y);
   1297    return Nil;
   1298 }
   1299 
   1300 static any Rank;
   1301 
   1302 any rank1(any lst, int n) {
   1303    int i;
   1304 
   1305    if (isCell(car(lst)) && compare(caar(lst), Rank) > 0)
   1306       return NULL;
   1307    if (n == 1)
   1308       return car(lst);
   1309    i = n / 2;
   1310    return rank1(nCdr(i,lst), n-i) ?: rank1(lst, i);
   1311 }
   1312 
   1313 any rank2(any lst, int n) {
   1314    int i;
   1315 
   1316    if (isCell(car(lst)) && compare(Rank, caar(lst)) > 0)
   1317       return NULL;
   1318    if (n == 1)
   1319       return car(lst);
   1320    i = n / 2;
   1321    return rank2(nCdr(i,lst), n-i) ?: rank2(lst, i);
   1322 }
   1323 
   1324 // (rank 'any 'lst ['flg]) -> lst
   1325 any doRank(any x) {
   1326    any y;
   1327    cell c1, c2;
   1328 
   1329    x = cdr(x),  Push(c1, EVAL(car(x)));
   1330    x = cdr(x),  Push(c2, y = EVAL(car(x)));
   1331    x = cdr(x),  x = EVAL(car(x));
   1332    Rank = Pop(c1);
   1333    if (isCell(y))
   1334       return (isNil(x)? rank1(y, length(y)) : rank2(y, length(y))) ?: Nil;
   1335    return Nil;
   1336 }
   1337 
   1338 /* Pattern matching */
   1339 bool match(any p, any d) {
   1340    any x;
   1341 
   1342    for (;;) {
   1343       if (!isCell(p)) {
   1344          if (isSym(p)  &&  firstByte(p) == '@') {
   1345             val(p) = d;
   1346             return YES;
   1347          }
   1348          return equal(p,d);
   1349       }
   1350       if (isSym(x = car(p))  &&  firstByte(x) == '@') {
   1351          if (!isCell(d)) {
   1352             if (equal(d, cdr(p))) {
   1353                val(x) = Nil;
   1354                return YES;
   1355             }
   1356             return NO;
   1357          }
   1358          if (match(cdr(p), cdr(d))) {
   1359             val(x) = cons(car(d), Nil);
   1360             return YES;
   1361          }
   1362          if (match(cdr(p), d)) {
   1363             val(x) = Nil;
   1364             return YES;
   1365          }
   1366          if (match(p, cdr(d))) {
   1367             val(x) = cons(car(d), val(x));
   1368             return YES;
   1369          }
   1370       }
   1371       if (!isCell(d) || !match(x, car(d)))
   1372          return NO;
   1373       p = cdr(p);
   1374       d = cdr(d);
   1375    }
   1376 }
   1377 
   1378 // (match 'lst1 'lst2) -> flg
   1379 any doMatch(any x) {
   1380    cell c1, c2;
   1381 
   1382    x = cdr(x),  Push(c1, EVAL(car(x)));
   1383    x = cdr(x),  Push(c2, EVAL(car(x)));
   1384    x = match(data(c1), data(c2))? T : Nil;
   1385    drop(c1);
   1386    return x;
   1387 }
   1388 
   1389 // Fill template structure
   1390 static any fill(any x, any s) {
   1391    any y;
   1392    cell c1;
   1393 
   1394    if (isNum(x))
   1395       return NULL;
   1396    if (isSym(x))
   1397       return x != val(x) && (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? val(x) : NULL;
   1398    if (car(x) == Up) {
   1399       x = cdr(x);
   1400       if (!isCell(y = EVAL(car(x))))
   1401          return fill(cdr(x), s) ?: cdr(x);
   1402       Push(c1, y);
   1403       while (isCell(cdr(y)))
   1404          y = cdr(y);
   1405       cdr(y) = fill(cdr(x), s) ?: cdr(x);
   1406       return Pop(c1);
   1407    }
   1408    if (y = fill(car(x), s)) {
   1409       Push(c1,y);
   1410       y = fill(cdr(x), s);
   1411       return cons(Pop(c1), y ?: cdr(x));
   1412    }
   1413    if (y = fill(cdr(x), s))
   1414       return cons(car(x), y);
   1415    return NULL;
   1416 }
   1417 
   1418 // (fill 'any ['sym|lst]) -> any
   1419 any doFill(any x) {
   1420    cell c1, c2;
   1421 
   1422    x = cdr(x),  Push(c1, EVAL(car(x)));
   1423    x = cdr(x),  Push(c2, EVAL(car(x)));
   1424    if (x = fill(data(c1), data(c2))) {
   1425       drop(c1);
   1426       return x;
   1427    }
   1428    return Pop(c1);
   1429 }
   1430 
   1431 /* Declarative Programming */
   1432 cell *Penv, *Pnl;
   1433 
   1434 static bool unify(any n1, any x1, any n2, any x2) {
   1435    any x, env;
   1436 
   1437 lookup1:
   1438    if (isSym(x1)  &&  firstByte(x1) == '@')
   1439       for (x = data(*Penv);  isCell(car(x));  x = cdr(x))
   1440          if (unDig(n1) == unDig(caaar(x))  &&  x1 == cdaar(x)) {
   1441             n1 = cadar(x);
   1442             x1 = cddar(x);
   1443             goto lookup1;
   1444          }
   1445 lookup2:
   1446    if (isSym(x2)  &&  firstByte(x2) == '@')
   1447       for (x = data(*Penv);  isCell(car(x));  x = cdr(x))
   1448          if (unDig(n2) == unDig(caaar(x))  &&  x2 == cdaar(x)) {
   1449             n2 = cadar(x);
   1450             x2 = cddar(x);
   1451             goto lookup2;
   1452          }
   1453    if (unDig(n1) == unDig(n2)  &&  equal(x1, x2))
   1454       return YES;
   1455    if (isSym(x1)  &&  firstByte(x1) == '@') {
   1456       if (x1 != At) {
   1457          data(*Penv) = cons(cons(cons(n1,x1), Nil), data(*Penv));
   1458          cdar(data(*Penv)) = cons(n2,x2);
   1459       }
   1460       return YES;
   1461    }
   1462    if (isSym(x2)  &&  firstByte(x2) == '@') {
   1463       if (x2 != At) {
   1464          data(*Penv) = cons(cons(cons(n2,x2), Nil), data(*Penv));
   1465          cdar(data(*Penv)) = cons(n1,x1);
   1466       }
   1467       return YES;
   1468    }
   1469    if (!isCell(x1) || !isCell(x2))
   1470       return equal(x1, x2);
   1471    env = data(*Penv);
   1472    if (unify(n1, car(x1), n2, car(x2))  &&  unify(n1, cdr(x1), n2, cdr(x2)))
   1473       return YES;
   1474    data(*Penv) = env;
   1475    return NO;
   1476 }
   1477 
   1478 static any lup(any n, any x) {
   1479    any y;
   1480    cell c1;
   1481 
   1482 lup:
   1483    if (isSym(x)  &&  firstByte(x) == '@')
   1484       for (y = data(*Penv);  isCell(car(y));  y = cdr(y))
   1485          if (unDig(n) == unDig(caaar(y))  &&  x == cdaar(y)) {
   1486             n = cadar(y);
   1487             x = cddar(y);
   1488             goto lup;
   1489          }
   1490    if (!isCell(x))
   1491       return x;
   1492    Push(c1, lup(n, car(x)));
   1493    x = lup(n, cdr(x));
   1494    return cons(Pop(c1), x);
   1495 }
   1496 
   1497 static any lookup(any n, any x) {
   1498    return isSym(x = lup(n,x)) && firstByte(x)=='@'?  Nil : x;
   1499 }
   1500 
   1501 static any uniFill(any x) {
   1502    cell c1;
   1503 
   1504    if (isNum(x))
   1505       return x;
   1506    if (isSym(x))
   1507       return lup(car(data(*Pnl)), x);
   1508    Push(c1, uniFill(car(x)));
   1509    x = uniFill(cdr(x));
   1510    return cons(Pop(c1), x);
   1511 }
   1512 
   1513 // (prove 'lst ['lst]) -> lst
   1514 any doProve(any x) {
   1515    int i;
   1516    cell *envSave, *nlSave, at, q, dbg, env, n, nl, alt, tp1, tp2, e;
   1517 
   1518    x = cdr(x);
   1519    if (!isCell(data(q) = EVAL(car(x))))
   1520       return Nil;
   1521    Save(q);
   1522    Push(at,val(At));
   1523    envSave = Penv,  Penv = &env,  nlSave = Pnl,  Pnl = &nl;
   1524    if (x = cdr(x), isNil(x = EVAL(car(x))))
   1525       data(dbg) = NULL;
   1526    else
   1527       Push(dbg, x);
   1528    Push(env, caar(data(q))),  car(data(q)) = cdar(data(q));
   1529    Push(n, car(data(env))),  data(env) = cdr(data(env));
   1530    Push(nl, car(data(env))),  data(env) = cdr(data(env));
   1531    Push(alt, car(data(env))),  data(env) = cdr(data(env));
   1532    Push(tp1, car(data(env))),  data(env) = cdr(data(env));
   1533    Push(tp2, car(data(env))),  data(env) = cdr(data(env));
   1534    Push(e,Nil);
   1535    while (isCell(data(tp1)) || isCell(data(tp2))) {
   1536       if (isCell(data(alt))) {
   1537          data(e) = data(env);
   1538          if (!unify(car(data(nl)), cdar(data(tp1)), data(n), caar(data(alt)))) {
   1539             if (!isCell(data(alt) = cdr(data(alt)))) {
   1540                data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
   1541                data(n) = car(data(env)),  data(env) = cdr(data(env));
   1542                data(nl) = car(data(env)),  data(env) = cdr(data(env));
   1543                data(alt) = car(data(env)),  data(env) = cdr(data(env));
   1544                data(tp1) = car(data(env)),  data(env) = cdr(data(env));
   1545                data(tp2) = car(data(env)),  data(env) = cdr(data(env));
   1546             }
   1547          }
   1548          else {
   1549             if (data(dbg)  &&  memq(caar(data(tp1)), data(dbg))) {
   1550                outWord(indx(car(data(alt)), get(caar(data(tp1)), T)));
   1551                space();
   1552                print(uniFill(car(data(tp1)))), newline();
   1553             }
   1554             if (isCell(cdr(data(alt))))
   1555                car(data(q)) =
   1556                   cons(
   1557                      cons(data(n),
   1558                         cons(data(nl),
   1559                            cons(cdr(data(alt)),
   1560                               cons(data(tp1), cons(data(tp2),data(e))) ) ) ),
   1561                      car(data(q)) );
   1562             data(nl) = cons(data(n), data(nl));
   1563             data(n) = box(2 + unDig(data(n)));
   1564             data(tp2) = cons(cdr(data(tp1)), data(tp2));
   1565             data(tp1) = cdar(data(alt));
   1566             data(alt) = Nil;
   1567          }
   1568       }
   1569       else if (!isCell(x = data(tp1))) {
   1570          data(tp1) = car(data(tp2)),  data(tp2) = cdr(data(tp2));
   1571          data(nl) = cdr(data(nl));
   1572       }
   1573       else if (car(x) == T) {
   1574          while (isCell(car(data(q)))  &&
   1575                               unDig(caaar(data(q))) >= unDig(car(data(nl))) )
   1576             car(data(q)) = cdar(data(q));
   1577          data(tp1) = cdr(x);
   1578       }
   1579       else if (isNum(caar(x))) {
   1580          data(e) = prog(cdar(x));
   1581          for (i = unDig(caar(x)), x = data(nl);  (i -= 2) > 0;)
   1582             x = cdr(x);
   1583          data(nl) = cons(car(x), data(nl));
   1584          data(tp2) = cons(cdr(data(tp1)), data(tp2));
   1585          data(tp1) = data(e);
   1586       }
   1587       else if (caar(x) == Up) {
   1588          if (!isNil(data(e) = prog(cddar(x)))  &&
   1589                      unify(car(data(nl)), cadar(x), car(data(nl)), data(e)) )
   1590             data(tp1) = cdr(x);
   1591          else {
   1592             data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
   1593             data(n) = car(data(env)),  data(env) = cdr(data(env));
   1594             data(nl) = car(data(env)),  data(env) = cdr(data(env));
   1595             data(alt) = car(data(env)),  data(env) = cdr(data(env));
   1596             data(tp1) = car(data(env)),  data(env) = cdr(data(env));
   1597             data(tp2) = car(data(env)),  data(env) = cdr(data(env));
   1598          }
   1599       }
   1600       else if (!isCell(data(alt) = get(caar(x), T))) {
   1601          data(env) = caar(data(q)),  car(data(q)) = cdar(data(q));
   1602          data(n) = car(data(env)),  data(env) = cdr(data(env));
   1603          data(nl) = car(data(env)),  data(env) = cdr(data(env));
   1604          data(alt) = car(data(env)),  data(env) = cdr(data(env));
   1605          data(tp1) = car(data(env)),  data(env) = cdr(data(env));
   1606          data(tp2) = car(data(env)),  data(env) = cdr(data(env));
   1607       }
   1608    }
   1609    for (data(e) = Nil,  x = data(env);  isCell(cdr(x));  x = cdr(x))
   1610       if (!unDig(caaar(x)))
   1611          data(e) = cons(cons(cdaar(x), lookup(Zero, cdaar(x))), data(e));
   1612    val(At) = data(at);
   1613    drop(q);
   1614    Penv = envSave,  Pnl = nlSave;
   1615    return isCell(data(e))? data(e) : isCell(data(env))? T : Nil;
   1616 }
   1617 
   1618 // (-> any [num]) -> any
   1619 any doArrow(any x) {
   1620    int i;
   1621    any y;
   1622 
   1623    if (!isNum(caddr(x)))
   1624       return lookup(car(data(*Pnl)), cadr(x));
   1625    for (i = unDig(caddr(x)), y = data(*Pnl);  (i -= 2) > 0;)
   1626       y = cdr(y);
   1627    return lookup(car(y), cadr(x));
   1628 }
   1629 
   1630 // (unify 'any) -> lst
   1631 any doUnify(any x) {
   1632    cell c1;
   1633 
   1634    Push(c1, EVAL(cadr(x)));
   1635    if (unify(cadr(data(*Pnl)), data(c1), car(data(*Pnl)), data(c1))) {
   1636       drop(c1);
   1637       return data(*Penv);
   1638    }
   1639    drop(c1);
   1640    return Nil;
   1641 }
   1642 
   1643 /* List Merge Sort: Bill McDaniel, DDJ Jun99 */
   1644 static bool cmp(any ex, any foo, cell c[2]) {
   1645    if (isNil(foo))
   1646       return compare(car(data(c[0])), car(data(c[1]))) < 0;
   1647    return !isNil(apply(ex, foo, YES, 2, c));
   1648 }
   1649 
   1650 // (sort 'lst ['fun]) -> lst
   1651 any doSort(any ex) {
   1652    int i;
   1653    any x;
   1654    cell p, foo, in[2], out[2], last[2];
   1655    any *tail[2];
   1656 
   1657    x = cdr(ex);
   1658    if (!isCell(data(out[0]) = EVAL(car(x))))
   1659       return data(out[0]);
   1660    Save(out[0]);
   1661    x = cdr(x),  Push(foo, EVAL(car(x)));
   1662    Push(out[1], Nil);
   1663    Save(in[0]);
   1664    Save(in[1]);
   1665    Push(p, Nil);
   1666    Push(last[1], Nil);
   1667    do {
   1668       data(in[0]) = data(out[0]);
   1669       data(in[1]) = data(out[1]);
   1670 
   1671       i = isCell(data(in[1]))  &&  !cmp(ex, data(foo), in);
   1672       if (isCell(data(p) = data(in[i])))
   1673          data(in[i]) = cdr(data(in[i]));
   1674       data(out[0]) = data(p);
   1675       tail[0] = &cdr(data(p));
   1676       data(last[1]) = data(out[0]);
   1677       cdr(data(p)) = Nil;
   1678       i = 0;
   1679       data(out[1]) = Nil;
   1680       tail[1] = &data(out[1]);
   1681       while (isCell(data(in[0])) || isCell(data(in[1]))) {
   1682          if (!isCell(data(in[1]))) {
   1683             if (isCell(data(p) = data(in[0])))
   1684                data(in[0]) = cdr(data(in[0]));
   1685             data(last[0]) = data(p);
   1686             if (cmp(ex, data(foo), last))
   1687                i = 1 - i;
   1688          }
   1689          else if (!isCell(data(in[0]))) {
   1690             data(last[0]) = data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
   1691             if (cmp(ex, data(foo), last))
   1692                i = 1 - i;
   1693          }
   1694          else if (data(last[0]) = data(in[0]),  cmp(ex, data(foo), last)) {
   1695             data(last[0]) = data(in[1]);
   1696             if (!cmp(ex, data(foo), last))
   1697                data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
   1698             else {
   1699                if (cmp(ex, data(foo), in))
   1700                   data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
   1701                else
   1702                   data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
   1703                i = 1 - i;
   1704             }
   1705          }
   1706          else {
   1707             data(last[0]) = data(in[1]);
   1708             if (cmp(ex, data(foo), last))
   1709                data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
   1710             else {
   1711                if (cmp(ex, data(foo), in))
   1712                   data(p) = data(in[0]),  data(in[0]) = cdr(data(in[0]));
   1713                else
   1714                   data(p) = data(in[1]),  data(in[1]) = cdr(data(in[1]));
   1715             }
   1716          }
   1717          *tail[i] = data(p);
   1718          tail[i] = &cdr(data(p));
   1719          cdr(data(p)) = Nil;
   1720          data(last[1]) = data(p);
   1721       }
   1722    } while (isCell(data(out[1])));
   1723    return Pop(out[0]);
   1724 }
	picolisp Unnamed repository; edit this file to name it for gitweb.
	git clone https://logand.com/git/picolisp.git/
	Log \| Files \| Refs \| README \| LICENSE