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

flow.c (31150B)
      1 /* 30oct07abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 static void redefMsg(any x, any y) {
      8    FILE *oSave = OutFile;
      9 
     10    OutFile = stderr;
     11    outString("# ");
     12    print(x);
     13    if (y)
     14       space(), print(y);
     15    outString(" redefined\n");
     16    OutFile = oSave;
     17 }
     18 
     19 static void redefine(any ex, any s, any x) {
     20    NeedSymb(ex,s);
     21    CheckVar(ex,s);
     22    if (!isNil(val(s))  &&  s != val(s)  &&  !equal(x,val(s)))
     23       redefMsg(s,NULL);
     24    val(s) = x;
     25 }
     26 
     27 // (quote . any) -> any
     28 any doQuote(any x) {return cdr(x);}
     29 
     30 // (as 'any1 . any2) -> any2 | NIL
     31 any doAs(any x) {
     32    x = cdr(x);
     33    if (isNil(EVAL(car(x))))
     34       return Nil;
     35    return cdr(x);
     36 }
     37 
     38 // (lit 'any) -> any
     39 any doLit(any x) {
     40    x = cadr(x);
     41    if (isNum(x = EVAL(x)) || isSym(x) && x==val(x) || isCell(x) && isNum(car(x)))
     42       return x;
     43    return cons(Quote, x);
     44 }
     45 
     46 // (eval 'any ['cnt]) -> any
     47 any doEval(any x) {
     48    cell c1;
     49    bindFrame *p;
     50 
     51    x = cdr(x),  Push(c1, EVAL(car(x))),  x = cdr(x);
     52    if (!isNum(x = EVAL(car(x))) || !(p = Env.bind))
     53       data(c1) = EVAL(data(c1));
     54    else {
     55       int cnt, n, i;
     56       bindFrame *q;
     57 
     58       for (cnt = (int)unBox(x), n = 0;;) {
     59          ++n;
     60          if (p->i <= 0) {
     61             if (p->i-- == 0) {
     62                for (i = 0;  i < p->cnt;  ++i) {
     63                   x = val(p->bnd[i].sym);
     64                   val(p->bnd[i].sym) = p->bnd[i].val;
     65                   p->bnd[i].val = x;
     66                }
     67                if (p->cnt  &&  p->bnd[0].sym == At  &&  !--cnt)
     68                   break;
     69             }
     70          }
     71          if (!(q = Env.bind->link))
     72             break;
     73          Env.bind->link = q->link,  q->link = p,  p = q;
     74       }
     75       Env.bind = p;
     76       data(c1) = EVAL(data(c1));
     77       for (;;) {
     78          if (p->i < 0) {
     79             if (++p->i == 0)
     80                for (i = p->cnt;  --i >= 0;) {
     81                   x = val(p->bnd[i].sym);
     82                   val(p->bnd[i].sym) = p->bnd[i].val;
     83                   p->bnd[i].val = x;
     84                }
     85          }
     86          if (!--n)
     87             break;
     88          q = Env.bind->link, Env.bind->link = q->link,  q->link = p,  p = q;
     89       }
     90       Env.bind = p;
     91    }
     92    return Pop(c1);
     93 }
     94 
     95 // (run 'any ['cnt]) -> any
     96 any doRun(any x) {
     97    cell c1;
     98    bindFrame *p;
     99 
    100    x = cdr(x),  data(c1) = EVAL(car(x)),  x = cdr(x);
    101    if (!isNum(data(c1))) {
    102       Save(c1);
    103       if (!isNum(x = EVAL(car(x))) || !(p = Env.bind))
    104          data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1));
    105       else {
    106          int cnt, n, i;
    107          bindFrame *q;
    108 
    109          for (cnt = (int)unBox(x), n = 0;;) {
    110             ++n;
    111             if (p->i <= 0) {
    112                if (p->i-- == 0) {
    113                   for (i = 0;  i < p->cnt;  ++i) {
    114                      x = val(p->bnd[i].sym);
    115                      val(p->bnd[i].sym) = p->bnd[i].val;
    116                      p->bnd[i].val = x;
    117                   }
    118                   if (p->cnt  &&  p->bnd[0].sym==At  &&  !--cnt)
    119                      break;
    120                }
    121             }
    122             if (!(q = Env.bind->link))
    123                break;
    124             Env.bind->link = q->link,  q->link = p,  p = q;
    125          }
    126          Env.bind = p;
    127          data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1));
    128          for (;;) {
    129             if (p->i < 0) {
    130                if (++p->i == 0)
    131                   for (i = p->cnt;  --i >= 0;) {
    132                      x = val(p->bnd[i].sym);
    133                      val(p->bnd[i].sym) = p->bnd[i].val;
    134                      p->bnd[i].val = x;
    135                   }
    136             }
    137             if (!--n)
    138                break;
    139             q = Env.bind->link, Env.bind->link = q->link,  q->link = p,  p = q;
    140          }
    141          Env.bind = p;
    142       }
    143       drop(c1);
    144    }
    145    return data(c1);
    146 }
    147 
    148 // (def 'sym 'any) -> sym
    149 // (def 'sym 'sym 'any) -> sym
    150 any doDef(any ex) {
    151    any x, y;
    152    cell c1, c2, c3;
    153 
    154    x = cdr(ex),  Push(c1, EVAL(car(x)));
    155    NeedSymb(ex,data(c1));
    156    CheckVar(ex,data(c1));
    157    x = cdr(x),  Push(c2, EVAL(car(x)));
    158    if (!isCell(cdr(x))) {
    159       if (!equal(data(c2), y = val(data(c1)))) {
    160          if (!isNil(y)  &&  data(c1) != y)
    161             redefMsg(data(c1),NULL);
    162          val(data(c1)) = data(c2);
    163       }
    164    }
    165    else {
    166       x = cdr(x),  Push(c3, EVAL(car(x)));
    167       if (!equal(data(c3), y = get(data(c1), data(c2)))) {
    168          if (!isNil(y))
    169             redefMsg(data(c1), data(c2));
    170          put(data(c1), data(c2), data(c3));
    171       }
    172    }
    173    return Pop(c1);
    174 }
    175 
    176 // (de sym . any) -> sym
    177 any doDe(any ex) {
    178    redefine(ex, cadr(ex), cddr(ex));
    179    return cadr(ex);
    180 }
    181 
    182 // (dm sym . fun) -> sym
    183 // (dm (sym . cls) . fun) -> sym
    184 // (dm (sym sym [. cls]) . fun) -> sym
    185 any doDm(any ex) {
    186    any x, y, msg, cls;
    187 
    188    x = cdr(ex);
    189    if (!isCell(car(x)))
    190       msg = car(x),  cls = val(Class);
    191    else {
    192       msg = caar(x);
    193       cls = !isCell(cdar(x))? cdar(x) :
    194          get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x));
    195    }
    196    if (msg != T)
    197       redefine(ex, msg, val(Meth));
    198    if (isSymb(cdr(x))) {
    199       y = val(cdr(x));
    200       for (;;) {
    201          if (!isCell(y) || !isCell(car(y)))
    202             err(ex, msg, "Bad message");
    203          if (caar(y) == msg) {
    204             x = car(y);
    205             break;
    206          }
    207          y = cdr(y);
    208       }
    209    }
    210    for (y = val(cls);  isCell(y) && isCell(car(y));  y = cdr(y))
    211       if (caar(y) == msg) {
    212          if (!equal(cdr(x), cdar(y)))
    213             redefMsg(msg,cls);
    214          cdar(y) = cdr(x);
    215          return msg;
    216       }
    217    if (!isCell(car(x)))
    218       val(cls) = cons(x, val(cls));
    219    else
    220       val(cls) = cons(cons(caar(x), cdr(x)), val(cls));
    221    return msg;
    222 }
    223 
    224 /* Evaluate method invocation */
    225 static any evMethod(any o, any expr, any x) {
    226    any y = car(expr);
    227    methFrame m;
    228    struct {  // bindFrame
    229       struct bindFrame *link;
    230       int i, cnt;
    231       struct {any sym; any val;} bnd[length(y)+3];
    232    } f;
    233 
    234    m.link = Env.meth;
    235    m.key = TheKey;
    236    m.cls = TheCls;
    237    f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    238    f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2;
    239    f.cnt = 1,  f.bnd[0].sym = At,  f.bnd[0].val = val(At);
    240    while (isCell(y)) {
    241       f.bnd[f.cnt].sym = car(y);
    242       f.bnd[f.cnt].val = EVAL(car(x));
    243       ++f.cnt, x = cdr(x), y = cdr(y);
    244    }
    245    if (isNil(y)) {
    246       while (--f.i > 0) {
    247          x = val(f.bnd[f.i].sym);
    248          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    249          f.bnd[f.i].val = x;
    250       }
    251       f.bnd[f.cnt].sym = This;
    252       f.bnd[f.cnt++].val = val(This);
    253       val(This) = o;
    254       Env.meth = &m;
    255       x = prog(cdr(expr));
    256    }
    257    else if (y != At) {
    258       f.bnd[f.cnt].sym = y,  f.bnd[f.cnt++].val = val(y),  val(y) = x;
    259       while (--f.i > 0) {
    260          x = val(f.bnd[f.i].sym);
    261          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    262          f.bnd[f.i].val = x;
    263       }
    264       f.bnd[f.cnt].sym = This,  f.bnd[f.cnt++].val = val(This),  val(This) = o;
    265       Env.meth = &m;
    266       x = prog(cdr(expr));
    267    }
    268    else {
    269       int n, cnt;
    270       cell *arg;
    271       cell c[n = cnt = length(x)];
    272 
    273       while (--n >= 0)
    274          Push(c[n], EVAL(car(x))),  x = cdr(x);
    275       while (--f.i > 0) {
    276          x = val(f.bnd[f.i].sym);
    277          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    278          f.bnd[f.i].val = x;
    279       }
    280       n = Env.next,  Env.next = cnt;
    281       arg = Env.arg,  Env.arg = c;
    282       f.bnd[f.cnt].sym = This;
    283       f.bnd[f.cnt++].val = val(This);
    284       val(This) = o;
    285       Env.meth = &m;
    286       x = prog(cdr(expr));
    287       if (cnt)
    288          drop(c[cnt-1]);
    289       Env.arg = arg,  Env.next = n;
    290    }
    291    while (--f.cnt >= 0)
    292       val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    293    Env.bind = f.link;
    294    Env.meth = Env.meth->link;
    295    return x;
    296 }
    297 
    298 any method(any x) {
    299    any y, z;
    300 
    301    if (isCell(y = val(x))) {
    302       if (isCell(car(y))) {
    303          if (caar(y) == TheKey)
    304             return cdar(y);
    305          for (;;) {
    306             z = y;
    307             if (!isCell(y = cdr(y)))
    308                return NULL;
    309             if (!isCell(car(y)))
    310                break;
    311             if (caar(y) == TheKey) {
    312                cdr(z) = cdr(y),  cdr(y) = val(x),  val(x) = y;
    313                return cdar(y);
    314             }
    315          }
    316       }
    317       do
    318          if (x = method(car(TheCls = y)))
    319             return x;
    320       while (isCell(y = cdr(y)));
    321    }
    322    return NULL;
    323 }
    324 
    325 // (box 'any) -> sym
    326 any doBox(any x) {
    327    x = cdr(x);
    328    return consSym(EVAL(car(x)),0);
    329 }
    330 
    331 // (new ['typ ['any ..]]) -> obj
    332 any doNew(any ex) {
    333    any x, y;
    334    cell c1, c2;
    335 
    336    x = cdr(ex);
    337    Push(c1, consSym(EVAL(car(x)),0));
    338    TheKey = T,  TheCls = Nil;
    339    if (y = method(data(c1)))
    340       evMethod(data(c1), y, cdr(x));
    341    else {
    342       Save(c2);
    343       while (isCell(x = cdr(x))) {
    344          data(c2) = EVAL(car(x)),  x = cdr(x);
    345          put(data(c1), data(c2), EVAL(car(x)));
    346       }
    347    }
    348    return Pop(c1);
    349 }
    350 
    351 // (type 'any) -> lst
    352 any doType(any ex) {
    353    any x, y, z;
    354 
    355    x = cdr(ex),  x = EVAL(car(x));
    356    if (isSymb(x)) {
    357       z = x = val(x);
    358       while (isCell(x)) {
    359          if (!isCell(car(x))) {
    360             y = x;
    361             while (isSymb(car(x))) {
    362                if (!isCell(x = cdr(x)))
    363                   return isNil(x)? y : Nil;
    364                if (z == x)
    365                   return Nil;
    366             }
    367             return Nil;
    368          }
    369          if (z == (x = cdr(x)))
    370             return Nil;
    371       }
    372    }
    373    return Nil;
    374 }
    375 
    376 static bool isa(any ex, any cls, any x) {
    377    any z;
    378 
    379    z = x = val(x);
    380    while (isCell(x)) {
    381       if (!isCell(car(x))) {
    382          while (isSymb(car(x))) {
    383             if (cls == car(x) || isa(ex, cls, car(x)))
    384                return YES;
    385             if (!isCell(x = cdr(x)) || z == x)
    386                return NO;
    387          }
    388          return NO;
    389       }
    390       if (z == (x = cdr(x)))
    391          return NO;
    392    }
    393    return NO;
    394 }
    395 
    396 // (isa 'cls|typ 'any) -> obj | NIL
    397 any doIsa(any ex) {
    398    any x;
    399    cell c1;
    400 
    401    x = cdr(ex),  Push(c1, EVAL(car(x)));
    402    x = cdr(x),  x = EVAL(car(x));
    403    drop(c1);
    404    if (isSymb(x)) {
    405       if (isSymb(data(c1)))
    406          return isa(ex, data(c1), x)? x : Nil;
    407       while (isCell(data(c1))) {
    408          if (!isa(ex, car(data(c1)), x))
    409             return Nil;
    410          data(c1) = cdr(data(c1));
    411       }
    412       return x;
    413    }
    414    return Nil;
    415 }
    416 
    417 // (method 'msg 'obj) -> fun
    418 any doMethod(any ex) {
    419    any x, y;
    420 
    421    x = cdr(ex),  y = EVAL(car(x));
    422    x = cdr(x),  x = EVAL(car(x));
    423    TheKey = y;
    424    return method(x)? : Nil;
    425 }
    426 
    427 // (meth 'obj ..) -> any
    428 any doMeth(any ex) {
    429    any x, y;
    430    cell c1;
    431 
    432    x = cdr(ex),  Push(c1, EVAL(car(x)));
    433    NeedSymb(ex,data(c1));
    434    for (TheKey = car(ex); ; TheKey = val(TheKey)) {
    435       if (!isSymb(TheKey))
    436          err(ex, car(ex), "Bad message");
    437       if (isNum(val(TheKey))) {
    438          TheCls = Nil;
    439          if (y = method(data(c1))) {
    440             x = evMethod(data(c1), y, cdr(x));
    441             drop(c1);
    442             return x;
    443          }
    444          err(ex, TheKey, "Bad message");
    445       }
    446    }
    447 }
    448 
    449 // (send 'msg 'obj ['any ..]) -> any
    450 any doSend(any ex) {
    451    any x, y;
    452    cell c1, c2;
    453 
    454    x = cdr(ex),  Push(c1,  EVAL(car(x)));
    455    NeedSymb(ex,data(c1));
    456    x = cdr(x),  Push(c2,  EVAL(car(x)));
    457    NeedSymb(ex,data(c2));
    458    TheKey = data(c1),  TheCls = Nil;
    459    if (y = method(data(c2))) {
    460       x = evMethod(data(c2), y, cdr(x));
    461       drop(c1);
    462       return x;
    463    }
    464    err(ex, TheKey, "Bad message");
    465 }
    466 
    467 // (try 'msg 'obj ['any ..]) -> any
    468 any doTry(any ex) {
    469    any x, y;
    470    cell c1, c2;
    471 
    472    x = cdr(ex),  Push(c1,  EVAL(car(x)));
    473    NeedSymb(ex,data(c1));
    474    x = cdr(x),  Push(c2,  EVAL(car(x)));
    475    if (isSymb(data(c2))) {
    476       TheKey = data(c1),  TheCls = Nil;
    477       if (y = method(data(c2))) {
    478          x = evMethod(data(c2), y, cdr(x));
    479          drop(c1);
    480          return x;
    481       }
    482    }
    483    drop(c1);
    484    return Nil;
    485 }
    486 
    487 // (super ['any ..]) -> any
    488 any doSuper(any ex) {
    489    any x, y;
    490    methFrame m;
    491 
    492    m.key = TheKey = Env.meth->key;
    493    x = val(isNil(Env.meth->cls)? val(This) : car(Env.meth->cls));
    494    while (isCell(car(x)))
    495       x = cdr(x);
    496    while (isCell(x)) {
    497       if (y = method(car(TheCls = x))) {
    498          m.cls = TheCls;
    499          m.link = Env.meth,  Env.meth = &m;
    500          x = evExpr(y, cdr(ex));
    501          Env.meth = Env.meth->link;
    502          return x;
    503       }
    504       x = cdr(x);
    505    }
    506    err(ex, TheKey, "Bad super");
    507 }
    508 
    509 static any extra(any x) {
    510    any y;
    511 
    512    for (x = val(x); isCell(car(x)); x = cdr(x));
    513    while (isCell(x)) {
    514       if (x == Env.meth->cls  ||  !(y = extra(car(x)))) {
    515          while (isCell(x = cdr(x)))
    516             if (y = method(car(TheCls = x)))
    517                return y;
    518          return NULL;
    519       }
    520       if (y  &&  y != Zero)
    521          return y;
    522       x = cdr(x);
    523    }
    524    return Zero;
    525 }
    526 
    527 // (extra ['any ..]) -> any
    528 any doExtra(any ex) {
    529    any x, y;
    530    methFrame m;
    531 
    532    m.key = TheKey = Env.meth->key;
    533    if ((y = extra(val(This)))  &&  y != Zero) {
    534       m.cls = TheCls;
    535       m.link = Env.meth,  Env.meth = &m;
    536       x = evExpr(y, cdr(ex));
    537       Env.meth = Env.meth->link;
    538       return x;
    539    }
    540    err(ex, TheKey, "Bad extra");
    541 }
    542 
    543 // (with 'sym . prg) -> any
    544 any doWith(any ex) {
    545    any x;
    546    bindFrame f;
    547 
    548    x = cdr(ex);
    549    if (isNil(x = EVAL(car(x))))
    550       return Nil;
    551    NeedSymb(ex,x);
    552    Bind(This,f),  val(This) = x;
    553    x = prog(cddr(ex));
    554    Unbind(f);
    555    return x;
    556 }
    557 
    558 // (bind 'sym|lst . prg) -> any
    559 any doBind(any ex) {
    560    any x, y;
    561 
    562    x = cdr(ex);
    563    if (isNum(y = EVAL(car(x))))
    564       argError(ex, y);
    565    if (isNil(y))
    566       return prog(cdr(x));
    567    if (isSym(y)) {
    568       bindFrame f;
    569 
    570       Bind(y,f);
    571       x = prog(cdr(x));
    572       Unbind(f);
    573       return x;
    574    }
    575    {
    576       struct {  // bindFrame
    577          struct bindFrame *link;
    578          int i, cnt;
    579          struct {any sym; any val;} bnd[length(y)];
    580       } f;
    581 
    582       f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    583       f.i = f.cnt = 0;
    584       while (isCell(y)) {
    585          if (isNum(car(y)))
    586             argError(ex, car(y));
    587          if (isSym(car(y))) {
    588             f.bnd[f.cnt].sym = car(y);
    589             f.bnd[f.cnt].val = val(car(y));
    590          }
    591          else {
    592             f.bnd[f.cnt].sym = caar(y);
    593             f.bnd[f.cnt].val = val(caar(y));
    594             val(caar(y)) = cdar(y);
    595          }
    596          ++f.cnt,  y = cdr(y);
    597       }
    598       x = prog(cdr(x));
    599       while (--f.cnt >= 0)
    600          val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    601       Env.bind = f.link;
    602       return x;
    603    }
    604 }
    605 
    606 // (job 'lst . prg) -> any
    607 any doJob(any ex) {
    608    any x = cdr(ex);
    609    any y = EVAL(car(x));
    610    any z;
    611    cell c1;
    612    struct {  // bindFrame
    613       struct bindFrame *link;
    614       int i, cnt;
    615       struct {any sym; any val;} bnd[length(y)];
    616    } f;
    617 
    618    Push(c1,y);
    619    f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    620    f.i = f.cnt = 0;
    621    while (isCell(y)) {
    622       f.bnd[f.cnt].sym = caar(y);
    623       f.bnd[f.cnt].val = val(caar(y));
    624       val(caar(y)) = cdar(y);
    625       ++f.cnt,  y = cdr(y);
    626    }
    627    z = prog(cdr(x));
    628    for (f.cnt = 0, y = Pop(c1);  isCell(y);  ++f.cnt, y = cdr(y)) {
    629       cdar(y) = val(caar(y));
    630       val(caar(y)) = f.bnd[f.cnt].val;
    631    }
    632    Env.bind = f.link;
    633    return z;
    634 }
    635 
    636 // (let sym 'any . prg) -> any
    637 // (let (sym 'any ..) . prg) -> any
    638 any doLet(any x) {
    639    any y;
    640 
    641    x = cdr(x);
    642    if (!isCell(y = car(x))) {
    643       bindFrame f;
    644 
    645       x = cdr(x),  Bind(y,f),  val(y) = EVAL(car(x));
    646       x = prog(cdr(x));
    647       Unbind(f);
    648    }
    649    else {
    650       struct {  // bindFrame
    651          struct bindFrame *link;
    652          int i, cnt;
    653          struct {any sym; any val;} bnd[(length(y)+1)/2];
    654       } f;
    655 
    656       f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    657       f.i = f.cnt = 0;
    658       do {
    659          f.bnd[f.cnt].sym = car(y);
    660          f.bnd[f.cnt].val = val(car(y));
    661          val(car(y)) = EVAL(cadr(y));
    662          ++f.cnt;
    663       } while (isCell(y = cddr(y)));
    664       x = prog(cdr(x));
    665       while (--f.cnt >= 0)
    666          val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    667       Env.bind = f.link;
    668    }
    669    return x;
    670 }
    671 
    672 // (let? sym 'any . prg) -> any
    673 any doLetQ(any ex) {
    674    any x, y, z;
    675    bindFrame f;
    676 
    677    x = cdr(ex),  y = car(x),  x = cdr(x);
    678    if (isNil(z = EVAL(car(x))))
    679       return Nil;
    680    Bind(y,f),  val(y) = z;
    681    x = prog(cdr(x));
    682    Unbind(f);
    683    return x;
    684 }
    685 
    686 // (use sym . prg) -> any
    687 // (use (sym ..) . prg) -> any
    688 any doUse(any x) {
    689    any y;
    690 
    691    x = cdr(x);
    692    if (!isCell(y = car(x))) {
    693       bindFrame f;
    694 
    695       Bind(y,f);
    696       x = prog(cdr(x));
    697       Unbind(f);
    698    }
    699    else {
    700       struct {  // bindFrame
    701          struct bindFrame *link;
    702          int i, cnt;
    703          struct {any sym; any val;} bnd[length(y)];
    704       } f;
    705 
    706       f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    707       f.i = f.cnt = 0;
    708       do {
    709          f.bnd[f.cnt].sym = car(y);
    710          f.bnd[f.cnt].val = val(car(y));
    711          ++f.cnt;
    712       } while (isCell(y = cdr(y)));
    713       x = prog(cdr(x));
    714       while (--f.cnt >= 0)
    715          val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    716       Env.bind = f.link;
    717    }
    718    return x;
    719 }
    720 
    721 // (and 'any ..) -> any
    722 any doAnd(any x) {
    723    any a;
    724 
    725    x = cdr(x);
    726    do {
    727       if (isNil(a = EVAL(car(x))))
    728          return Nil;
    729       val(At) = a;
    730    }
    731    while (isCell(x = cdr(x)));
    732    return a;
    733 }
    734 
    735 // (or 'any ..) -> any
    736 any doOr(any x) {
    737    any a;
    738 
    739    x = cdr(x);
    740    do
    741       if (!isNil(a = EVAL(car(x))))
    742          return val(At) = a;
    743    while (isCell(x = cdr(x)));
    744    return Nil;
    745 }
    746 
    747 // (nand 'any ..) -> flg
    748 any doNand(any x) {
    749    any a;
    750 
    751    x = cdr(x);
    752    do {
    753       if (isNil(a = EVAL(car(x))))
    754          return T;
    755       val(At) = a;
    756    }
    757    while (isCell(x = cdr(x)));
    758    return Nil;
    759 }
    760 
    761 // (nor 'any ..) -> flg
    762 any doNor(any x) {
    763    any a;
    764 
    765    x = cdr(x);
    766    do {
    767       if (!isNil(a = EVAL(car(x)))) {
    768          val(At) = a;
    769          return Nil;
    770       }
    771    } while (isCell(x = cdr(x)));
    772    return T;
    773 }
    774 
    775 // (xor 'any 'any) -> flg
    776 any doXor(any x) {
    777    bool f;
    778 
    779    x = cdr(x),  f = isNil(EVAL(car(x))),  x = cdr(x);
    780    return  f ^ isNil(EVAL(car(x)))?  T : Nil;
    781 }
    782 
    783 // (bool 'any) -> flg
    784 any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;}
    785 
    786 // (not 'any) -> flg
    787 any doNot(any x) {return isNil(EVAL(cadr(x)))? T : Nil;}
    788 
    789 // (nil . prg) -> NIL
    790 any doNil(any x) {
    791    while (isCell(x = cdr(x)))
    792       if (isCell(car(x)))
    793          evList(car(x));
    794    return Nil;
    795 }
    796 
    797 // (t . prg) -> T
    798 any doT(any x) {
    799    while (isCell(x = cdr(x)))
    800       if (isCell(car(x)))
    801          evList(car(x));
    802    return T;
    803 }
    804 
    805 // (prog . prg) -> any
    806 any doProg(any x) {return prog(cdr(x));}
    807 
    808 // (prog1 'any1 . prg) -> any1
    809 any doProg1(any x) {
    810    cell c1;
    811 
    812    x = cdr(x),  Push(c1, val(At) = EVAL(car(x)));
    813    while (isCell(x = cdr(x)))
    814       if (isCell(car(x)))
    815          evList(car(x));
    816    return Pop(c1);
    817 }
    818 
    819 // (prog2 'any1 'any2 . prg) -> any2
    820 any doProg2(any x) {
    821    cell c1;
    822 
    823    x = cdr(x),  EVAL(car(x));
    824    x = cdr(x),  Push(c1, val(At) = EVAL(car(x)));
    825    while (isCell(x = cdr(x)))
    826       if (isCell(car(x)))
    827          evList(car(x));
    828    return Pop(c1);
    829 }
    830 
    831 // (if 'any1 'any2 . prg) -> any
    832 any doIf(any x) {
    833    any a;
    834 
    835    x = cdr(x);
    836    if (isNil(a = EVAL(car(x))))
    837       return prog(cddr(x));
    838    val(At) = a;
    839    x = cdr(x);
    840    return EVAL(car(x));
    841 }
    842 
    843 // (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any
    844 any doIf2(any x) {
    845    any a;
    846 
    847    x = cdr(x);
    848    if (isNil(a = EVAL(car(x)))) {
    849       x = cdr(x);
    850       if (isNil(a = EVAL(car(x))))
    851          return prog(cddddr(x));
    852       val(At) = a;
    853       x = cdddr(x);
    854       return EVAL(car(x));
    855    }
    856    val(At) = a;
    857    x = cdr(x);
    858    if (isNil(a = EVAL(car(x)))) {
    859       x = cddr(x);
    860       return EVAL(car(x));
    861    }
    862    val(At) = a;
    863    x = cdr(x);
    864    return EVAL(car(x));
    865 }
    866 
    867 // (ifn 'any1 'any2 . prg) -> any
    868 any doIfn(any x) {
    869    any a;
    870 
    871    x = cdr(x);
    872    if (!isNil(a = EVAL(car(x)))) {
    873       val(At) = a;
    874       return prog(cddr(x));
    875    }
    876    x = cdr(x);
    877    return EVAL(car(x));
    878 }
    879 
    880 // (when 'any . prg) -> any
    881 any doWhen(any x) {
    882    any a;
    883 
    884    x = cdr(x);
    885    if (isNil(a = EVAL(car(x))))
    886       return Nil;
    887    val(At) = a;
    888    return prog(cdr(x));
    889 }
    890 
    891 // (unless 'any . prg) -> any
    892 any doUnless(any x) {
    893    any a;
    894 
    895    x = cdr(x);
    896    if (!isNil(a = EVAL(car(x)))) {
    897       val(At) = a;
    898       return Nil;
    899    }
    900    return prog(cdr(x));
    901 }
    902 
    903 // (cond ('any1 . prg1) ('any2 . prg2) ..) -> any
    904 any doCond(any x) {
    905    any a;
    906 
    907    while (isCell(x = cdr(x))) {
    908       if (!isNil(a = EVAL(caar(x)))) {
    909          val(At) = a;
    910          return prog(cdar(x));
    911       }
    912    }
    913    return Nil;
    914 }
    915 
    916 // (nond ('any1 . prg1) ('any2 . prg2) ..) -> any
    917 any doNond(any x) {
    918    any a;
    919 
    920    while (isCell(x = cdr(x))) {
    921       if (isNil(a = EVAL(caar(x))))
    922          return prog(cdar(x));
    923       val(At) = a;
    924    }
    925    return Nil;
    926 }
    927 
    928 // (case 'any (any1 . prg1) (any2 . prg2) ..) -> any
    929 any doCase(any x) {
    930    any y, z;
    931 
    932    x = cdr(x),  val(At) = EVAL(car(x));
    933    while (isCell(x = cdr(x))) {
    934       y = car(x),  z = car(y);
    935       if (z == T  ||  equal(val(At), z))
    936          return prog(cdr(y));
    937       if (isCell(z)) {
    938          do
    939             if (equal(val(At), car(z)))
    940                return prog(cdr(y));
    941          while (isCell(z = cdr(z)));
    942       }
    943    }
    944    return Nil;
    945 }
    946 
    947 // (state 'var ((sym|lst sym [. prg]) . prg) ..) -> any
    948 any doState(any ex) {
    949    any x, y, z, a;
    950    cell c1;
    951 
    952    x = cdr(ex);
    953    Push(c1, EVAL(car(x)));
    954    NeedVar(ex,data(c1));
    955    CheckVar(ex,data(c1));
    956    while (isCell(x = cdr(x))) {
    957       y = caar(x),  z = car(y);
    958       if (z==T || z==val(data(c1)) || isCell(z) && memq(val(data(c1)),z)) {
    959          y = cdr(y);
    960          if (!isCell(cdr(y)))
    961             goto st1;
    962          if (!isNil(a = prog(cdr(y)))) {
    963             val(At) = a;
    964          st1:
    965             val(data(c1)) = car(y);
    966             drop(c1);
    967             return prog(cdar(x));
    968          }
    969       }
    970    }
    971    drop(c1);
    972    return Nil;
    973 }
    974 
    975 // (while 'any . prg) -> any
    976 any doWhile(any x) {
    977    any cond, a;
    978    cell c1;
    979 
    980    cond = car(x = cdr(x)),  x = cdr(x);
    981    Push(c1, Nil);
    982    while (!isNil(a = EVAL(cond))) {
    983       val(At) = a;
    984       data(c1) = prog(x);
    985    }
    986    return Pop(c1);
    987 }
    988 
    989 // (until 'any . prg) -> any
    990 any doUntil(any x) {
    991    any cond, a;
    992    cell c1;
    993 
    994    cond = car(x = cdr(x)),  x = cdr(x);
    995    Push(c1, Nil);
    996    while (isNil(a = EVAL(cond)))
    997       data(c1) = prog(x);
    998    val(At) = a;
    999    return Pop(c1);
   1000 }
   1001 
   1002 // (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
   1003 any doLoop(any ex) {
   1004    any x, y, a;
   1005 
   1006    for (;;) {
   1007       x = cdr(ex);
   1008       do {
   1009          if (isCell(y = car(x))) {
   1010             if (isNil(car(y))) {
   1011                y = cdr(y);
   1012                if (isNil(a = EVAL(car(y))))
   1013                   return prog(cdr(y));
   1014                val(At) = a;
   1015             }
   1016             else if (car(y) == T) {
   1017                y = cdr(y);
   1018                if (!isNil(a = EVAL(car(y)))) {
   1019                   val(At) = a;
   1020                   return prog(cdr(y));
   1021                }
   1022             }
   1023             else
   1024                evList(y);
   1025          }
   1026       } while (isCell(x = cdr(x)));
   1027    }
   1028 }
   1029 
   1030 // (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
   1031 any doDo(any x) {
   1032    any f, y, z, a;
   1033 
   1034    x = cdr(x);
   1035    if (isNil(f = EVAL(car(x))))
   1036       return Nil;
   1037    if (isNum(f) && num(f) < 0)
   1038       return Nil;
   1039    x = cdr(x),  z = Nil;
   1040    for (;;) {
   1041       if (isNum(f)) {
   1042          if (f == Zero)
   1043             return z;
   1044          f = (any)(num(f) - 4);
   1045       }
   1046       y = x;
   1047       do {
   1048          if (!isNum(z = car(y))) {
   1049             if (isSym(z))
   1050                z = val(z);
   1051             else if (isNil(car(z))) {
   1052                z = cdr(z);
   1053                if (isNil(a = EVAL(car(z))))
   1054                   return prog(cdr(z));
   1055                val(At) = a;
   1056                z = Nil;
   1057             }
   1058             else if (car(z) == T) {
   1059                z = cdr(z);
   1060                if (!isNil(a = EVAL(car(z)))) {
   1061                   val(At) = a;
   1062                   return prog(cdr(z));
   1063                }
   1064                z = Nil;
   1065             }
   1066             else
   1067                z = evList(z);
   1068          }
   1069       } while (isCell(y = cdr(y)));
   1070    }
   1071 }
   1072 
   1073 // (at '(cnt1 . cnt2) . prg) -> any
   1074 any doAt(any ex) {
   1075    any x;
   1076 
   1077    x = cdr(ex),  x = EVAL(car(x));
   1078    NeedCell(ex,x);
   1079    NeedNum(ex,car(x));
   1080    NeedNum(ex,cdr(x));
   1081    if (num(car(x) += 4) < num(cdr(x)))
   1082       return Nil;
   1083    car(x) = Zero;
   1084    return prog(cddr(ex));
   1085 }
   1086 
   1087 // (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
   1088 // (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
   1089 any doFor(any ex) {
   1090    any x, y, body, cond, a;
   1091    cell c1;
   1092    struct {  // bindFrame
   1093       struct bindFrame *link;
   1094       int i, cnt;
   1095       struct {any sym; any val;} bnd[2];
   1096    } f;
   1097 
   1098    f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   1099    f.i = 0;
   1100    if (!isCell(y = car(x = cdr(ex))) || !isCell(cdr(y))) {
   1101       if (!isCell(y)) {
   1102          f.cnt = 1;
   1103          f.bnd[0].sym = y;
   1104          f.bnd[0].val = val(y);
   1105       }
   1106       else {
   1107          f.cnt = 2;
   1108          f.bnd[0].sym = cdr(y);
   1109          f.bnd[0].val = val(cdr(y));
   1110          f.bnd[1].sym = car(y);
   1111          f.bnd[1].val = val(car(y));
   1112          val(f.bnd[1].sym) = Zero;
   1113       }
   1114       y = Nil;
   1115       x = cdr(x),  Push(c1, EVAL(car(x)));
   1116       body = x = cdr(x);
   1117       while (isCell(data(c1))) {
   1118          val(f.bnd[0].sym) = car(data(c1)),  data(c1) = cdr(data(c1));
   1119          if (f.cnt == 2)
   1120             val(f.bnd[1].sym) = (any)(num(val(f.bnd[1].sym)) + 4);
   1121          do {
   1122             if (!isNum(y = car(x))) {
   1123                if (isSym(y))
   1124                   y = val(y);
   1125                else if (isNil(car(y))) {
   1126                   y = cdr(y);
   1127                   if (isNil(a = EVAL(car(y)))) {
   1128                      y = prog(cdr(y));
   1129                      goto for1;
   1130                   }
   1131                   val(At) = a;
   1132                   y = Nil;
   1133                }
   1134                else if (car(y) == T) {
   1135                   y = cdr(y);
   1136                   if (!isNil(a = EVAL(car(y)))) {
   1137                      val(At) = a;
   1138                      y = prog(cdr(y));
   1139                      goto for1;
   1140                   }
   1141                   y = Nil;
   1142                }
   1143                else
   1144                   y = evList(y);
   1145             }
   1146          } while (isCell(x = cdr(x)));
   1147          x = body;
   1148       }
   1149    for1:
   1150       drop(c1);
   1151       if (f.cnt == 2)
   1152          val(f.bnd[1].sym) = f.bnd[1].val;
   1153       val(f.bnd[0].sym) = f.bnd[0].val;
   1154       Env.bind = f.link;
   1155       return y;
   1156    }
   1157    if (!isCell(car(y))) {
   1158       f.cnt = 1;
   1159       f.bnd[0].sym = car(y);
   1160       f.bnd[0].val = val(car(y));
   1161    }
   1162    else {
   1163       f.cnt = 2;
   1164       f.bnd[0].sym = cdar(y);
   1165       f.bnd[0].val = val(cdar(y));
   1166       f.bnd[1].sym = caar(y);
   1167       f.bnd[1].val = val(caar(y));
   1168       val(f.bnd[1].sym) = Zero;
   1169    }
   1170    y = cdr(y);
   1171    val(f.bnd[0].sym) = EVAL(car(y));
   1172    y = cdr(y),  cond = car(y),  y = cdr(y);
   1173    Push(c1,Nil);
   1174    body = x = cdr(x);
   1175    while (!isNil(a = EVAL(cond))) {
   1176       val(At) = a;
   1177       if (f.cnt == 2)
   1178          val(f.bnd[1].sym) = (any)(num(val(f.bnd[1].sym)) + 4);
   1179       do {
   1180          if (!isNum(data(c1) = car(x))) {
   1181             if (isSym(data(c1)))
   1182                data(c1) = val(data(c1));
   1183             else if (isNil(car(data(c1)))) {
   1184                data(c1) = cdr(data(c1));
   1185                if (isNil(a = EVAL(car(data(c1))))) {
   1186                   data(c1) = prog(cdr(data(c1)));
   1187                   goto for2;
   1188                }
   1189                val(At) = a;
   1190                data(c1) = Nil;
   1191             }
   1192             else if (car(data(c1)) == T) {
   1193                data(c1) = cdr(data(c1));
   1194                if (!isNil(a = EVAL(car(data(c1))))) {
   1195                   val(At) = a;
   1196                   data(c1) = prog(cdr(data(c1)));
   1197                   goto for2;
   1198                }
   1199                data(c1) = Nil;
   1200             }
   1201             else
   1202                data(c1) = evList(data(c1));
   1203          }
   1204       } while (isCell(x = cdr(x)));
   1205       if (isCell(y))
   1206          val(f.bnd[0].sym) = prog(y);
   1207       x = body;
   1208    }
   1209 for2:
   1210    if (f.cnt == 2)
   1211       val(f.bnd[1].sym) = f.bnd[1].val;
   1212    val(f.bnd[0].sym) = f.bnd[0].val;
   1213    Env.bind = f.link;
   1214    return Pop(c1);
   1215 }
   1216 
   1217 static any Thrown;
   1218 
   1219 // (catch 'sym . prg) -> any
   1220 any doCatch(any ex) {
   1221    any x, y;
   1222    catchFrame f;
   1223 
   1224    x = cdr(ex),  f.tag = EVAL(car(x));
   1225    NeedSymb(ex,f.tag);
   1226    f.link = CatchPtr,  CatchPtr = &f;
   1227    f.env = Env;
   1228    y = setjmp(f.rst)? Thrown : prog(cdr(x));
   1229    CatchPtr = f.link;
   1230    return y;
   1231 }
   1232 
   1233 // (throw 'sym 'any)
   1234 any doThrow(any ex) {
   1235    any x, tag;
   1236    catchFrame *p;
   1237 
   1238    x = cdr(ex),  tag = EVAL(car(x));
   1239    x = cdr(x),  Thrown = EVAL(car(x));
   1240    for (p = CatchPtr;  p;  p = p->link)
   1241       if (p->tag == T  ||  tag == p->tag) {
   1242          unwind(p);
   1243          longjmp(p->rst, 1);
   1244       }
   1245    err(ex, tag, "Tag not found");
   1246 }
   1247 
   1248 // (finally exe . prg) -> any
   1249 any doFinally(any x) {
   1250    catchFrame f;
   1251    cell c1;
   1252 
   1253    x = cdr(x);
   1254    f.tag = car(x);
   1255    f.link = CatchPtr,  CatchPtr = &f;
   1256    f.env = Env;
   1257    Push(c1, prog(cdr(x)));
   1258    EVAL(f.tag);
   1259    CatchPtr = f.link;
   1260    return Pop(c1);
   1261 }
   1262 
   1263 static outFrame Out;
   1264 static struct {  // bindFrame
   1265    struct bindFrame *link;
   1266    int i, cnt;
   1267    struct {any sym; any val;} bnd[2];  // for 'Up' and 'At'
   1268 } Brk;
   1269 
   1270 void brkLoad(any x) {
   1271    if (!isNil(val(Dbg)) && !Env.brk) {
   1272       Env.brk = YES;
   1273       Brk.cnt = 2;
   1274       Brk.bnd[0].sym = Up,  Brk.bnd[0].val = val(Up),  val(Up) = x;
   1275       Brk.bnd[1].sym = At,  Brk.bnd[1].val = val(At);
   1276       Brk.link = Env.bind,  Env.bind = (bindFrame*)&Brk;
   1277       Out.fp = stdout,  pushOutFiles(&Out);
   1278       print(x), crlf();
   1279       load(NULL, '!', Nil);
   1280       popOutFiles();
   1281       val(At) = Brk.bnd[1].val;
   1282       val(Up) = Brk.bnd[0].val;
   1283       Env.bind = Brk.link;
   1284       Env.brk = NO;
   1285    }
   1286 }
   1287 
   1288 // (! . prg) -> any
   1289 any doBreak(any ex) {
   1290    brkLoad(cdr(ex));
   1291    return EVAL(cdr(ex));
   1292 }
   1293 
   1294 // (e . prg) -> any
   1295 any doE(any ex) {
   1296    any x;
   1297    cell c1, at;
   1298 
   1299    if (!Env.brk)
   1300       err(ex, NULL, "No Break");
   1301    Push(c1,val(Dbg)),  val(Dbg) = Nil;
   1302    Push(at, val(At)),  val(At) = Brk.bnd[1].val;
   1303    if (Env.inFiles && Env.inFiles->link)
   1304       Chr = Env.inFiles->next,  Env.get = Env.inFiles->get,  InFile = Env.inFiles->link->fp;
   1305    popOutFiles();
   1306    x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up));
   1307    pushOutFiles(&Out);
   1308    if (Env.inFiles && Env.inFiles->link)
   1309       Env.inFiles->next = Chr,  Chr = 0;
   1310    InFile = stdin,  OutFile = stdout;
   1311    val(At) = data(at);
   1312    val(Dbg) = Pop(c1);
   1313    return x;
   1314 }
   1315 
   1316 static void traceIndent(int i, any x, char *s) {
   1317    if (i > 64)
   1318       i = 64;
   1319    while (--i >= 0)
   1320       Env.put(' ');
   1321    if (!isCell(x))
   1322       print(x);
   1323    else
   1324       print(car(x)), space(), print(cdr(x)), space(), print(val(This));
   1325    outString(s);
   1326 }
   1327 
   1328 static void traceSym(any x) {
   1329    if (x != At)
   1330       space(), print(val(x));
   1331    else {
   1332       int i = Env.next;
   1333 
   1334       while (--i >= 0)
   1335          space(), print(data(Env.arg[i]));
   1336    }
   1337 }
   1338 
   1339 // ($ sym|lst lst . prg) -> any
   1340 any doTrace(any x) {
   1341    any foo, body;
   1342    FILE *oSave;
   1343    void (*putSave)(int);
   1344    cell c1;
   1345 
   1346    if (isNil(val(Dbg)))
   1347       return prog(cdddr(x));
   1348    oSave = OutFile,  OutFile = stderr;
   1349    putSave = Env.put,  Env.put = putStdout;
   1350    x = cdr(x),  foo = car(x);
   1351    x = cdr(x),  body = cdr(x);
   1352    traceIndent(++Trace, foo, " :");
   1353    for (x = car(x);  isCell(x);  x = cdr(x))
   1354       traceSym(car(x));
   1355    if (!isNil(x) && !isNum(x))
   1356       traceSym(x);
   1357    crlf();
   1358    Env.put = putSave;
   1359    OutFile = oSave;
   1360    Push(c1, prog(body));
   1361    OutFile = stderr;
   1362    Env.put = putStdout;
   1363    traceIndent(Trace--, foo, " = "),  print(data(c1)),  crlf();
   1364    Env.put = putSave;
   1365    OutFile = oSave;
   1366    return Pop(c1);
   1367 }
   1368 
   1369 // (bye 'num|NIL)
   1370 any doBye(any ex) {
   1371    any x = EVAL(cadr(ex));
   1372 
   1373    bye(isNil(x)? 0 : xNum(ex,x));
   1374 }
	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