![](/media/cache/profiles/916954106a13204fa4909ae2d48e0602.jpg.50x50_q85.jpg)
asdf
Fork of manworm_ticker_tv by
Diff: lisp.cpp
- Revision:
- 9:2a47b9ff8911
- Child:
- 10:1163fb31b0a7
diff -r caeb6582cdc1 -r 2a47b9ff8911 lisp.cpp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp.cpp Sat Mar 10 05:09:55 2018 +0000 @@ -0,0 +1,580 @@ +///* A minimal Lisp interpreter +// Copyright 2004 Andru Luvisi +// +// This program is free software; you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation; either version 2 of the License , or +// (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with this program. If not, write to the Free Software +// Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +// */ +// +// +//#include <stdio.h> +//#include <stdlib.h> +//#include <stdarg.h> +//#include <string.h> +//#include <ctype.h> +//#include "main.h" +// +//#define error(X) do { printf("ERROR: %s\n", X); } while (0) +//#define out_buf_size 5000 +//#define in_buf_size 5000 +// +//int out_counter = 0; +//int in_counter = 0; +//char out_buf[out_buf_size]; +//char in_buf [in_buf_size]; +// +//char lisp_exit = 0; +// +//void init_buf() +//{ +// for(int i = 0; i < out_buf_size; i++) +// out_buf[i] = 0; +// +// for(int i = 0; i < in_buf_size; i++) +// in_buf[i] = 0; +// +// out_buf[out_buf_size - 1] = 0; +// out_counter = 0; +// in_counter = 0; +//} +// +//char getc_2() +//{ +// //draw_vincent_string("getc2"); +// in_counter++; +// if(in_counter >= in_buf_size) +// { +// lisp_exit = 1; +// return EOF; +// } +// +// char next_char = in_buf[in_counter - 1]; +// +// if(next_char == 0) +// { +// lisp_exit = 1; +// return EOF; +// } +// +// return in_buf[in_counter-1]; +//} +// +//void ungetc_2(char c) +//{ +// in_counter--; +//} +// +// +//char* strdup_2(char* in) +//{ +// char* new_string = (char*)malloc(strlen(in)); +// strcpy(new_string,in); +// return new_string; +//} +// +//void write_out(char* str) +//{ +// printf("write_out: %s\n",str); +// +// int len = strlen(str); +// +// if(len + out_counter < out_buf_size) +// { +// printf("BUUFER OVERLFOW!\n"); +// return; +// } +// +// memcpy(out_buf + out_counter, str, len); +//} +// +//int line_num = 1; +//int total_malloc = 0; +// +///*** List Structured Memory ***/ +//enum otype { INT, SYM, CONS, PROC, PRIMOP }; +//typedef struct obj { +// enum otype type; +// int line_num; +// struct obj *p[1]; +//} obj; +//typedef obj * (*primop)(obj *); +//obj *all_symbols, *top_env, *nil, *tee, *quote, +// *s_if, *s_lambda, *s_define, *s_setb, *s_begin; +// +//#define cons(X, Y) omake(CONS, 2, (X), (Y)) +// +//obj *car(obj *X) { +// if(X == 0) { +// sprintf(out_buf + strlen(out_buf),"warning: car argument null on line %d\n", line_num); +// return nil; +// } +// if(X == nil) +// return nil; +// if(X->type != CONS) { +// sprintf(out_buf + strlen(out_buf),"warning: car argument not a list (%d) on line %d\n", X->p[0], X->line_num); +// return nil; +// } +// return X->p[0]; +//} +// +//obj *cdr(obj *X) { +// if(X == nil) +// return nil; +// if(X->type != CONS) { +// sprintf(out_buf + strlen(out_buf),"warning: cdr argument not a list on line %d\n", X->line_num); +// return nil; +// } +// if(X->p[1] == 0) { +// sprintf(out_buf + strlen(out_buf),"error: cdr list element is zero-pointer at %d\n", X->line_num); +// return nil; +// } +// return X->p[1]; +//} +// +//#define setcar(X,Y) (((X)->p[0]) = (Y)) +//#define setcdr(X,Y) (((X)->p[1]) = (Y)) +//#define mkint(X) omake(INT, 1, (obj *)(X)) +//#define intval(X) ((int)((X)->type == INT ? (X)->p[0] : 0)) // intval for INT only +//#define mksym(X) omake(SYM, 1, (obj *)(X)) +//#define symname(X) ((char *)((X)->p[0])) +//#define mkprimop(X) omake(PRIMOP, 1, (obj *)(X)) +//#define primopval(X) ((primop)(X)->p[0]) +//#define mkproc(X,Y,Z) omake(PROC, 3, (X), (Y), (Z)) +//#define procargs(X) ((X)->p[0]) +//#define proccode(X) ((X)->p[1]) +//#define procenv(X) ((X)->p[2]) +//#define isnil(X) ((X) == nil) +// +//obj *omake(enum otype type, int count, ...) { +// obj *ret; +// va_list ap; +// int i; +// va_start(ap, count); +// int object_size = sizeof(obj) + (count - 1)*sizeof(obj *); +// total_malloc += object_size; +// if(type == INT) +// printf("malloc %d bytes for INT\r\n",object_size); +// if(type == SYM) +// printf("malloc %d bytes for SYM\r\n",object_size); +// if(type == CONS) +// printf("malloc %d bytes for CONS\r\n",object_size); +// if(type == SYM) +// printf("malloc %d bytes for PROC\r\n",object_size); +// if(type == PRIMOP) +// printf("malloc %d bytes for PRIMOP\r\n",object_size); +// +////enum otype { INT, SYM, CONS, PROC, PRIMOP }; +// ret = (obj *) malloc(object_size); +// ret->type = type; +// ret->line_num = line_num; +// for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *); +// va_end(ap); +// return ret; +//} +// +//obj *findsym(char *name) { +// obj *symlist; +// for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist)) +// if(!strcmp(name, symname(car(symlist)))) +// return symlist; +// return nil; +//} +// +//obj *intern(char *name) { +// obj *op = findsym(name); +// if(!isnil(op)) return car(op); +// op = mksym(name); +// all_symbols = cons(op, all_symbols); +// return op; +//} +// +///*** Environment ***/ +//#define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV))) +// +//obj *multiple_extend(obj *env, obj *syms, obj *vals) { +// return isnil(syms) ? +// env : +// multiple_extend(extend(env, car(syms), car(vals)), +// cdr(syms), cdr(vals)); +//} +// +//obj *extend_top(obj *sym, obj *val) { +// setcdr(top_env, cons(cons(sym, val), cdr(top_env))); +// return val; +//} +// +//obj *assoc(obj *key, obj *alist) { +// if(isnil(alist)) return nil; +// if(car(car(alist)) == key) return car(alist); +// return assoc(key, cdr(alist)); +//} +// +///*** Input/Output ***/ +////FILE *ifp; +//char *token_la; +//int la_valid = 0; +//#define MAXLEN 100 +//char buf[MAXLEN]; +//int bufused; +// +//void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; } +//char *buf2str() { buf[bufused++] = '\0'; return strdup_2(buf); } +////void setinput(FILE *fp) { ifp = fp; } +//void putback_token(char *token) { token_la = token; la_valid = 1; } +// +//void myexit(int code); +// +//char *gettoken() { +// int ch; +// char comment=0; +// +// bufused = 0; +// if(la_valid) { la_valid = 0; return token_la; } +// do { +// if((ch = getc_2()) == EOF) {myexit(0); return NULL;} // replace with serial +// //draw_vincent_string("gettoken"); +// if(ch == ';') comment = 1; +// if(ch == '\n') { +// comment = 0; +// line_num++; +// } +// +// } while(isspace(ch) || comment); +// +// +// add_to_buf(ch); +// if(strchr("()\'", ch)) return buf2str(); +// for(;;) { +// if(lisp_exit) { return NULL; } +// if((ch = getc_2()) == EOF) {myexit(0); return NULL;} +// if(strchr("()\'", ch) || isspace(ch)) { +// ungetc_2(ch); +// return buf2str(); +// } +// add_to_buf(ch); +// } +//} +// +//obj *readlist(); +// +//obj *readobj() { +// char *token; +// +// token = gettoken(); +// if(token == NULL) return NULL; +// if(!strcmp(token, "(")) return readlist(); +// if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil)); +// +// if(token[strspn(token, "0123456789")] == '\0' +// || (token[0] == '-' && strlen(token) > 1)) +// return mkint(atoi(token)); +// return intern(token); +//} +// +//obj *readlist() { +// char *token = gettoken(); +// if(token == NULL) return NULL; +// obj *tmp; +// if(!strcmp(token, ")")) return nil; +// if(!strcmp(token, ".")) { +// tmp = readobj(); +// if(strcmp(gettoken(), ")")) myexit(1); +// return tmp; +// } +// putback_token(token); +// tmp = readobj(); /* Must force evaluation order */ +// return cons(tmp, readlist()); +//} +// +//void writeobj(obj *op) { +// +// if(op == NULL) { return; } +// switch(op->type) { +// case INT: sprintf(out_buf + strlen(out_buf),"%d", intval(op)); break; +// case CONS: +// //draw_vincent_string(" write_cons "); +// sprintf(out_buf + strlen(out_buf),"("); +// for(;;) { +// writeobj(car(op)); +// if(isnil(cdr(op))) { +// sprintf(out_buf + strlen(out_buf),")"); +// break; +// } +// op = cdr(op); +// if(op->type != CONS) { +// sprintf(out_buf + strlen(out_buf)," . "); +// writeobj(op); +// sprintf(out_buf + strlen(out_buf),")"); +// break; +// } +// sprintf(out_buf + strlen(out_buf)," "); +// } +// break; +// case SYM: +// +// if(isnil(op)) sprintf(out_buf + strlen(out_buf),"()"); +// else sprintf(out_buf + strlen(out_buf),"%s", symname(op)); +// break; +// case PRIMOP: sprintf(out_buf + strlen(out_buf),"#<PRIMOP>"); break; +// case PROC: sprintf(out_buf + strlen(out_buf),"#<PROC>"); break; +// default: myexit(1); +// } +//} +// +///*** Evaluator (Eval/no Apply) ***/ +//obj *evlis(obj *exps, obj *env); +// +//obj *eval(obj *exp, obj *env) { +// if(lisp_exit) return NULL; +// obj *tmp, *proc, *vals; +// +// eval_start: +// +// if(exp == NULL) return nil; +// if(exp == nil) return nil; +// +// +// switch(exp->type) { +// case INT: return exp; +// case SYM: tmp = assoc(exp, env); +// +// if(tmp == nil) { +// sprintf(out_buf + strlen(out_buf), "Unbound symbol "); +// writeobj(exp); +// sprintf(out_buf + strlen(out_buf), "\n"); +// return nil; +// } +// return cdr(tmp); +// +// +// +// case CONS: +// if(car(exp) == s_if) { +// if(eval(car(cdr(exp)), env) != nil) +// return eval(car(cdr(cdr(exp))), env); +// else +// return eval(car(cdr(cdr(cdr(exp)))), env); +// } +// if(car(exp) == s_lambda) +// return mkproc(car(cdr(exp)), cdr(cdr(exp)), env); +// if(car(exp) == quote) +// return car(cdr(exp)); +// if(car(exp) == s_define) +// return(extend_top(car(cdr(exp)), +// eval(car(cdr(cdr(exp))), env))); +// if(car(exp) == s_setb) { +// obj *pair = assoc(car(cdr(exp)), env); +// obj *newval = eval(car(cdr(cdr(exp))), env); +// setcdr(pair, newval); +// return newval; +// } +// if(car(exp) == s_begin) { +// exp = cdr(exp); +// if(exp == nil) return nil; +// for(;;) { +// if(cdr(exp) == nil) { +// exp = car(exp); +// goto eval_start; +// } +// eval(car(exp), env); +// exp = cdr(exp); +// } +// } +// proc = eval(car(exp), env); +// vals = evlis(cdr(exp), env); +// if(proc->type == PRIMOP) +// return (*primopval(proc))(vals); +// if(proc->type == PROC) { +// /* For dynamic scope, use env instead of procenv(proc) */ +// env = multiple_extend(procenv(proc), procargs(proc), vals); +// exp = cons(s_begin, proccode(proc)); +// goto eval_start; +// } +// sprintf(out_buf + strlen(out_buf),"Bad PROC type\n"); +// return nil; +// case PRIMOP: return exp; +// case PROC: return exp; +// } +// /* Not reached */ +// return exp; +//} +// +//obj *evlis(obj *exps, obj *env) { +// if(exps == nil) return nil; +// return cons(eval(car(exps), env), +// evlis(cdr(exps), env)); +//} +// +///*** Primitives ***/ +//obj *prim_sum(obj *args) { +// int sum; +// for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args)); +// return mkint(sum); +//} +// +//obj *prim_sub(obj *args) { +// int sum; +// for(sum = intval(car(args)), args = cdr(args); +// !isnil(args); +// sum -= intval(car(args)), args = cdr(args)); +// return mkint(sum); +//} +// +//obj *prim_prod(obj *args) { +// int prod; +// for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args)); +// return mkint(prod); +//} +//obj *prim_divide(obj *args) { +// int prod = intval(car(args)); +// args = cdr(args); +// while(!isnil(args)) { +// prod /= intval(car(args)); +// args = cdr(args); +// } +// +// return mkint(prod); +//} +// +//obj *prim_gt(obj *args) { +// return intval(car(args)) > intval(car(cdr(args))) ? tee : nil; +//} +// +//obj *prim_lt(obj *args) { +// return intval(car(args)) < intval(car(cdr(args))) ? tee : nil; +//} +//obj *prim_ge(obj *args) { +// return intval(car(args)) >= intval(car(cdr(args))) ? tee : nil; +//} +//obj *prim_le(obj *args) { +// return intval(car(args)) <= intval(car(cdr(args))) ? tee : nil; +//} +//obj *prim_numeq(obj *args) { +// return intval(car(args)) == intval(car(cdr(args))) ? tee : nil; +//} +// +//obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); } +//obj *prim_car(obj *args) { return car(car(args)); } +//obj *prim_cdr(obj *args) { return cdr(car(args)); } +// +// +///*** Helpers *****/ +// +//obj *prim_print(obj *args) { +// while(!isnil(args)) { +// writeobj(car(args)); +// args = cdr(args); +// sprintf(out_buf + strlen(out_buf)," "); +// } +// sprintf(out_buf + strlen(out_buf),"\n"); +// return nil; +//} +// +///*** Initialization ***/ +//void init_sl3() { +// nil = mksym("nil"); +// all_symbols = cons(nil, nil); +// top_env = cons(cons(nil, nil), nil); +// tee = intern("t"); +// extend_top(tee, tee); +// quote = intern("quote"); +// s_if = intern("if"); +// s_lambda = intern("lambda"); +// s_define = intern("define"); +// s_setb = intern("set!"); +// s_begin = intern("begin"); +// extend_top(intern("+"), mkprimop(prim_sum)); +// extend_top(intern("-"), mkprimop(prim_sub)); +// extend_top(intern("*"), mkprimop(prim_prod)); +// extend_top(intern("/"), mkprimop(prim_divide)); +// extend_top(intern("="), mkprimop(prim_numeq)); +// +// extend_top(intern(">"), mkprimop(prim_gt)); +// extend_top(intern(">="), mkprimop(prim_ge)); +// +// extend_top(intern("<"), mkprimop(prim_lt)); +// extend_top(intern("<="), mkprimop(prim_le)); +// +// extend_top(intern("cons"), mkprimop(prim_cons)); +// extend_top(intern("car"), mkprimop(prim_car)); +// extend_top(intern("cdr"), mkprimop(prim_cdr)); +// +// extend_top(intern("print"), mkprimop(prim_print)); +//} +// +//char* get_output() +//{ +// return out_buf; +//} +// +//int lisp_init = 0; +// +///*** Main Driver ***/ +//int run_lisp(char* input) { +// if(!lisp_init) +// { +// init_sl3(); +// lisp_init = 1; +// } +// +// init_buf(); +// +// +// lisp_exit = 0; +// strcpy(in_buf, input); +// if(!strncmp(input,"clear",4)){ clear_all_text(); return 0; } +// if(!strncmp(input,"mem",3)) +// { +// char memuse[40]; +// sprintf(memuse,"MEM: %d bytes",total_malloc); +// draw_vincent_string(memuse); +// return; +// } +// in_buf[in_buf_size - 1] = 0; +// //new_line(); +// //draw_vincent_string(in_buf); +// //new_line(); +// //print_vincent_string(in_buf); +//// if(argc == 2) +//// { +//// memcpy(in_buf,argv[1],strlen(argv[1])); +//// printf("%s\n",in_buf); +//// } +//// else +// //sprintf(in_buf,"(+ 2 2)\n"); +//// char test_in[] = "(+ 2 2)\n"; +//// FILE* input_stream = open_memstream(test_in,8); +//// fprintf(input_stream,"(+ 2 3)\n"); +//// char test_out[50]; +//// FILE* output_stream = fmemopen(test_out,50,"w"); +// //setinput(input_stream); +// int lisp_count = 0; +// while(!lisp_exit) { +// writeobj(eval(readobj(), top_env)); +// //fflush(output_stream); +// printf("\n"); +// printf("%s\n",out_buf); +// +// lisp_count++; +// if(lisp_count > 500) break; +// //printf("outstream: %s\n",test_out); +// } +// draw_vincent_string(out_buf); +// //draw_vincent_string("done!"); +// return 0; +//} +// +//void myexit(int code) { +// printf("%d bytes left hanging\n", total_malloc); +// lisp_exit = 1; +//} \ No newline at end of file