Jared DiCarlo
asdf
Fork of
manworm_ticker_tv
by 
Bayley Wang
Diff: lisp.cpp
- Revision:
- 10:1163fb31b0a7
- Parent:
- 9:2a47b9ff8911
--- a/lisp.cpp Sat Mar 10 05:09:55 2018 +0000
+++ b/lisp.cpp Sat Mar 10 06:26:01 2018 +0000
@@ -1,580 +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 ***/
+/* 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 };
-//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);
+ 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);
// }
-//}
-//
-//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
+// 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