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

main.c (14771B)
      1 /* 15nov07abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 /* Globals */
      8 int Chr, Trace;
      9 char **AV, *Home;
     10 heap *Heaps;
     11 cell *Avail;
     12 stkEnv Env;
     13 catchFrame *CatchPtr;
     14 FILE *InFile, *OutFile;
     15 any TheKey, TheCls;
     16 any Intern[2], Transient[2], Reloc;
     17 any ApplyArgs, ApplyBody;
     18 any Nil, Meth, Quote, T, At, At2, At3, This;
     19 any Dbg, Scl, Class, Up, Err, Rst, Msg, Adr, Bye;
     20 
     21 static bool Jam;
     22 static jmp_buf ErrRst;
     23 
     24 
     25 /*** System ***/
     26 void giveup(char *msg) {
     27    fprintf(stderr, "%s\n", msg);
     28    exit(1);
     29 }
     30 
     31 void bye(int n) {
     32    static bool b;
     33 
     34    if (!b) {
     35       b = YES;
     36       unwind(NULL);
     37       prog(val(Bye));
     38    }
     39    exit(n);
     40 }
     41 
     42 void execError(char *s) {
     43    fprintf(stderr, "%s: can't exec\n", s);
     44    exit(127);
     45 }
     46 
     47 /* Allocate memory */
     48 void *alloc(void *p, size_t siz) {
     49    if (!(p = realloc(p,siz)))
     50       giveup("No memory");
     51    return p;
     52 }
     53 
     54 /* Allocate cell heap */
     55 void heapAlloc(void) {
     56    heap *h;
     57    cell *p;
     58 
     59    h = (heap*)((long)alloc(NULL,
     60       sizeof(heap) + sizeof(cell)) + (sizeof(cell)-1) & ~(sizeof(cell)-1) );
     61    h->next = Heaps,  Heaps = h;
     62    p = h->cells + CELLS-1;
     63    do
     64       Free(p);
     65    while (--p >= h->cells);
     66 }
     67 
     68 // (heap 'flg) -> num
     69 any doHeap(any x) {
     70    long n = 0;
     71 
     72    x = cdr(x);
     73    if (isNil(EVAL(car(x)))) {
     74       heap *h = Heaps;
     75       do
     76          ++n;
     77       while (h = h->next);
     78       return box(n);
     79    }
     80    for (x = Avail;  x;  x = car(x))
     81       ++n;
     82    return box(n / CELLS);
     83 }
     84 
     85 // (env ['lst] | ['sym 'val] ..) -> lst
     86 any doEnv(any x) {
     87    int i;
     88    bindFrame *p;
     89    cell c1, c2;
     90 
     91    Push(c1,Nil);
     92    if (!isCell(x = cdr(x))) {
     93       for (p = Env.bind;  p;  p = p->link) {
     94          if (p->i == 0) {
     95             for (i = p->cnt;  --i >= 0;) {
     96                for (x = data(c1); ; x = cdr(x)) {
     97                   if (!isCell(x)) {
     98                      data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1));
     99                      break;
    100                   }
    101                   if (caar(x) == p->bnd[i].sym)
    102                      break;
    103                }
    104             }
    105          }
    106       }
    107    }
    108    else {
    109       do {
    110          Push(c2, EVAL(car(x)));
    111          if (isCell(data(c2))) {
    112             do
    113                data(c1) = cons(cons(car(data(c2)), val(car(data(c2)))), data(c1));
    114             while (isCell(data(c2) = cdr(data(c2))));
    115          }
    116          else if (!isNil(data(c2))) {
    117             x = cdr(x);
    118             data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1));
    119          }
    120          drop(c2);
    121       }
    122       while (isCell(x = cdr(x)));
    123    }
    124    return Pop(c1);
    125 }
    126 
    127 // (up [cnt] sym ['val]) -> any
    128 any doUp(any x) {
    129    any y, *val;
    130    int cnt, i;
    131    bindFrame *p;
    132 
    133    x = cdr(x);
    134    if (!isNum(y = car(x)))
    135       cnt = 1;
    136    else
    137       cnt = (int)unBox(y),  x = cdr(x),  y = car(x);
    138    for (p = Env.bind, val = &val(y);  p;  p = p->link) {
    139       if (p->i <= 0) {
    140          for (i = 0;  i < p->cnt;  ++i)
    141             if (p->bnd[i].sym == y) {
    142                if (!--cnt) {
    143                   if (isCell(x = cdr(x)))
    144                      return p->bnd[i].val = EVAL(car(x));
    145                   return p->bnd[i].val;
    146                }
    147                val = &p->bnd[i].val;
    148                break;
    149             }
    150       }
    151    }
    152    if (isCell(x = cdr(x)))
    153       return *val = EVAL(car(x));
    154    return *val;
    155 }
    156 
    157 // (stk any ..) -> T
    158 any doStk(any x) {
    159    any p;
    160    FILE *oSave = OutFile;
    161 
    162    OutFile = stderr;
    163    print(cdr(x)), crlf();
    164    for (p = Env.stack; p; p = cdr(p)) {
    165       printf("%lX ", (word)p),  fflush(stderr);
    166       print(car(p)), crlf();
    167    }
    168    crlf();
    169    OutFile = oSave;
    170    return T;
    171 }
    172 
    173 /*** Primitives ***/
    174 /* Comparisons */
    175 bool equal(any x, any y) {
    176    any a, b;
    177 
    178    for (;;) {
    179       if (x == y)
    180          return YES;
    181       if (isNum(x))
    182          return NO;
    183       if (isSym(x)) {
    184          if (!isSymb(y))
    185             return NO;
    186          if ((x = name(x)) == (y = name(y)))
    187             return x != txt(0);
    188          if (isTxt(x) || isTxt(y))
    189             return NO;
    190          do {
    191             if (num(tail(x)) != num(tail(y)))
    192                return NO;
    193             x = val(x),  y = val(y);
    194          } while (!isNum(x) && !isNum(y));
    195          return x == y;
    196       }
    197       if (!isCell(y))
    198          return NO;
    199       while (car(x) == Quote) {
    200          if (car(y) != Quote)
    201             return NO;
    202          if (x == cdr(x))
    203             return y == cdr(y);
    204          if (y == cdr(y))
    205             return NO;
    206          if (!isCell(x = cdr(x)))
    207             return equal(x, cdr(y));
    208          if (!isCell(y = cdr(y)))
    209             return NO;
    210       }
    211       a = x, b = y;
    212       for (;;) {
    213          if (!equal(car(x), car(y)))
    214             return NO;
    215          if (!isCell(x = cdr(x)))
    216             return equal(x, cdr(y));
    217          if (!isCell(y = cdr(y)))
    218             return NO;
    219          if (x == a && y == b)
    220             return YES;
    221       }
    222    }
    223 }
    224 
    225 int compare(any x, any y) {
    226    any a, b;
    227 
    228    if (x == y)
    229       return 0;
    230    if (isNil(x))
    231       return -1;
    232    if (x == T)
    233       return +1;
    234    if (isNum(x)) {
    235       if (!isNum(y))
    236          return isNil(y)? +1 : -1;
    237       return num(x) - num(y);
    238    }
    239    if (isSym(x)) {
    240       int c, d, i, j;
    241       word w, v;
    242 
    243       if (isNum(y) || isNil(y))
    244          return +1;
    245       if (isCell(y) || y == T)
    246          return -1;
    247       a = name(x),  b = name(y);
    248       if (a == txt(0) && b == txt(0))
    249          return 1664525*(int32_t)(long)x - 1664525*(int32_t)(long)y;
    250       if ((c = getByte1(&i, &w, &a)) == (d = getByte1(&j, &v, &b)))
    251          do
    252             if (c == 0)
    253                return 0;
    254          while ((c = getByte(&i, &w, &a)) == (d = getByte(&j, &v, &b)));
    255       return c - d;
    256    }
    257    if (!isCell(y))
    258       return y == T? -1 : +1;
    259    a = x, b = y;
    260    for (;;) {
    261       int n;
    262 
    263       if (n = compare(car(x),car(y)))
    264          return n;
    265       if (!isCell(x = cdr(x)))
    266          return compare(x, cdr(y));
    267       if (!isCell(y = cdr(y)))
    268          return y == T? -1 : +1;
    269       if (x == a && y == b)
    270          return 0;
    271    }
    272 }
    273 
    274 /*** Error handling ***/
    275 static void reset(void) {
    276    unwind(NULL);
    277    Env.stack = NULL;
    278    Env.meth = NULL;
    279    Env.next = -1;
    280    Env.make = NULL;
    281    Env.parser = NULL;
    282    Trace = 0;
    283 }
    284 
    285 void err(any ex, any x, char *fmt, ...) {
    286    va_list ap;
    287    char msg[240];
    288    outFrame f;
    289 
    290    Chr = 0;
    291    Reloc = Nil;
    292    Env.brk = NO;
    293    f.fp = stderr;
    294    pushOutFiles(&f);
    295    while (*AV  &&  strcmp(*AV,"-") != 0)
    296       ++AV;
    297    if (ex)
    298       outString("!? "), print(val(Up) = ex), crlf();
    299    if (x)
    300       print(x), outString(" -- ");
    301    va_start(ap,fmt);
    302    vsnprintf(msg, sizeof(msg), fmt, ap);
    303    va_end(ap);
    304    if (msg[0]) {
    305       outString(msg), crlf();
    306       val(Msg) = mkStr(msg);
    307       if (!isNil(val(Err)) && !Jam)
    308          Jam = YES,  prog(val(Err)),  Jam = NO;
    309       if (!isNil(val(Rst)))
    310          reset(),  longjmp(ErrRst, -1);
    311       load(NULL, '?', Nil);
    312    }
    313    reset();
    314    longjmp(ErrRst, +1);
    315 }
    316 
    317 // (quit ['any ['any]])
    318 any doQuit(any x) {
    319    cell c1;
    320 
    321    x = cdr(x),  Push(c1, evSym(x));
    322    x = isCell(x = cdr(x))?  EVAL(car(x)) : NULL;
    323    {
    324       char msg[bufSize(data(c1))];
    325 
    326       bufString(data(c1), msg);
    327       drop(c1);
    328       err(NULL, x, "%s", msg);
    329    }
    330 }
    331 
    332 void argError(any ex, any x) {err(ex, x, "Bad argument");}
    333 void numError(any ex, any x) {err(ex, x, "Number expected");}
    334 void symError(any ex, any x) {err(ex, x, "Symbol expected");}
    335 void cellError(any ex, any x) {err(ex, x, "Cell expected");}
    336 void atomError(any ex, any x) {err(ex, x, "Atom expected");}
    337 void lstError(any ex, any x) {err(ex, x, "List expected");}
    338 void varError(any ex, any x) {err(ex, x, "Variable expected");}
    339 void protError(any ex, any x) {err(ex, x, "Protected symbol");}
    340 
    341 void unwind(catchFrame *p) {
    342    int i;
    343    catchFrame *q;
    344    cell c1;
    345 
    346    while (CatchPtr) {
    347       q = CatchPtr,  CatchPtr = CatchPtr->link;
    348       while (Env.bind != q->env.bind) {
    349          if (Env.bind->i == 0)
    350             for (i = Env.bind->cnt;  --i >= 0;)
    351                val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
    352          Env.bind = Env.bind->link;
    353       }
    354       while (Env.inFiles != q->env.inFiles)
    355          popInFiles();
    356       while (Env.outFiles != q->env.outFiles)
    357          popOutFiles();
    358       Env = q->env;
    359       if (q == p)
    360          return;
    361       if (!isSym(q->tag)) {
    362          Push(c1, q->tag);
    363          EVAL(data(c1));
    364          drop(c1);
    365       }
    366    }
    367    while (Env.bind) {
    368       if (Env.bind->i == 0)
    369          for (i = Env.bind->cnt;  --i >= 0;)
    370             val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
    371       Env.bind = Env.bind->link;
    372    }
    373    while (Env.inFiles)
    374       popInFiles();
    375    while (Env.outFiles)
    376       popOutFiles();
    377 }
    378 
    379 /*** Evaluation ***/
    380 any evExpr(any expr, any x) {
    381    any y = car(expr);
    382    struct {  // bindFrame
    383       struct bindFrame *link;
    384       int i, cnt;
    385       struct {any sym; any val;} bnd[length(y)+2];
    386    } f;
    387 
    388    f.link = Env.bind,  Env.bind = (bindFrame*)&f;
    389    f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1;
    390    f.cnt = 1,  f.bnd[0].sym = At,  f.bnd[0].val = val(At);
    391    while (isCell(y)) {
    392       f.bnd[f.cnt].sym = car(y);
    393       f.bnd[f.cnt].val = EVAL(car(x));
    394       ++f.cnt, x = cdr(x), y = cdr(y);
    395    }
    396    if (isNil(y)) {
    397       while (--f.i > 0) {
    398          x = val(f.bnd[f.i].sym);
    399          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    400          f.bnd[f.i].val = x;
    401       }
    402       x = prog(cdr(expr));
    403    }
    404    else if (y != At) {
    405       f.bnd[f.cnt].sym = y,  f.bnd[f.cnt++].val = val(y),  val(y) = x;
    406       while (--f.i > 0) {
    407          x = val(f.bnd[f.i].sym);
    408          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    409          f.bnd[f.i].val = x;
    410       }
    411       x = prog(cdr(expr));
    412    }
    413    else {
    414       int n, cnt;
    415       cell *arg;
    416       cell c[n = cnt = length(x)];
    417 
    418       while (--n >= 0)
    419          Push(c[n], EVAL(car(x))),  x = cdr(x);
    420       while (--f.i > 0) {
    421          x = val(f.bnd[f.i].sym);
    422          val(f.bnd[f.i].sym) = f.bnd[f.i].val;
    423          f.bnd[f.i].val = x;
    424       }
    425       n = Env.next,  Env.next = cnt;
    426       arg = Env.arg,  Env.arg = c;
    427       x = prog(cdr(expr));
    428       if (cnt)
    429          drop(c[cnt-1]);
    430       Env.arg = arg,  Env.next = n;
    431    }
    432    while (--f.cnt >= 0)
    433       val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
    434    Env.bind = f.link;
    435    return x;
    436 }
    437 
    438 void undefined(any x, any ex) {err(ex, x, "Undefined");}
    439 
    440 /* Evaluate a list */
    441 any evList(any ex) {
    442    any foo;
    443 
    444    if (isNum(foo = car(ex)))
    445       return ex;
    446    if (isCell(foo)) {
    447       if (isNum(foo = evList(foo)))
    448          return evSubr(foo,ex);
    449       if (isCell(foo))
    450          return evExpr(foo, cdr(ex));
    451    }
    452    for (;;) {
    453       if (isNil(val(foo)))
    454          undefined(foo,ex);
    455       if (isNum(foo = val(foo)))
    456          return evSubr(foo,ex);
    457       if (isCell(foo))
    458          return evExpr(foo, cdr(ex));
    459    }
    460 }
    461 
    462 /* Evaluate number */
    463 long evNum(any ex, any x) {return xNum(ex, EVAL(car(x)));}
    464 
    465 long xNum(any ex, any x) {
    466    NeedNum(ex,x);
    467    return unBox(x);
    468 }
    469 
    470 /* Evaluate any to sym */
    471 any evSym(any x) {return xSym(EVAL(car(x)));}
    472 
    473 any xSym(any x) {
    474    int i;
    475    word w;
    476    any y;
    477    cell c1, c2;
    478 
    479    if (isSymb(x))
    480       return x;
    481    Push(c1,x);
    482    putByte0(&i, &w, &y);
    483    i = 0,  pack(x, &i, &w, &y, &c2);
    484    y = popSym(i, w, y, &c2);
    485    drop(c1);
    486    return i? y : Nil;
    487 }
    488 
    489 any boxSubr(fun f) {
    490    if (num(f) & 3)
    491       giveup("Unaligned Function");
    492    return (any)(num(f) | 2);
    493 }
    494 
    495 // (args) -> flg
    496 any doArgs(any ex __attribute__((unused))) {
    497    return Env.next > 0? T : Nil;
    498 }
    499 
    500 // (next) -> any
    501 any doNext(any ex __attribute__((unused))) {
    502    if (Env.next > 0)
    503       return data(Env.arg[--Env.next]);
    504    if (Env.next == 0)
    505       Env.next = -1;
    506    return Nil;
    507 }
    508 
    509 // (arg ['cnt]) -> any
    510 any doArg(any ex) {
    511    long n;
    512 
    513    if (Env.next < 0)
    514       return Nil;
    515    if (!isCell(cdr(ex)))
    516       return data(Env.arg[Env.next]);
    517    if ((n = evNum(ex,cdr(ex))) > 0  &&  n <= Env.next)
    518       return data(Env.arg[Env.next - n]);
    519    return Nil;
    520 }
    521 
    522 // (rest) -> lst
    523 any doRest(any x) {
    524    int i;
    525    cell c1;
    526 
    527    if ((i = Env.next) <= 0)
    528       return Nil;
    529    Push(c1, x = cons(data(Env.arg[--i]), Nil));
    530    while (i)
    531       x = cdr(x) = cons(data(Env.arg[--i]), Nil);
    532    return Pop(c1);
    533 }
    534 
    535 any mkDat(int y, int m, int d) {
    536    int n;
    537    static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31};
    538 
    539    if (m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400))
    540       return Nil;
    541    n = (12*y + m - 3) / 12;
    542    return box((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d);
    543 }
    544 
    545 // (date 'dat) -> (y m d)
    546 // (date 'y 'm 'd) -> dat | NIL
    547 // (date '(y m d)) -> dat | NIL
    548 any doDate(any ex) {
    549    any x, z;
    550    int y, m, d, n;
    551    cell c1;
    552 
    553    x = cdr(ex);
    554    if (isNil(z = EVAL(car(x))))
    555       return Nil;
    556    if (isNum(z) && !isCell(x = cdr(x))) {
    557       n = xNum(ex,z);
    558       y = (100*n - 20) / 3652425;
    559       n += (y - y/4);
    560       y = (100*n - 20) / 36525;
    561       n -= 36525*y / 100;
    562       m = (10*n - 5) / 306;
    563       d = (10*n - 306*m + 5) / 10;
    564       if (m < 10)
    565          m += 3;
    566       else
    567          ++y,  m -= 9;
    568       Push(c1, cons(box(d), Nil));
    569       data(c1) = cons(box(m), data(c1));
    570       data(c1) = cons(box(y), data(c1));
    571       return Pop(c1);
    572    }
    573    if (!isCell(z))
    574       return mkDat(xNum(ex,z), evNum(ex,x), evNum(ex,cdr(x)));
    575    return mkDat(xNum(ex, car(z)),  xNum(ex, cadr(z)),  xNum(ex, caddr(z)));
    576 }
    577 
    578 // (argv [sym ..] [. sym]) -> lst|sym
    579 any doArgv(any ex) {
    580    any x, y;
    581    char **p;
    582    cell c1;
    583 
    584    if (*(p = AV) && strcmp(*p,"-") == 0)
    585       ++p;
    586    if (isNil(x = cdr(ex))) {
    587       if (!*p)
    588          return Nil;
    589       Push(c1, x = cons(mkStr(*p++), Nil));
    590       while (*p)
    591          x = cdr(x) = cons(mkStr(*p++), Nil);
    592       return Pop(c1);
    593    }
    594    do {
    595       if (!isCell(x)) {
    596          NeedSymb(ex,x);
    597          if (!*p)
    598             return val(x) = Nil;
    599          Push(c1, y = cons(mkStr(*p++), Nil));
    600          while (*p)
    601             y = cdr(y) = cons(mkStr(*p++), Nil);
    602          return val(x) = Pop(c1);
    603       }
    604       y = car(x);
    605       NeedSymb(ex,y);
    606       val(y) = *p? mkStr(*p++) : Nil;
    607    } while (!isNil(x = cdr(x)));
    608    return val(y);
    609 }
    610 
    611 // (opt) -> sym
    612 any doOpt(any ex __attribute__((unused))) {
    613    return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil;
    614 }
    615 
    616 /*** Main ***/
    617 int main(int ac, char *av[]) {
    618    int i;
    619    char *p;
    620 
    621    for (i = 1; i < ac; ++i)
    622       if (*av[i] != '-') {
    623          if ((p = strrchr(av[i], '/')) && !(p == av[i]+1 && *av[i] == '.')) {
    624             Home = malloc(p - av[i] + 2);
    625             memcpy(Home, av[i], p - av[i] + 1);
    626             Home[p - av[i] + 1] = '\0';
    627          }
    628          break;
    629       }
    630    AV = av+1;
    631    heapAlloc();
    632    initSymbols();
    633    Reloc = Nil;
    634    InFile = stdin,  Env.get = getStdin;
    635    OutFile = stdout,  Env.put = putStdout;
    636    ApplyArgs = cons(cons(consSym(Nil,0), Nil), Nil);
    637    ApplyBody = cons(Nil,Nil);
    638    if (setjmp(ErrRst) < 0)
    639       prog(val(Rst));
    640    else {
    641       while (*AV  &&  strcmp(*AV,"-") != 0)
    642          load(NULL, 0, mkStr(*AV++));
    643       load(NULL, ':', Nil);
    644    }
    645    bye(0);
    646 }
	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