Lisp Interpreter for mbed LPC1768
Lisp Interpreter
(Marc Adler Lisp Interpreter, malisp)
mbed LPC1768 port by Takehisa Oneta (ohneta@gmail.com)
malisp.cpp
- Committer:
- ohneta
- Date:
- 2016-04-17
- Revision:
- 0:e9a7a38d9ad3
- Child:
- 1:a2955606adef
File content as of revision 0:e9a7a38d9ad3:
#include "mbed.h" #include <stdio.h> #include <stdlib.h> #include <ctype.h> #include <string.h> #include "malisp.h" #include "mbed_functions.h" extern Serial pc; extern DigitalOut led1; extern DigitalOut led2; extern DigitalOut led3; extern DigitalOut led4; extern char *lisplib; int _stack = 5000; LIST *TRU; LIST *g_alist; // 連想リスト LIST *g_oblist; // list of Lisp Functions char progon; //FILE *fd; // input file descriptor FILE_MINE fd; int32_t getc_mine_buffer_pt = 0; int getc_mine_buffer[8]; uint32_t lisplib_counter = 0; //---------------------------------------------------------------- //int getc_mine(FILE *fd) int getc_mine(FILE_MINE fd) { if (getc_mine_buffer_pt > 0) { int c = getc_mine_buffer[getc_mine_buffer_pt]; getc_mine_buffer_pt--; if (getc_mine_buffer_pt < 0) { getc_mine_buffer_pt = 0; } return c; } //return getc(fd); int c = 0; if (fd == FILE_SERIAL) { c = pc.getc(); //pc.putc(c); } else if (fd == FILE_STRING) { if (lisplib_counter > strlen(lisplib)) { c = EOF; // EOF } else { c = *(lisplib + lisplib_counter); lisplib_counter++; } } return c; } //void ungetc_mine(int c, FILE *fd) void ungetc_mine(int c, FILE_MINE fd) { getc_mine_buffer_pt++; getc_mine_buffer[getc_mine_buffer_pt] = c; } //---------------------------------------------------------------- // main program //---------------------------------------------------------------- void malisp_main() { initialize(); pc.printf("\nMarc Adler's LISP Interpreter. (mbed port and expansion by ohneta)\n"); load_library(); pc.printf("[FREE-MEM: %d bytes]\n", _getFreeMemorySize()); { fd = FILE_SERIAL; getc_mine_buffer_pt = 0; interpret_malisp(); } } void interpret_malisp() { LIST *p = NULL; LIST *q = NULL; int c; while (EOF != (c = gettok())) { if (c == ERR) { continue; } switch (c) { case LPAREN: getc_mine(fd); // span the paren q = makelist(); p = eval(q, g_alist); break; case LETTER: p = cdr(car(getid())); break; } if (fd == FILE_SERIAL) { pc.printf("\n"); pc.printf("value => "); if (p == NULL) { pc.printf("nil"); } else { lisp_print(cons(p, NULL)); //lisp_print(p); } pc.printf("\n"); } } } //---------------------------------------------------------------- // initialization procedures //---------------------------------------------------------------- void initialize() { init("'", QUOTE); init("car", FCAR); init("cond", COND); init("cdr", FCDR); init("defun", DEFUN); init("cons",FCONS); init("nil", NILL); init("atom",FATOM); init("prog",PROG); init("eq", FEQ); init("go", GO); init("setq",FSETQ); init("return",RETRN); init("print",PRINT); init("read", FREAD); init("rplaca",FREPLACA); init("rplacd",FREPLACD); init("apply", FAPPLY); init("eval", FEVAL); init("and", FAND); init("or", FOR); init("not", FNOT); init("plus", PLUS); init("zerop", ZEROP); init("diff", DIFF); init("greaterp", GREATERP); init("times", TIMES); init("lessp", LESSP); init("add1", ADD1); init("sub1", SUB1); init("quot", QUOTIENT); TRU = cons(init("t",T), NULL); init("numberp",NUMBERP); rplact(TRU, SATOM); init("null", NUL); init("funcall",FUNCALL); // for mbed functions init("info", FINFO); init("freemem", FFREEMEM); init("wait", FWAIT); init("dout", FDOUT); init("din", FDIN); init("aout", FAOUT); init("ain", FAIN); init("pwmout", PWMOUT); g_oblist = g_alist; } LIST *init(char *name, int t) { LIST *p; p = install(name, 1); rplact(p, t); return p; } //---------------------------------------------------------------- // create the executable list form of a LISP program //---------------------------------------------------------------- LIST *makelist() { LIST *p; switch (gettok()) { case LPAREN: getc_mine(fd); // span the paren ????? p = makelist(); p = cons(p, makelist()); rplact(p, LST); return p; case LETTER: p = getid(); return cons(p, makelist()); case INQUOTE: p = getid(); p = cons(p, makelist()); rplaca(p, cons(car(p), cons(car(cdr(p)), NULL))); rplacd(p, cdr(cdr(p))); return p; case DIGIT: p = getnum(); return cons(p, makelist()); case RPAREN: getc_mine(fd); // span rparen ?????? return NULL; } return NULL; } // isp_print - walks along the list structure printing atoms void lisp_print(LIST *p) { if (p != NULL) { if (type(p) == RATOM) { pc.printf("%f ", p->u.num); } else if (type(p) == IATOM) { pc.printf("%d ", (int) p->u.num); } else if (type(p) == SATOM) { pc.printf("%s ", getname(car(p))); } else if (type(car(p)) == LST) { pc.printf("%c", '('); lisp_print(car(p)); pc.printf("%c", ')'); lisp_print(cdr(p)); } else if (type(p) == LST) { lisp_print(car(p)); lisp_print(cdr(p)); } else { pc.printf("******** can't print it out *******\n"); } } } //---------------------------------------------------------------- // evaluate a LISP function //---------------------------------------------------------------- LIST *eval(LIST *x, LIST *alist) { LIST *p, *q; int savt, t; if (x == NULL) { return NULL; } t = type(x); if (t == VARI) { return assoc(alist, getname(car(x))); } if (t == IATOM || t == RATOM) { return x; } if (t == LABL) { return NULL; } switch (type(car(x))) { case T: return TRU; case NILL: return NULL; case QUOTE: var_to_atom(car(cdr(x))); return car(cdr(x)); case FCAR: return car(eval(cdr(x), alist)); case FCDR: return cdr(eval(cdr(x), alist)); case FATOM: return atom(eval(cdr(x), alist)); case FEQ: return eq(eval(car(cdr(x)),alist), eval(cdr(cdr(x)),alist)); case NUL: return eq(eval(car(cdr(x)), alist), NULL); case FCONS: return cons(eval(car(cdr(x)),alist), eval(cdr(cdr(x)), alist)); case FLIST: return _list(x); case COND: return evalcond(cdr(x), alist); case FSETQ: p = eval(cdr(cdr(x)), alist); rplacd(getvar(alist, getname(car(car(cdr(x))))), p); return p; case DEFUN: rplact(car(car(cdr(x))), FUSER); rplacd(car(car(cdr(x))), cdr(cdr(x))); var_to_user(cdr(cdr(cdr(x)))); if (fd == FILE_SERIAL) { pc.printf("%s\n", getname(car(car(cdr(x))))); } return NULL; case FUSER: p = cdr(car(car(x))); // p is statement list return eval(car(cdr(p)), pairargs(car(p), evalargs(cdr(x),alist), alist, FALSE)); case FAPPLY: case FUNCALL: p = eval(car(cdr(x)), alist); // func name if (isfunc(savt = type(car(p)))) { p = cons(p, cdr(cdr(x))); if (savt == FUSER) { rplact(car(p), FUSER); } q = eval(p, alist); rplact(car(p), savt); return q; } else return NULL; case FEVAL: p = eval(cdr(x), alist); if (type(p) == SATOM) { return assoc(alist, getname(car(p))); } return eval(p, alist); case PRINT: lisp_print(eval(car(cdr(x)), alist)); pc.printf("\n"); return NULL; case FREAD: return makelist(); case FAND: return _and(x); case FOR: return _or(x); case FNOT: return _not(x); case PLUS: case DIFF: case TIMES: case QUOTIENT: case GREATERP: case LESSP: return arith(car(x), eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist)); case ADD1: case SUB1: return arith(car(x), eval(car(cdr(x)), alist), NULL); case ZEROP: p = eval(car(cdr(x)), alist); return (p->u.num == 0) ? TRU : NULL; case NUMBERP: savt = type(eval(car(cdr(x)), alist)); return (savt==IATOM || savt==RATOM) ? TRU : NULL; case PROG: return evalprog(x, alist); case GO: return cdr(car(car(cdr(x)))); case RETRN: progon = FALSE; return eval(cdr(x), alist); case LST: if (cdr(x) == NULL) { return eval(car(x), alist); } return cons(eval(car(x),alist),eval(cdr(x),alist)); case VARI: return assoc(alist, getname(car(car(x)))); case IATOM: case RATOM: return car(x); // mbed expand case FINFO: { /* pc.printf("alist --\n"); work_garbageCollect(g_alist); pc.printf("oblist --\n"); work_garbageCollect(g_oblist); */ //pc.printf("alist --\n"); //debug(g_alist); pc.printf("\noblist --\n"); debug(g_oblist); return NULL; } case FFREEMEM: { LIST * p = memfreesize(); if (p != NULL) { p->gcbit = GARBAGE; } return p; } case FWAIT: { LIST * p = mbed_wait(eval(car(cdr(x)), alist)); if (p != NULL) { p->gcbit = GARBAGE; } return p; } case FDOUT: return mbed_digitalout(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist)); case FDIN: return mbed_digitalin(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist)); case FAOUT: return mbed_analogout(eval(car(cdr(x)), alist), eval(cdr(cdr(x)), alist)); case FAIN: return mbed_analogin(eval(car(cdr(x)), alist)); case PWMOUT: return mbed_pwmout(eval(car(cdr(x)), alist), eval(car(cdr(cdr(x))), alist), eval(cdr(cdr(cdr(x))), alist)); } return NULL; } LIST *evalcond(LIST *expr, LIST *alist) { if (expr == NULL) { return NULL; } if (eval(car(car(expr)), alist) != NULL) { // expr was true return eval(car(cdr(car(expr))), alist); // return result } return evalcond(cdr(expr), alist); // eval rest of args } LIST *evalprog(LIST *p, LIST *alist) { LIST *x = NULL; // set up parameters as locals alist = pairargs(car(cdr(p)), cons(NULL, NULL), alist, TRUE); progon = TRUE; p = cdr(cdr(p)); /* p now points to the statement list */ find_labels(p); /* set up all labels in the prog */ while (p != NULL && progon) { x = eval(car(p), alist); if (type(car(car(p))) == GO) { p = x; /* GO returned the next statement to go to */ } else { p = cdr(p); /* just follow regular chain of statements */ } } progon = TRUE; /* in case of nested progs */ return x; } // pairargs - installs parameters in the alist, and sets the value to be the value of the corresponding argument. LIST *pairargs(LIST *params, LIST *args, LIST *alist, int prog) { if (params == NULL) { // no more args to be evaluated return alist; } LIST *p = cons(NULL, car(args)); // value of param is corresponding arg p->u.pname = getname(car(car(params))); rplact(p, VARI); if (prog) { return cons(p, pairargs(cdr(params), cons(NULL,NULL), alist, prog)); } return cons(p, pairargs(cdr(params), cdr(args), alist, prog)); } LIST *evalargs(LIST *arglist, LIST *alist) { if (arglist == NULL) { return NULL; } return cons(eval(car(arglist),alist), evalargs(cdr(arglist), alist)); } LIST *assoc( LIST *alist, char *name) { return cdr(getvar(alist, name)); } LIST *getvar(LIST *alist, char *name) { return lookup(alist, name); } // arith - performs arithmetic on numeric items LIST *arith(LIST *op, LIST *x, LIST *y) { LIST *p; float res = 0; int t = type(op); if (t == LESSP) { return (x->u.num < y->u.num) ? TRU : NULL; } if (t == GREATERP) { return (x->u.num > y->u.num) ? TRU : NULL; } switch (t) { case PLUS: res = x->u.num + y->u.num; break; case DIFF: res = x->u.num - y->u.num; break; case TIMES: res = x->u.num * y->u.num; break; case QUOTIENT: res = x->u.num / y->u.num; break; case ADD1: res = x->u.num + 1; break; case SUB1: res = x->u.num - 1; break; } p = cons(NULL, NULL); // @TODO: tがADD1かSUB1の場合、yは必ずNULLなので、 type(y)を実行するとエラーだと思うんだが... /* if ( (type(x) == IATOM) && (type(y) == IATOM) || (t == ADD1) || (t == SUB1) ) ) { */ if ((type(x) == IATOM) && ((t == ADD1) || (t == SUB1))) { p->u.num = (int)res; rplact(p, IATOM); } else { p->u.num = res; rplact(p, RATOM); } return p; } //---------------------------------------------------------------- // input functions //---------------------------------------------------------------- // advance - skips white space in input file int advance() { int c; #if 0 while (((c = getc_mine(fd)) != EOF) && (strchr(" \t\n", c) != NULL)); #else while (1) { c = getc_mine(fd); if (c == EOF) { break; } if (strchr(" \t\n\r", c) == NULL) { break; } } #endif ungetc_mine(c, fd); //pc.printf("%c", c); return c; } LIST *lookup(LIST *head, char *name) { LIST *p; #if 0 for (p = head; p != NULL && strcmp(name, getname(car(p))); p = cdr(p)) { ; } #else p = head; while (p != NULL) { if (strcmp(name, getname(car(p))) == 0) { break; } p = cdr(p); } #endif return ((p == NULL) ? NULL : car(p)); } LIST *install(char *name, int nameConstKind = 0) { LIST *p; p = cons(NULL, NULL); #if 0 strcpy(p->u.pname = (char *)emalloc(strlen(name) + 1), name); #else if (nameConstKind == 0) { p->u.pname = (char *)emalloc(strlen(name) + 1); strcpy(p->u.pname, name); } else { p->u.pname = name; } #endif rplact(p, VARI); g_alist = cons(p, g_alist); return p; } LIST *getnum() { LIST *p; float sum, n; int c; sum = 0.0; p = cons(NULL, NULL); rplact(p, IATOM); while (isdigit(c = getc_mine(fd))) { sum = sum * 10 + c - '0'; } if (c == '.') { /* the number is real */ n = 10; rplact(p, RATOM); //while (isdigit(c = getc(fd))) { while (isdigit(c = getc_mine(fd))) { sum += (c - '0')/n; n *= 10; } } ungetc_mine(c, fd); p->u.num = sum; return p; } LIST *getid() { LIST *p; char inbuf[120]; char *s = inbuf; LIST *idptr; int c = getc_mine(fd); *s = c; s++; if (c != '\'') { while(1) { c = getc_mine(fd); if (!isalnum(c)) { ungetc_mine(c, fd); break; } *s = c; s++; } } *s = '\0'; if ((idptr = lookup(g_oblist, inbuf)) == NULL) { // not a LISP function if ((idptr = lookup(g_alist, inbuf)) == NULL) { // id not declared yet idptr = install(inbuf, 0); // install it in g_alist (alist) } } p = cons(idptr, NULL); rplact(p, type(idptr)); return p; } int gettok() { int c; while ((c = advance()) == ';') { // saw a comment while (1) { c = getc_mine(fd); if ((c == EOF) || (c == '\n')) { // EOF or CR break; } } } if (isalpha(c)) { return LETTER; } if (isdigit(c)) { return DIGIT; } switch (c) { case '(': return LPAREN; case ')': return RPAREN; case '\'': return INQUOTE; case EOF: return EOF; } return ERR; } //---------------------------------------------------------------- // LISP primitive functions //---------------------------------------------------------------- // new - gets a new node from the free storage LIST *new_malisp() { LIST *p = (struct LIST *)emalloc(sizeof(LIST)); p->gcbit = RUNNING; return p; } int type(LIST *p) { return p->htype; } char* getname(LIST *p) { return (p == NULL) ? NULL : p->u.pname; } // pのcar部をqに置き換える void rplaca(LIST *p, LIST *q) { p->left = q; } // pのcdr部をqに置き換える void rplacd(LIST *p, LIST *q) { p->right = q; } // pのタイプ(htype)をtに置き換える void rplact(LIST *p, int t) { p->htype = t; } LIST *car(LIST *p) { return (p == NULL) ? NULL : p->left; } LIST *cdr(LIST *p) { return (p == NULL) ? NULL : p->right; } LIST *cons(LIST *p, LIST *q) { LIST *x = new_malisp(); /* // for debug { static int num = 0; x->gcbit = (num << 16) | x->gcbit; pc.printf("cons-num(%08x): %d\n", x->gcbit, num); num++; } */ rplaca(x, p); rplacd(x, q); rplact(x, LST); return x; } LIST *eq(LIST *x, LIST *y) { if (x == NULL || y == NULL) { if (x == y) { return TRU; } } else if (type(x) == SATOM && type(y) == SATOM && car(x) == car(y)) { return TRU; } return NULL; } LIST *atom(LIST *x) { int typ; if (x == NULL || (typ = type(x)) == IATOM || typ == RATOM || typ == SATOM) { return TRU; } return NULL; } //---------------------------------------------------------------- // logical connectives - and, or, not LIST *_and(LIST *x) { LIST *p; for (p = cdr(x); p != NULL; p = cdr(p)) { if (eval(car(p), NULL) == NULL) { return NULL; } } return TRU; } LIST *_or(LIST *x) { LIST *p; for (p = cdr(x); p != NULL; p = cdr(p)) { if (eval(car(p), NULL) != NULL) { return TRU; } } return NULL; } LIST *_not(LIST *x) { return (eval(cdr(x), NULL) == NULL) ? TRU : NULL; } // other primitives LIST *_list(LIST *x) { LIST *res, *p; for (res = NULL, p = cdr(x); p != NULL; p = cdr(p)) { res = cons(res, car(p)); } return res; } void var_to_user(LIST *p) { if (p == NULL) { return; } if (type(p) == VARI) { if (type(car(p)) == FUSER) { rplact(p, FUSER); } } else if (type(p) == LST) { var_to_user(car(p)); var_to_user(cdr(p)); } } void var_to_atom(LIST *p) { int t; if (p != NULL) { if (((t = type(p)) != LST && !isfunc(t)) || t == FUSER) { rplact(p, SATOM); } else { var_to_atom(car(p)); var_to_atom(cdr(p)); } } } // find_labels - change the type of all labels in a PROG to LABL void find_labels(LIST *p) { for ( ; p != NULL; p = cdr(p)) { if (type(car(p)) == VARI) { rplact(car(p), LABL); // change the type to LABL rplacd(car(car(p)), cdr(p)); // label points to next statement } } } //---------------------------------------------------------------- // garbage collection //---------------------------------------------------------------- void work_garbageCollect(LIST *p) { int cnt = 0; while (p != NULL) { int t = type(p); pc.printf("[%d] ", cnt); pc.printf("(%d) ", t); if ((t == IATOM) || (t == RATOM)) { pc.printf("[%f ] : ", p->u.num); } else if (t == SATOM) { pc.printf("[%s ] : ", p->u.pname); } else { pc.printf(" : "); } pc.printf("%d : ", (p->gcbit >> 16) & 0xff); // num pc.printf("%d \n", (p->gcbit & 0xff)); // bit (USED/RUNNING) p = cdr(p); cnt++; } } // marktree - recursively marks all used items in a list void marktree(LIST *p) { if (p != NULL) { if (type(p) == LST) { marktree(car(p)); marktree(cdr(p)); } p->gcbit = USED; } } /*********************** storage allocator *****************/ void *emalloc(size_t size) { void *s; if ((s = malloc(size)) == NULL) { pc.printf("OUT OF MEMORY !! : crashed !! \n"); exit(0); } return s; } // routine to load the library of lisp functions in void load_library(void) { #if 0 char libpath[1024]; strcpy(libpath, getenv("HOME")); strcat(libpath, "/lisplib"); if ((fd = fopen(libpath, "r")) != NULL) { interpret_malisp(); fclose(fd); pc.printf("loaded lisplib from %s\n", libpath); } interpret_malisp(); fd = stdin; #else fd = FILE_STRING; interpret_malisp(); pc.printf("loaded lisplib from flash\n"); fd = FILE_SERIAL; #endif } // isfunc - returns YES if type t is a user-function or a lisp primitive int isfunc(int t) { return ( t==FUSER || t==ADD1 || t==SUB1 || t==PLUS || t==DIFF || t==TIMES || t==QUOTIENT || t==LESSP || t==GREATERP || t==ZEROP || t==NUMBERP || t==FCAR || t==FCDR || t==FCONS || t==FREAD || t==PRINT || t==FNOT|| t==FAND || t==FOR || t==FEVAL || t==FEQ || t==FATOM || // mbed extends t == FFREEMEM || t == FWAIT || t == FDOUT || t == FDIN || t == FAOUT || t == FAIN || t == PWMOUT ); } void debug(LIST *p) { pc.printf("DEBUG ---\n"); debug2(p); pc.printf("\n"); } void debug2(LIST *p) { int t; if (p != NULL) { if ((t = type(p)) == LST) { pc.printf("("); debug2(car(p)); debug2(cdr(p)); pc.printf(")"); } else if (t == RATOM) { pc.printf("RATOM %f ", p->u.num); } else if (t == IATOM) { pc.printf("IATOM %d ", (int) p->u.num); } else if (t == SATOM) { pc.printf("SATOM %s ", getname(car(p))); } else { pc.printf("FUNC %d ", type(p)); } } }