subr.c - mplisp - miniPicoLisp with FFI and modules for Buddy BDD library, OpenGL, Gtk and GMP

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