malisp.cpp

00001 #include "mbed.h"
00002 
00003 #include <stdio.h>
00004 #include <stdlib.h>
00005 #include <ctype.h>
00006 #include <string.h>
00007 #include "malisp.h"
00008 #include "mbed_functions.h"
00009 
00010 extern Serial pc;
00011 extern DigitalOut led1;
00012 extern DigitalOut led2;
00013 extern DigitalOut led3;
00014 extern DigitalOut led4;
00015 extern char *lisplib;
00016 
00017 int _stack = 5000;
00018 
00019 LIST *TRU;
00020 LIST *g_alist;      // 連想リスト
00021 LIST *g_oblist;     // list of Lisp Functions
00022 
00023 char progon;
00024 
00025 //FILE *fd;     // input file descriptor
00026 FILE_MINE   fd;
00027 
00028 int32_t  getc_mine_buffer_pt = 0;
00029 int      getc_mine_buffer[8];
00030 uint32_t lisplib_counter = 0;
00031 
00032 //----------------------------------------------------------------
00033 //int getc_mine(FILE *fd)
00034 int getc_mine(FILE_MINE fd)
00035 {
00036     if (getc_mine_buffer_pt > 0) {
00037         int c = getc_mine_buffer[getc_mine_buffer_pt];
00038         getc_mine_buffer_pt--;
00039         if (getc_mine_buffer_pt < 0) {
00040             getc_mine_buffer_pt = 0;
00041         }
00042         return c;
00043     }
00044 
00045     //return getc(fd);
00046     
00047     int c = 0;
00048     if (fd == FILE_SERIAL) {
00049         c = pc.getc();
00050         //pc.putc(c);
00051  
00052     } else if (fd == FILE_STRING) {
00053 
00054         if (lisplib_counter > strlen(lisplib)) {
00055             c = EOF;     // EOF
00056         } else {
00057             c = *(lisplib + lisplib_counter);
00058             lisplib_counter++;
00059         }
00060     }
00061     
00062     return c;
00063 }
00064 
00065 //void ungetc_mine(int c, FILE *fd)
00066 void ungetc_mine(int c, FILE_MINE fd)
00067 {
00068     getc_mine_buffer_pt++;
00069     getc_mine_buffer[getc_mine_buffer_pt] = c;
00070 }
00071 
00072 //----------------------------------------------------------------
00073 // main program
00074 //----------------------------------------------------------------
00075 
00076 void malisp_main()
00077 {
00078     initialize();
00079     pc.printf("\nMarc Adler's LISP Interpreter. (mbed port and expansion by ohneta)\n");
00080     load_library();
00081 
00082     pc.printf("[FREE-MEM: %d bytes]\n", _getFreeMemorySize());
00083 
00084     {
00085         fd = FILE_SERIAL;
00086         getc_mine_buffer_pt = 0;
00087         interpret_malisp();
00088     }
00089 }
00090 
00091 void interpret_malisp()
00092 {
00093     LIST *p = NULL;
00094     LIST *q = NULL;
00095     int c;
00096 
00097     while (EOF != (c = gettok())) {
00098         if (c == ERR) {
00099             continue;
00100         }
00101 
00102         switch (c) {
00103             case LPAREN:
00104                 getc_mine(fd);   // span the paren
00105                 q = makelist();
00106                 p = eval(q, g_alist);
00107                 break;
00108 
00109             case LETTER:
00110                 p = cdr(car(getid()));
00111                 break;
00112         }
00113 
00114         if (fd == FILE_SERIAL) {
00115             pc.printf("\n");
00116             pc.printf("value => ");
00117             if (p == NULL) {
00118                 pc.printf("nil");
00119             } else {
00120                 lisp_print(cons(p, NULL));
00121                 //lisp_print(p);
00122             }
00123             pc.printf("\n");
00124         }
00125     }
00126 }
00127 
00128 //----------------------------------------------------------------
00129 // initialization procedures
00130 //----------------------------------------------------------------
00131 
00132 void initialize()
00133 {
00134     init("'", QUOTE);
00135     init("car", FCAR);
00136     init("cond", COND);
00137     init("cdr", FCDR);
00138     init("defun", DEFUN);
00139     init("cons",FCONS);
00140     init("nil", NILL);
00141     init("atom",FATOM);
00142     init("prog",PROG);
00143     init("eq",  FEQ);
00144     init("go",  GO);
00145     init("setq",FSETQ);
00146     init("return",RETRN);
00147     init("print",PRINT);
00148     init("read", FREAD);
00149     init("rplaca",FREPLACA);
00150     init("rplacd",FREPLACD);
00151     init("apply", FAPPLY);
00152     init("eval",  FEVAL);
00153     init("and", FAND);
00154     init("or", FOR);
00155     init("not", FNOT);
00156     init("plus",  PLUS);
00157     init("zerop", ZEROP);
00158     init("diff",  DIFF);
00159     init("greaterp", GREATERP);
00160     init("times", TIMES);
00161     init("lessp", LESSP);
00162     init("add1",  ADD1);
00163     init("sub1",  SUB1);
00164     init("quot",  QUOTIENT);
00165     TRU = cons(init("t", T), NULL);
00166     init("numberp", NUMBERP);
00167     rplact(TRU, SATOM);
00168     init("null",  NUL);
00169     init("funcall",FUNCALL);
00170 
00171     // for mbed functions
00172     init("info", FINFO);
00173     init("freemem", FFREEMEM);
00174 
00175     init("wait", FWAIT);
00176     init("dout", FDOUT);
00177     init("din",  FDIN);
00178     init("aout", FAOUT);
00179     init("ain",  FAIN);
00180     init("pwmout", PWMOUT);
00181 
00182     g_oblist = g_alist;
00183 }
00184 
00185 LIST *init(char *name, int t)
00186 {
00187     LIST *p = install(name, false);
00188     rplact(p, t);
00189 
00190     return p;
00191 }
00192 
00193 //----------------------------------------------------------------
00194 // create the executable list form of a LISP program
00195 //----------------------------------------------------------------
00196 
00197 LIST *makelist()
00198 {
00199     LIST *p;
00200 
00201     switch (gettok()) {
00202         case LPAREN:
00203             getc_mine(fd);  // span the paren ?????
00204             p = makelist();
00205             p = cons(p, makelist());
00206             rplact(p, LST);
00207             return p;
00208 
00209         case LETTER:
00210             p = getid();
00211             return cons(p, makelist());
00212 
00213         case INQUOTE:
00214             p = getid();
00215             p = cons(p, makelist());
00216             rplaca(p, cons(car(p), cons(car(cdr(p)), NULL)));
00217             rplacd(p, cdr(cdr(p)));
00218             return p;
00219 
00220         case DIGIT:
00221             p = getnum();
00222             return cons(p, makelist());
00223 
00224         case RPAREN:
00225             getc_mine(fd);  // span rparen ??????
00226             return NULL;
00227     }
00228 
00229     return NULL;
00230 }
00231 
00232 
00233 // isp_print - walks along the list structure printing atoms
00234 void lisp_print(LIST *p)
00235 {
00236     if (p == NULL) {
00237         return;
00238     }
00239 
00240     if (type(p) == RATOM) {
00241         pc.printf("%f ", p->u.num);
00242     } else if (type(p) == IATOM) {
00243         pc.printf("%d ", (int) p->u.num);
00244     } else if (type(p) == SATOM) {
00245         pc.printf("%s ", getname(car(p)));
00246     } else if (type(car(p)) == LST) {
00247         pc.printf("%c", '(');
00248         lisp_print(car(p));
00249         pc.printf("%c", ')');
00250         lisp_print(cdr(p));
00251     } else if (type(p) == LST) {
00252         lisp_print(car(p));
00253         lisp_print(cdr(p));
00254     } else {
00255         pc.printf("******** can't print it out *******\n");
00256     }
00257 }
00258 
00259 //----------------------------------------------------------------
00260 // evaluate a LISP function
00261 //----------------------------------------------------------------
00262 
00263 LIST *eval(LIST *x, LIST *alist)
00264 {
00265     LIST *p, *q;
00266     int savt, t;
00267 
00268     if (x == NULL) {
00269         return NULL;
00270     }
00271     t = type(x);
00272     if (t == VARI) {
00273         return assoc(alist, getname(car(x)));
00274     }
00275     if (t == IATOM || t == RATOM) {
00276         return x;
00277     }
00278     if (t == LABL) {
00279         return NULL;
00280     }
00281 
00282     switch (type(car(x))) {
00283         case T:
00284             return TRU;
00285 
00286         case NILL:
00287             return NULL;
00288 
00289         case QUOTE:
00290             var_to_atom(car(cdr(x)));
00291             return car(cdr(x));
00292 
00293         case FCAR:
00294             return car(eval(cdr(x), alist));
00295 
00296         case FCDR:
00297             return cdr(eval(cdr(x), alist));
00298 
00299         case FATOM:
00300             return atom(eval(cdr(x), alist));
00301 
00302         case FEQ:
00303             return eq(eval(car(cdr(x)),alist), eval(cdr(cdr(x)),alist));
00304 
00305         case NUL:
00306             return eq(eval(car(cdr(x)), alist), NULL);
00307 
00308         case FCONS:
00309             return cons(eval(car(cdr(x)),alist), eval(cdr(cdr(x)), alist));
00310 
00311         case FLIST:
00312             return _list(x);
00313 
00314         case COND:
00315             return evalcond(cdr(x), alist);
00316 
00317         case FSETQ:
00318             p = eval(cdr(cdr(x)), alist);
00319             rplacd(getvar(alist, getname(car(car(cdr(x))))), p);
00320             return p;
00321 
00322         case DEFUN:
00323             rplact(car(car(cdr(x))), FUSER);
00324             rplacd(car(car(cdr(x))), cdr(cdr(x)));
00325             var_to_user(cdr(cdr(cdr(x))));
00326             if (fd == FILE_SERIAL) {
00327                 pc.printf("%s\n", getname(car(car(cdr(x)))));
00328             }
00329             return NULL;
00330 
00331         case FUSER:
00332             p = cdr(car(car(x)));   // p is statement list
00333             return eval(car(cdr(p)), pairargs(car(p), evalargs(cdr(x),alist), alist, FALSE));
00334 
00335         case FAPPLY:
00336         case FUNCALL:
00337             p = eval(car(cdr(x)), alist);   // func name
00338             if (isfunc(savt = type(car(p)))) {
00339                 p = cons(p, cdr(cdr(x)));
00340                 if (savt == FUSER) {
00341                     rplact(car(p), FUSER);
00342                 }
00343                 q = eval(p, alist);
00344                 rplact(car(p), savt);
00345                 return q;
00346             } else
00347                 return NULL;
00348 
00349         case FEVAL:
00350             p = eval(cdr(x), alist);
00351             if (type(p) == SATOM) {
00352                 return assoc(alist, getname(car(p)));
00353             }
00354             return eval(p, alist);
00355 
00356         case PRINT:
00357             lisp_print(eval(car(cdr(x)), alist));
00358             pc.printf("\n");
00359             return NULL;
00360 
00361         case FREAD:
00362             return makelist();
00363 
00364         case FAND:
00365             return _and(x);
00366         case FOR:
00367             return _or(x);
00368         case FNOT:
00369             return _not(x);
00370 
00371         case PLUS:
00372         case DIFF:
00373         case TIMES:
00374         case QUOTIENT:
00375         case GREATERP:
00376         case LESSP:
00377             return arith(car(x), eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist));
00378 
00379         case ADD1:
00380         case SUB1:
00381             return arith(car(x), eval(car(cdr(x)), alist), NULL);
00382 
00383         case ZEROP:
00384             p = eval(car(cdr(x)), alist);
00385             return  (p->u.num == 0) ? TRU : NULL;
00386 
00387         case NUMBERP:
00388             savt = type(eval(car(cdr(x)), alist));
00389             return (savt==IATOM || savt==RATOM) ? TRU : NULL;
00390 
00391         case PROG:
00392             return evalprog(x, alist);
00393 
00394         case GO:
00395             return cdr(car(car(cdr(x))));
00396 
00397         case RETRN:
00398             progon = FALSE;
00399             return eval(cdr(x), alist);
00400 
00401         case LST:
00402             if (cdr(x) == NULL) {
00403                 return eval(car(x), alist);
00404             }
00405             return cons(eval(car(x),alist),eval(cdr(x),alist));
00406 
00407         case VARI:
00408             return assoc(alist, getname(car(car(x))));
00409 
00410         case IATOM:
00411         case RATOM:
00412             return car(x);
00413 
00414 
00415 
00416         // mbed expand
00417         case FINFO:
00418         {
00419 pc.printf("\noblist --\n");
00420 debug(g_oblist);
00421 
00422             return NULL;
00423         }
00424         case FFREEMEM:
00425         {
00426             LIST * p = memfreesize();
00427             if (p != NULL) {
00428                 p->gcbit = GARBAGE;
00429             }
00430             return p;
00431         }
00432         case FWAIT:
00433         {
00434             LIST * p = mbed_wait(eval(car(cdr(x)), alist));
00435 /*
00436             if (p != NULL) {
00437                 p->gcbit = GARBAGE;
00438             }
00439 */
00440             return p;
00441         }
00442         case FDOUT:
00443             return mbed_digitalout(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist));
00444         case FDIN:
00445             return mbed_digitalin(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist));
00446         case FAOUT:
00447             return mbed_analogout(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist));
00448         case FAIN:
00449             return mbed_analogin(eval(car(cdr(x)), alist));
00450         case PWMOUT:
00451             return mbed_pwmout(eval(car(cdr(x)), alist), eval(car(cdr(cdr(x))), alist), eval(cdr(cdr(cdr(x))), alist));
00452     }
00453     
00454     return NULL;
00455 }
00456 
00457 
00458 LIST *evalcond(LIST *expr, LIST *alist)
00459 {
00460     if (expr == NULL) {
00461         return NULL;
00462     }
00463 
00464     if (eval(car(car(expr)), alist) != NULL) {      // expr was true
00465         return eval(car(cdr(car(expr))), alist);    // return result
00466     }
00467 
00468     return evalcond(cdr(expr), alist);        // eval rest of args
00469 }
00470 
00471 
00472 LIST *evalprog(LIST *p, LIST *alist)
00473 {
00474     LIST *x = NULL;
00475 
00476     // set up parameters as locals
00477     alist = pairargs(car(cdr(p)), cons(NULL, NULL), alist, TRUE);
00478     progon = TRUE;
00479     p = cdr(cdr(p));     /* p now points to the statement list */
00480     find_labels(p);  /* set up all labels in the prog */
00481 
00482     while (p != NULL && progon) {
00483         x = eval(car(p), alist);
00484         if (type(car(car(p))) == GO) {
00485             p = x;       /* GO returned the next statement to go to */
00486         } else {
00487             p = cdr(p);  /* just follow regular chain of statements */
00488 
00489         }
00490     }
00491 
00492     progon = TRUE;   /* in case of nested progs */
00493     return x;
00494 }
00495 
00496 // pairargs - installs parameters in the alist, and sets the value to be the value of the corresponding argument.
00497 LIST *pairargs(LIST *params, LIST *args, LIST *alist, int prog)
00498 {
00499     if (params == NULL) {  // no more args to be evaluated
00500         return alist;
00501     }
00502 
00503     LIST *p = cons(NULL, car(args));  // value of param is corresponding arg
00504     p->u.pname = getname(car(car(params)));
00505     rplact(p, VARI);
00506     if (prog) {
00507         return cons(p, pairargs(cdr(params), cons(NULL,NULL), alist, prog));
00508     }
00509 
00510     return cons(p, pairargs(cdr(params), cdr(args),   alist, prog));
00511 }
00512 
00513 LIST *evalargs(LIST *arglist, LIST *alist)
00514 {
00515     if (arglist == NULL) {
00516         return NULL;
00517     }
00518 
00519     return cons(eval(car(arglist),alist), evalargs(cdr(arglist), alist));
00520 }
00521 
00522 LIST *assoc( LIST *alist, char *name)
00523 {
00524     return cdr(getvar(alist, name));
00525 }
00526 
00527 LIST *getvar(LIST *alist, char *name)
00528 {
00529     return lookup(alist, name);
00530 }
00531 
00532 // arith - performs arithmetic on numeric items
00533 LIST *arith(LIST *op, LIST *x, LIST *y)
00534 {
00535     LIST *p;
00536     float res = 0;
00537     int t = type(op);
00538 
00539     if (t == LESSP) {
00540         return (x->u.num < y->u.num) ? TRU : NULL;
00541     }
00542     if (t == GREATERP) {
00543         return (x->u.num > y->u.num) ? TRU : NULL;
00544     }
00545 
00546     switch (t) {
00547         case PLUS:
00548             res = x->u.num + y->u.num;
00549             break;
00550         case DIFF:
00551             res = x->u.num - y->u.num;
00552             break;
00553         case TIMES:
00554             res = x->u.num * y->u.num;
00555             break;
00556         case QUOTIENT:
00557             res = x->u.num / y->u.num;
00558             break;
00559         case ADD1:
00560             res = x->u.num + 1;
00561             break;
00562         case SUB1:
00563             res = x->u.num - 1;
00564             break;
00565     }
00566 
00567     p = cons(NULL, NULL);
00568 
00569 // @TODO: tがADD1かSUB1の場合、yは必ずNULLなので、 type(y)を実行するとエラーだと思うんだが...
00570 /*
00571     if (    (type(x) == IATOM) &&
00572             (type(y) == IATOM) ||
00573                 (t == ADD1) || (t == SUB1)  )
00574         ) {
00575 */
00576     if ((type(x) == IATOM) && ((t == ADD1) || (t == SUB1))) {
00577         p->u.num = (int)res;
00578         rplact(p, IATOM);
00579     } else {
00580         p->u.num = res;
00581         rplact(p, RATOM);
00582     }
00583     
00584     return p;
00585 }
00586 
00587 //----------------------------------------------------------------
00588 // input functions
00589 //----------------------------------------------------------------
00590 
00591 // advance - skips white space in input file
00592 int advance()
00593 {
00594     int c;
00595 #if 0
00596     while (((c = getc_mine(fd)) != EOF) && (strchr(" \t\n", c) != NULL));
00597 #else
00598     while (1) {
00599         c = getc_mine(fd);
00600         if (c == EOF) {
00601             break;
00602         }
00603         if (strchr(" \t\n\r", c) == NULL) {
00604             break;
00605         }
00606     }
00607 #endif
00608     ungetc_mine(c, fd);
00609 //pc.printf("%c", c);
00610 
00611     return c;
00612 }
00613 
00614 LIST *lookup(LIST *head, char *name)
00615 {
00616     LIST *p;
00617 
00618 #if 0
00619     for (p = head; p != NULL && strcmp(name, getname(car(p))); p = cdr(p)) {
00620         ;
00621     }
00622 #else
00623     p = head;
00624     while (p != NULL) {
00625         if (strcmp(name, getname(car(p))) == 0) {
00626             break;
00627         }
00628         p = cdr(p);
00629     }
00630 #endif
00631 
00632     return ((p == NULL) ? NULL : car(p));
00633 }
00634 
00635 /**
00636  * nameをalistに加える
00637  *
00638  * @param char *name alistに加える名前
00639  * @param bool nameCopyFlag nameをコピーするか否か。 true=コピーする、1=コピーしない(nameがconstな文字列)
00640  */
00641 LIST *install(char *name, bool nameCopyFlag = true)
00642 {
00643     LIST *p = cons(NULL, NULL);
00644 
00645     if (nameCopyFlag) {
00646         p->u.pname = (char *)emalloc(strlen(name) + 1);
00647         strcpy(p->u.pname, name);
00648     } else {
00649         p->u.pname = name;
00650     }
00651 
00652     rplact(p, VARI);
00653     g_alist = cons(p, g_alist);
00654 
00655     return p;
00656 }
00657 
00658 LIST *getnum()
00659 {
00660     LIST *p;
00661     float sum, n;
00662     int c;
00663 
00664     sum = 0.0;
00665     p = cons(NULL, NULL);
00666     rplact(p, IATOM);
00667 
00668     while (isdigit(c = getc_mine(fd))) {
00669         sum = sum * 10 + c - '0';
00670     }
00671 
00672     if (c == '.') {  /* the number is real */
00673         n = 10;
00674         rplact(p, RATOM);
00675         //while (isdigit(c = getc(fd))) {
00676         while (isdigit(c = getc_mine(fd))) {
00677                 sum += (c - '0')/n;
00678             n *= 10;
00679         }
00680     }
00681 
00682     ungetc_mine(c, fd);
00683     p->u.num = sum;
00684 
00685     return p;
00686 }
00687 
00688 LIST *getid()
00689 {
00690     LIST *p;
00691 
00692     char inbuf[120];    // トークン　１つ分のバッファ
00693     char *s = inbuf;
00694     LIST *idptr;
00695 
00696     // トークンを取得する
00697     {
00698         int c = getc_mine(fd);
00699         *s = c;
00700         s++;
00701         if (c != '\'') {
00702             while(1) {
00703                 c = getc_mine(fd);
00704                 if (!isalnum(c)) {
00705                     ungetc_mine(c, fd);
00706                     break;
00707                 }
00708                 *s = c;
00709                 s++;
00710             }
00711         }
00712         *s = '\0';
00713     }
00714 
00715     if ((idptr = lookup(g_oblist, inbuf)) == NULL) {    // not a LISP function
00716         if ((idptr = lookup(g_alist, inbuf)) == NULL) { // id not declared yet
00717             idptr = install(inbuf, true);               // install it in g_alist (alist)
00718         }
00719     }
00720     p = cons(idptr, NULL);
00721     rplact(p, type(idptr));
00722 
00723     return p;
00724 }
00725 
00726 int gettok()
00727 {
00728     int c;
00729  
00730     while ((c = advance()) == ';') {    // saw a comment
00731         while (1) {
00732             c = getc_mine(fd);
00733             if ((c == EOF) || (c == '\n')) { // EOF or CR
00734                 break;
00735             }
00736         }
00737     }
00738 
00739     if (isalpha(c)) {
00740         return LETTER;
00741     }
00742     if (isdigit(c)) {
00743         return DIGIT;
00744     }
00745     switch (c) {
00746         case '(':
00747             return LPAREN;
00748         case ')':
00749             return RPAREN;
00750         case '\'':
00751             return INQUOTE;
00752         case EOF:
00753             return EOF;
00754     }
00755     
00756     return ERR;
00757 }
00758 
00759 //----------------------------------------------------------------
00760 // LISP primitive functions
00761 //----------------------------------------------------------------
00762 
00763 // new - gets a new node from the free storage
00764 LIST *new_malisp()
00765 {
00766     LIST *p = (struct LIST *)emalloc(sizeof(LIST));
00767     p->gcbit = RUNNING;
00768 
00769     return p;
00770 }
00771 
00772 int type(LIST *p)
00773 {
00774     return p->htype;
00775 }
00776 
00777 char* getname(LIST *p)
00778 {
00779     return (p == NULL) ? NULL : p->u.pname;
00780 }
00781 
00782 // pのcar部をqに置き換える
00783 void rplaca(LIST *p, LIST *q)
00784 {
00785     p->left = q;
00786 }
00787 
00788 // pのcdr部をqに置き換える
00789 void rplacd(LIST *p, LIST *q)
00790 {
00791     p->right = q;
00792 }
00793 
00794 // pのタイプ(htype)をtに置き換える
00795 void rplact(LIST *p, int t)
00796 {
00797     p->htype = t;
00798 }
00799 
00800 LIST *car(LIST *p)
00801 {
00802     return (p == NULL) ? NULL : p->left;
00803 }
00804 
00805 LIST *cdr(LIST *p)
00806 {
00807     return (p == NULL) ? NULL : p->right;
00808 }
00809 
00810 LIST *cons(LIST *p, LIST *q)
00811 {
00812     LIST *x = new_malisp();
00813 
00814     rplaca(x, p);
00815     rplacd(x, q);
00816     rplact(x, LST);
00817 
00818     return x;
00819 }
00820 
00821 LIST *eq(LIST *x, LIST *y)
00822 {
00823     if (x == NULL || y == NULL) {
00824         if (x == y) {
00825             return TRU;
00826         }
00827     } else if ( (type(x) == SATOM) &&
00828                 (type(y) == SATOM) &&
00829                 (car(x) == car(y))  ) {
00830         return TRU;
00831     }
00832 
00833     return NULL;
00834 }
00835 
00836 LIST *atom(LIST *x)
00837 {
00838 #if 0
00839     int typ;
00840 
00841     if (x == NULL || (typ = type(x)) == IATOM || typ == RATOM || typ == SATOM) {
00842         return TRU;
00843     }
00844 #else
00845     if (x == NULL) {
00846         return TRU;
00847     }
00848     
00849     int typ = type(x);
00850     if (typ == IATOM) {
00851          return TRU;
00852     }
00853     if (typ == RATOM) {
00854          return TRU;
00855     }
00856     if (typ == SATOM) {
00857          return TRU;
00858     }
00859 #endif
00860     return NULL;
00861 }
00862 
00863 //----------------------------------------------------------------
00864 // logical connectives - and, or, not
00865 
00866 LIST *_and(LIST *x)
00867 {
00868     LIST *p;
00869     for (p = cdr(x); p != NULL; p = cdr(p)) {
00870         if (eval(car(p), NULL) == NULL) {
00871             return NULL;
00872         }
00873     }
00874 
00875     return TRU;
00876 }
00877 
00878 LIST *_or(LIST *x)
00879 {
00880     LIST *p;
00881     for (p = cdr(x); p != NULL; p = cdr(p)) {
00882         if (eval(car(p), NULL) != NULL) {
00883             return TRU;
00884         }
00885     }
00886 
00887     return NULL;
00888 }
00889 
00890 LIST *_not(LIST *x)
00891 {
00892     return (eval(cdr(x), NULL) == NULL) ? TRU : NULL;
00893 }
00894 
00895 // other primitives
00896 
00897 LIST *_list(LIST *x)
00898 {
00899     LIST *res, *p;
00900 
00901     for (res = NULL, p = cdr(x);  p != NULL;  p = cdr(p)) {
00902         res = cons(res, car(p));
00903     }
00904 
00905     return res;
00906 }
00907 
00908 
00909 void var_to_user(LIST *p)
00910 {
00911     if (p == NULL) {
00912         return;
00913     }
00914 
00915     if (type(p) == VARI) {
00916         if (type(car(p)) == FUSER) {
00917             rplact(p, FUSER);
00918         }
00919     } else if (type(p) == LST) {
00920         var_to_user(car(p));
00921         var_to_user(cdr(p));
00922     }
00923 }
00924 
00925 void var_to_atom(LIST *p)
00926 {
00927     int t;
00928 
00929     if (p != NULL) {
00930         if (((t = type(p)) != LST && !isfunc(t)) || t == FUSER) {
00931             rplact(p, SATOM);
00932         } else {
00933             var_to_atom(car(p));   var_to_atom(cdr(p));
00934         }
00935     }
00936 }
00937 
00938 // find_labels - change the type of all labels in a PROG to LABL
00939 void find_labels(LIST *p)
00940 {
00941     for ( ;  p != NULL;  p = cdr(p)) {
00942         if (type(car(p)) == VARI) {
00943             rplact(car(p), LABL);           // change the type to LABL
00944             rplacd(car(car(p)), cdr(p));    // label points to next statement
00945         }
00946     }
00947 }
00948 
00949 //----------------------------------------------------------------
00950 // garbage collection
00951 //----------------------------------------------------------------
00952 
00953 void work_garbageCollect(LIST *p)
00954 {
00955     int cnt = 0;
00956     while (p != NULL) {
00957 
00958         int t = type(p);
00959 
00960         pc.printf("[%d] ", cnt);
00961         pc.printf("(%d) ", t);
00962         if ((t == IATOM) || (t == RATOM)) {
00963             pc.printf("[%f ] : ", p->u.num);
00964         } else if (t == SATOM) {
00965             pc.printf("[%s ] : ", p->u.pname);
00966         } else {
00967             pc.printf(" : ");
00968         }
00969 
00970         //pc.printf("%d : ", (p->gcbit >> 16) & 0xff);    // num
00971         //pc.printf("%d \n", (p->gcbit & 0xff));          // bit (USED/RUNNING)
00972         
00973         p = cdr(p);
00974         cnt++;
00975     }
00976 }
00977 
00978 //  marktree - recursively marks all used items in a list
00979 void marktree(LIST *p)
00980 {
00981     if (p != NULL) {
00982         if (type(p) == LST) {
00983             marktree(car(p));
00984             marktree(cdr(p));
00985         }
00986         p->gcbit = USED;
00987     }
00988 }
00989 
00990 /*********************** storage allocator *****************/
00991 
00992 void *emalloc(size_t size)
00993 {
00994     void *s;
00995 
00996     if ((s = malloc(size)) == NULL) {
00997         pc.printf("OUT OF MEMORY !! : crashed !! \n");
00998         exit(0);
00999     }
01000 
01001     return s;
01002 }
01003 
01004 // routine to load the library of lisp functions in
01005 void load_library(void)
01006 {
01007 #if 0
01008     char libpath[1024];
01009     strcpy(libpath, getenv("HOME"));
01010     strcat(libpath, "/lisplib");
01011     
01012     if ((fd = fopen(libpath, "r")) !=  NULL) {
01013         interpret_malisp();
01014         fclose(fd);
01015         
01016         pc.printf("loaded lisplib from %s\n", libpath);
01017     }
01018     interpret_malisp();
01019     
01020     fd = stdin;
01021 #else
01022 
01023     fd = FILE_STRING;
01024     interpret_malisp();
01025     pc.printf("loaded lisplib from flash\n");
01026 
01027     fd = FILE_SERIAL;
01028 
01029 #endif
01030 }
01031 
01032 // isfunc - returns YES if type t is a user-function or a lisp primitive
01033 int isfunc(int t)
01034 {
01035     return
01036         (   t==FUSER || t==ADD1 || t==SUB1 || t==PLUS || t==DIFF || t==TIMES ||
01037             t==QUOTIENT || t==LESSP || t==GREATERP || t==ZEROP || t==NUMBERP ||
01038             t==FCAR || t==FCDR || t==FCONS || t==FREAD || t==PRINT || t==FNOT||
01039             t==FAND || t==FOR  || t==FEVAL || t==FEQ || t==FATOM ||
01040 
01041             // mbed extends
01042             t == FFREEMEM || t == FWAIT || t == FDOUT || t == FDIN ||
01043             t == FAOUT || t == FAIN || t == PWMOUT
01044         );
01045 }
01046 
01047 void debug(LIST *p)
01048 {
01049     pc.printf("DEBUG ---\n");
01050     debug2(p);
01051     pc.printf("\n");
01052 }
01053 
01054 void debug2(LIST *p)
01055 {
01056   int t;
01057 
01058   if (p != NULL) {
01059     if ((t = type(p)) == LST) {
01060         pc.printf("(");
01061         debug2(car(p));
01062         debug2(cdr(p));
01063         pc.printf(")");
01064     } else if (t == RATOM) {
01065         pc.printf("RATOM %f ", p->u.num);
01066     } else if (t == IATOM) {
01067         pc.printf("IATOM %d ", (int) p->u.num);
01068     } else if (t == SATOM) {
01069         pc.printf("SATOM %s ", getname(car(p)));
01070     } else {
01071         pc.printf("FUNC %d ", type(p));
01072     }
01073   }
01074 }