Jared DiCarlo / Mbed 2 deprecated manworm_tv_gpu

asdf

Dependencies:   mbed

Fork of manworm_ticker_tv by Bayley Wang

lisp.cpp@12:e99cc1e9d928, 2018-05-04 (annotated)

Committer:
dicarloj
Date:
Fri May 04 01:45:05 2018 +0000
Revision:
12:e99cc1e9d928
Parent:
10:1163fb31b0a7 
lol it works;

Who changed what in which revision?

UserRevisionLine numberNew contents of line
dicarloj 10:1163fb31b0a7 1 /* A minimal Lisp interpreter
dicarloj 10:1163fb31b0a7 2 Copyright 2004 Andru Luvisi
dicarloj 10:1163fb31b0a7 3
dicarloj 10:1163fb31b0a7 4 This program is free software; you can redistribute it and/or modify
dicarloj 10:1163fb31b0a7 5 it under the terms of the GNU General Public License as published by
dicarloj 10:1163fb31b0a7 6 the Free Software Foundation; either version 2 of the License , or
dicarloj 10:1163fb31b0a7 7 (at your option) any later version.
dicarloj 10:1163fb31b0a7 8
dicarloj 10:1163fb31b0a7 9 This program is distributed in the hope that it will be useful,
dicarloj 10:1163fb31b0a7 10 but WITHOUT ANY WARRANTY; without even the implied warranty of
dicarloj 10:1163fb31b0a7 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
dicarloj 10:1163fb31b0a7 12 GNU General Public License for more details.
dicarloj 10:1163fb31b0a7 13
dicarloj 10:1163fb31b0a7 14 You should have received a copy of the GNU General Public License
dicarloj 10:1163fb31b0a7 15 along with this program. If not, write to the Free Software
dicarloj 10:1163fb31b0a7 16 Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
dicarloj 10:1163fb31b0a7 17 */
dicarloj 10:1163fb31b0a7 18
dicarloj 10:1163fb31b0a7 19
dicarloj 10:1163fb31b0a7 20 #include <stdio.h>
dicarloj 10:1163fb31b0a7 21 #include <stdlib.h>
dicarloj 10:1163fb31b0a7 22 #include <stdarg.h>
dicarloj 10:1163fb31b0a7 23 #include <string.h>
dicarloj 10:1163fb31b0a7 24 #include <ctype.h>
dicarloj 10:1163fb31b0a7 25 #include "main.h"
dicarloj 10:1163fb31b0a7 26
dicarloj 10:1163fb31b0a7 27 #define error(X) do { printf("ERROR: %s\n", X); } while (0)
dicarloj 10:1163fb31b0a7 28 #define out_buf_size 5000
dicarloj 10:1163fb31b0a7 29 #define in_buf_size 5000
dicarloj 10:1163fb31b0a7 30
dicarloj 10:1163fb31b0a7 31 int out_counter = 0;
dicarloj 10:1163fb31b0a7 32 int in_counter = 0;
dicarloj 10:1163fb31b0a7 33 char out_buf[out_buf_size];
dicarloj 10:1163fb31b0a7 34 char in_buf [in_buf_size];
dicarloj 10:1163fb31b0a7 35
dicarloj 10:1163fb31b0a7 36 char lisp_exit = 0;
dicarloj 10:1163fb31b0a7 37
dicarloj 10:1163fb31b0a7 38 void init_buf()
dicarloj 10:1163fb31b0a7 39 {
dicarloj 10:1163fb31b0a7 40 for(int i = 0; i < out_buf_size; i++)
dicarloj 10:1163fb31b0a7 41 out_buf[i] = 0;
dicarloj 10:1163fb31b0a7 42
dicarloj 10:1163fb31b0a7 43 for(int i = 0; i < in_buf_size; i++)
dicarloj 10:1163fb31b0a7 44 in_buf[i] = 0;
dicarloj 10:1163fb31b0a7 45
dicarloj 10:1163fb31b0a7 46 out_buf[out_buf_size - 1] = 0;
dicarloj 10:1163fb31b0a7 47 out_counter = 0;
dicarloj 10:1163fb31b0a7 48 in_counter = 0;
dicarloj 10:1163fb31b0a7 49 }
dicarloj 10:1163fb31b0a7 50
dicarloj 10:1163fb31b0a7 51 char getc_2()
dicarloj 10:1163fb31b0a7 52 {
dicarloj 10:1163fb31b0a7 53 //draw_vincent_string("getc2");
dicarloj 10:1163fb31b0a7 54 in_counter++;
dicarloj 10:1163fb31b0a7 55 if(in_counter >= in_buf_size)
dicarloj 10:1163fb31b0a7 56 {
dicarloj 10:1163fb31b0a7 57 lisp_exit = 1;
dicarloj 10:1163fb31b0a7 58 return EOF;
dicarloj 10:1163fb31b0a7 59 }
dicarloj 10:1163fb31b0a7 60
dicarloj 10:1163fb31b0a7 61 char next_char = in_buf[in_counter - 1];
dicarloj 10:1163fb31b0a7 62
dicarloj 10:1163fb31b0a7 63 if(next_char == 0)
dicarloj 10:1163fb31b0a7 64 {
dicarloj 10:1163fb31b0a7 65 lisp_exit = 1;
dicarloj 10:1163fb31b0a7 66 return EOF;
dicarloj 10:1163fb31b0a7 67 }
dicarloj 10:1163fb31b0a7 68
dicarloj 10:1163fb31b0a7 69 return in_buf[in_counter-1];
dicarloj 10:1163fb31b0a7 70 }
dicarloj 10:1163fb31b0a7 71
dicarloj 10:1163fb31b0a7 72 void ungetc_2(char c)
dicarloj 10:1163fb31b0a7 73 {
dicarloj 10:1163fb31b0a7 74 in_counter--;
dicarloj 10:1163fb31b0a7 75 }
dicarloj 10:1163fb31b0a7 76
dicarloj 10:1163fb31b0a7 77
dicarloj 10:1163fb31b0a7 78 char* strdup_2(char* in)
dicarloj 10:1163fb31b0a7 79 {
dicarloj 10:1163fb31b0a7 80 char* new_string = (char*)malloc(strlen(in));
dicarloj 10:1163fb31b0a7 81 strcpy(new_string,in);
dicarloj 10:1163fb31b0a7 82 return new_string;
dicarloj 10:1163fb31b0a7 83 }
dicarloj 10:1163fb31b0a7 84
dicarloj 10:1163fb31b0a7 85 void write_out(char* str)
dicarloj 10:1163fb31b0a7 86 {
dicarloj 10:1163fb31b0a7 87 printf("write_out: %s\n",str);
dicarloj 10:1163fb31b0a7 88
dicarloj 10:1163fb31b0a7 89 int len = strlen(str);
dicarloj 10:1163fb31b0a7 90
dicarloj 10:1163fb31b0a7 91 if(len + out_counter < out_buf_size)
dicarloj 10:1163fb31b0a7 92 {
dicarloj 10:1163fb31b0a7 93 printf("BUUFER OVERLFOW!\n");
dicarloj 10:1163fb31b0a7 94 return;
dicarloj 10:1163fb31b0a7 95 }
dicarloj 10:1163fb31b0a7 96
dicarloj 10:1163fb31b0a7 97 memcpy(out_buf + out_counter, str, len);
dicarloj 10:1163fb31b0a7 98 }
dicarloj 10:1163fb31b0a7 99
dicarloj 10:1163fb31b0a7 100 int line_num = 1;
dicarloj 10:1163fb31b0a7 101 int total_malloc = 0;
dicarloj 10:1163fb31b0a7 102
dicarloj 10:1163fb31b0a7 103 /*** List Structured Memory ***/
dicarloj 10:1163fb31b0a7 104 enum otype { INT, SYM, CONS, PROC, PRIMOP };
dicarloj 10:1163fb31b0a7 105 typedef struct obj {
dicarloj 10:1163fb31b0a7 106 enum otype type;
dicarloj 10:1163fb31b0a7 107 int line_num;
dicarloj 10:1163fb31b0a7 108 struct obj *p[1];
dicarloj 10:1163fb31b0a7 109 } obj;
dicarloj 10:1163fb31b0a7 110 typedef obj * (*primop)(obj *);
dicarloj 10:1163fb31b0a7 111 obj *all_symbols, *top_env, *nil, *tee, *quote,
dicarloj 10:1163fb31b0a7 112 *s_if, *s_lambda, *s_define, *s_setb, *s_begin;
dicarloj 10:1163fb31b0a7 113
dicarloj 10:1163fb31b0a7 114 #define cons(X, Y) omake(CONS, 2, (X), (Y))
dicarloj 10:1163fb31b0a7 115
dicarloj 10:1163fb31b0a7 116 obj *car(obj *X) {
dicarloj 10:1163fb31b0a7 117 if(X == 0) {
dicarloj 10:1163fb31b0a7 118 sprintf(out_buf + strlen(out_buf),"warning: car argument null on line %d\n", line_num);
dicarloj 10:1163fb31b0a7 119 return nil;
dicarloj 10:1163fb31b0a7 120 }
dicarloj 10:1163fb31b0a7 121 if(X == nil)
dicarloj 10:1163fb31b0a7 122 return nil;
dicarloj 10:1163fb31b0a7 123 if(X->type != CONS) {
dicarloj 10:1163fb31b0a7 124 sprintf(out_buf + strlen(out_buf),"warning: car argument not a list (%d) on line %d\n", X->p[0], X->line_num);
dicarloj 10:1163fb31b0a7 125 return nil;
dicarloj 10:1163fb31b0a7 126 }
dicarloj 10:1163fb31b0a7 127 return X->p[0];
dicarloj 10:1163fb31b0a7 128 }
dicarloj 10:1163fb31b0a7 129
dicarloj 10:1163fb31b0a7 130 obj *cdr(obj *X) {
dicarloj 10:1163fb31b0a7 131 if(X == nil)
dicarloj 10:1163fb31b0a7 132 return nil;
dicarloj 10:1163fb31b0a7 133 if(X->type != CONS) {
dicarloj 10:1163fb31b0a7 134 sprintf(out_buf + strlen(out_buf),"warning: cdr argument not a list on line %d\n", X->line_num);
dicarloj 10:1163fb31b0a7 135 return nil;
dicarloj 10:1163fb31b0a7 136 }
dicarloj 10:1163fb31b0a7 137 if(X->p[1] == 0) {
dicarloj 10:1163fb31b0a7 138 sprintf(out_buf + strlen(out_buf),"error: cdr list element is zero-pointer at %d\n", X->line_num);
dicarloj 10:1163fb31b0a7 139 return nil;
dicarloj 10:1163fb31b0a7 140 }
dicarloj 10:1163fb31b0a7 141 return X->p[1];
dicarloj 10:1163fb31b0a7 142 }
dicarloj 10:1163fb31b0a7 143
dicarloj 10:1163fb31b0a7 144 #define setcar(X,Y) (((X)->p[0]) = (Y))
dicarloj 10:1163fb31b0a7 145 #define setcdr(X,Y) (((X)->p[1]) = (Y))
dicarloj 10:1163fb31b0a7 146 #define mkint(X) omake(INT, 1, (obj *)(X))
dicarloj 10:1163fb31b0a7 147 #define intval(X) ((int)((X)->type == INT ? (X)->p[0] : 0)) // intval for INT only
dicarloj 10:1163fb31b0a7 148 #define mksym(X) omake(SYM, 1, (obj *)(X))
dicarloj 10:1163fb31b0a7 149 #define symname(X) ((char *)((X)->p[0]))
dicarloj 10:1163fb31b0a7 150 #define mkprimop(X) omake(PRIMOP, 1, (obj *)(X))
dicarloj 10:1163fb31b0a7 151 #define primopval(X) ((primop)(X)->p[0])
dicarloj 10:1163fb31b0a7 152 #define mkproc(X,Y,Z) omake(PROC, 3, (X), (Y), (Z))
dicarloj 10:1163fb31b0a7 153 #define procargs(X) ((X)->p[0])
dicarloj 10:1163fb31b0a7 154 #define proccode(X) ((X)->p[1])
dicarloj 10:1163fb31b0a7 155 #define procenv(X) ((X)->p[2])
dicarloj 10:1163fb31b0a7 156 #define isnil(X) ((X) == nil)
dicarloj 10:1163fb31b0a7 157
dicarloj 10:1163fb31b0a7 158 obj *omake(enum otype type, int count, ...) {
dicarloj 10:1163fb31b0a7 159 obj *ret;
dicarloj 10:1163fb31b0a7 160 va_list ap;
dicarloj 10:1163fb31b0a7 161 int i;
dicarloj 10:1163fb31b0a7 162 va_start(ap, count);
dicarloj 10:1163fb31b0a7 163 int object_size = sizeof(obj) + (count - 1)*sizeof(obj *);
dicarloj 10:1163fb31b0a7 164 total_malloc += object_size;
dicarloj 10:1163fb31b0a7 165 if(type == INT)
dicarloj 10:1163fb31b0a7 166 printf("malloc %d bytes for INT\r\n",object_size);
dicarloj 10:1163fb31b0a7 167 if(type == SYM)
dicarloj 10:1163fb31b0a7 168 printf("malloc %d bytes for SYM\r\n",object_size);
dicarloj 10:1163fb31b0a7 169 if(type == CONS)
dicarloj 10:1163fb31b0a7 170 printf("malloc %d bytes for CONS\r\n",object_size);
dicarloj 10:1163fb31b0a7 171 if(type == SYM)
dicarloj 10:1163fb31b0a7 172 printf("malloc %d bytes for PROC\r\n",object_size);
dicarloj 10:1163fb31b0a7 173 if(type == PRIMOP)
dicarloj 10:1163fb31b0a7 174 printf("malloc %d bytes for PRIMOP\r\n",object_size);
dicarloj 10:1163fb31b0a7 175
dicarloj 9:2a47b9ff8911 176 //enum otype { INT, SYM, CONS, PROC, PRIMOP };
dicarloj 10:1163fb31b0a7 177 ret = (obj *) malloc(object_size);
dicarloj 10:1163fb31b0a7 178 ret->type = type;
dicarloj 10:1163fb31b0a7 179 ret->line_num = line_num;
dicarloj 10:1163fb31b0a7 180 for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *);
dicarloj 10:1163fb31b0a7 181 va_end(ap);
dicarloj 10:1163fb31b0a7 182 return ret;
dicarloj 10:1163fb31b0a7 183 }
dicarloj 10:1163fb31b0a7 184
dicarloj 10:1163fb31b0a7 185 obj *findsym(char *name) {
dicarloj 10:1163fb31b0a7 186 obj *symlist;
dicarloj 10:1163fb31b0a7 187 for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist))
dicarloj 10:1163fb31b0a7 188 if(!strcmp(name, symname(car(symlist))))
dicarloj 10:1163fb31b0a7 189 return symlist;
dicarloj 10:1163fb31b0a7 190 return nil;
dicarloj 10:1163fb31b0a7 191 }
dicarloj 10:1163fb31b0a7 192
dicarloj 10:1163fb31b0a7 193 obj *intern(char *name) {
dicarloj 10:1163fb31b0a7 194 obj *op = findsym(name);
dicarloj 10:1163fb31b0a7 195 if(!isnil(op)) return car(op);
dicarloj 10:1163fb31b0a7 196 op = mksym(name);
dicarloj 10:1163fb31b0a7 197 all_symbols = cons(op, all_symbols);
dicarloj 10:1163fb31b0a7 198 return op;
dicarloj 10:1163fb31b0a7 199 }
dicarloj 10:1163fb31b0a7 200
dicarloj 10:1163fb31b0a7 201 /*** Environment ***/
dicarloj 10:1163fb31b0a7 202 #define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV)))
dicarloj 10:1163fb31b0a7 203
dicarloj 10:1163fb31b0a7 204 obj *multiple_extend(obj *env, obj *syms, obj *vals) {
dicarloj 10:1163fb31b0a7 205 return isnil(syms) ?
dicarloj 10:1163fb31b0a7 206 env :
dicarloj 10:1163fb31b0a7 207 multiple_extend(extend(env, car(syms), car(vals)),
dicarloj 10:1163fb31b0a7 208 cdr(syms), cdr(vals));
dicarloj 10:1163fb31b0a7 209 }
dicarloj 10:1163fb31b0a7 210
dicarloj 10:1163fb31b0a7 211 obj *extend_top(obj *sym, obj *val) {
dicarloj 10:1163fb31b0a7 212 setcdr(top_env, cons(cons(sym, val), cdr(top_env)));
dicarloj 10:1163fb31b0a7 213 return val;
dicarloj 10:1163fb31b0a7 214 }
dicarloj 10:1163fb31b0a7 215
dicarloj 10:1163fb31b0a7 216 obj *assoc(obj *key, obj *alist) {
dicarloj 10:1163fb31b0a7 217 if(isnil(alist)) return nil;
dicarloj 10:1163fb31b0a7 218 if(car(car(alist)) == key) return car(alist);
dicarloj 10:1163fb31b0a7 219 return assoc(key, cdr(alist));
dicarloj 10:1163fb31b0a7 220 }
dicarloj 10:1163fb31b0a7 221
dicarloj 10:1163fb31b0a7 222 /*** Input/Output ***/
dicarloj 10:1163fb31b0a7 223 //FILE *ifp;
dicarloj 10:1163fb31b0a7 224 char *token_la;
dicarloj 10:1163fb31b0a7 225 int la_valid = 0;
dicarloj 10:1163fb31b0a7 226 #define MAXLEN 100
dicarloj 10:1163fb31b0a7 227 char buf[MAXLEN];
dicarloj 10:1163fb31b0a7 228 int bufused;
dicarloj 10:1163fb31b0a7 229
dicarloj 10:1163fb31b0a7 230 void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; }
dicarloj 10:1163fb31b0a7 231 char *buf2str() { buf[bufused++] = '\0'; return strdup_2(buf); }
dicarloj 10:1163fb31b0a7 232 //void setinput(FILE *fp) { ifp = fp; }
dicarloj 10:1163fb31b0a7 233 void putback_token(char *token) { token_la = token; la_valid = 1; }
dicarloj 10:1163fb31b0a7 234
dicarloj 10:1163fb31b0a7 235 void myexit(int code);
dicarloj 10:1163fb31b0a7 236
dicarloj 10:1163fb31b0a7 237 char *gettoken() {
dicarloj 10:1163fb31b0a7 238 int ch;
dicarloj 10:1163fb31b0a7 239 char comment=0;
dicarloj 10:1163fb31b0a7 240
dicarloj 10:1163fb31b0a7 241 bufused = 0;
dicarloj 10:1163fb31b0a7 242 if(la_valid) { la_valid = 0; return token_la; }
dicarloj 10:1163fb31b0a7 243 do {
dicarloj 10:1163fb31b0a7 244 if((ch = getc_2()) == EOF) {myexit(0); return NULL;} // replace with serial
dicarloj 10:1163fb31b0a7 245 //draw_vincent_string("gettoken");
dicarloj 10:1163fb31b0a7 246 if(ch == ';') comment = 1;
dicarloj 10:1163fb31b0a7 247 if(ch == '\n') {
dicarloj 10:1163fb31b0a7 248 comment = 0;
dicarloj 10:1163fb31b0a7 249 line_num++;
dicarloj 10:1163fb31b0a7 250 }
dicarloj 10:1163fb31b0a7 251
dicarloj 10:1163fb31b0a7 252 } while(isspace(ch) || comment);
dicarloj 10:1163fb31b0a7 253
dicarloj 10:1163fb31b0a7 254
dicarloj 10:1163fb31b0a7 255 add_to_buf(ch);
dicarloj 10:1163fb31b0a7 256 if(strchr("()\'", ch)) return buf2str();
dicarloj 10:1163fb31b0a7 257 for(;;) {
dicarloj 10:1163fb31b0a7 258 if(lisp_exit) { return NULL; }
dicarloj 10:1163fb31b0a7 259 if((ch = getc_2()) == EOF) {myexit(0); return NULL;}
dicarloj 10:1163fb31b0a7 260 if(strchr("()\'", ch) || isspace(ch)) {
dicarloj 10:1163fb31b0a7 261 ungetc_2(ch);
dicarloj 10:1163fb31b0a7 262 return buf2str();
dicarloj 10:1163fb31b0a7 263 }
dicarloj 10:1163fb31b0a7 264 add_to_buf(ch);
dicarloj 10:1163fb31b0a7 265 }
dicarloj 10:1163fb31b0a7 266 }
dicarloj 10:1163fb31b0a7 267
dicarloj 10:1163fb31b0a7 268 obj *readlist();
dicarloj 10:1163fb31b0a7 269
dicarloj 10:1163fb31b0a7 270 obj *readobj() {
dicarloj 10:1163fb31b0a7 271 char *token;
dicarloj 10:1163fb31b0a7 272
dicarloj 10:1163fb31b0a7 273 token = gettoken();
dicarloj 10:1163fb31b0a7 274 if(token == NULL) return NULL;
dicarloj 10:1163fb31b0a7 275 if(!strcmp(token, "(")) return readlist();
dicarloj 10:1163fb31b0a7 276 if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil));
dicarloj 10:1163fb31b0a7 277
dicarloj 10:1163fb31b0a7 278 if(token[strspn(token, "0123456789")] == '\0'
dicarloj 10:1163fb31b0a7 279 || (token[0] == '-' && strlen(token) > 1))
dicarloj 10:1163fb31b0a7 280 return mkint(atoi(token));
dicarloj 10:1163fb31b0a7 281 return intern(token);
dicarloj 10:1163fb31b0a7 282 }
dicarloj 10:1163fb31b0a7 283
dicarloj 10:1163fb31b0a7 284 obj *readlist() {
dicarloj 10:1163fb31b0a7 285 char *token = gettoken();
dicarloj 10:1163fb31b0a7 286 if(token == NULL) return NULL;
dicarloj 10:1163fb31b0a7 287 obj *tmp;
dicarloj 10:1163fb31b0a7 288 if(!strcmp(token, ")")) return nil;
dicarloj 10:1163fb31b0a7 289 if(!strcmp(token, ".")) {
dicarloj 10:1163fb31b0a7 290 tmp = readobj();
dicarloj 10:1163fb31b0a7 291 if(strcmp(gettoken(), ")")) myexit(1);
dicarloj 10:1163fb31b0a7 292 return tmp;
dicarloj 10:1163fb31b0a7 293 }
dicarloj 10:1163fb31b0a7 294 putback_token(token);
dicarloj 10:1163fb31b0a7 295 tmp = readobj(); /* Must force evaluation order */
dicarloj 10:1163fb31b0a7 296 return cons(tmp, readlist());
dicarloj 10:1163fb31b0a7 297 }
dicarloj 10:1163fb31b0a7 298
dicarloj 10:1163fb31b0a7 299 void writeobj(obj *op) {
dicarloj 10:1163fb31b0a7 300
dicarloj 10:1163fb31b0a7 301 if(op == NULL) { return; }
dicarloj 10:1163fb31b0a7 302 switch(op->type) {
dicarloj 10:1163fb31b0a7 303 case INT: sprintf(out_buf + strlen(out_buf),"%d", intval(op)); break;
dicarloj 10:1163fb31b0a7 304 case CONS:
dicarloj 10:1163fb31b0a7 305 //draw_vincent_string(" write_cons ");
dicarloj 10:1163fb31b0a7 306 sprintf(out_buf + strlen(out_buf),"(");
dicarloj 10:1163fb31b0a7 307 for(;;) {
dicarloj 10:1163fb31b0a7 308 writeobj(car(op));
dicarloj 10:1163fb31b0a7 309 if(isnil(cdr(op))) {
dicarloj 10:1163fb31b0a7 310 sprintf(out_buf + strlen(out_buf),")");
dicarloj 10:1163fb31b0a7 311 break;
dicarloj 10:1163fb31b0a7 312 }
dicarloj 10:1163fb31b0a7 313 op = cdr(op);
dicarloj 10:1163fb31b0a7 314 if(op->type != CONS) {
dicarloj 10:1163fb31b0a7 315 sprintf(out_buf + strlen(out_buf)," . ");
dicarloj 10:1163fb31b0a7 316 writeobj(op);
dicarloj 10:1163fb31b0a7 317 sprintf(out_buf + strlen(out_buf),")");
dicarloj 10:1163fb31b0a7 318 break;
dicarloj 10:1163fb31b0a7 319 }
dicarloj 10:1163fb31b0a7 320 sprintf(out_buf + strlen(out_buf)," ");
dicarloj 10:1163fb31b0a7 321 }
dicarloj 10:1163fb31b0a7 322 break;
dicarloj 10:1163fb31b0a7 323 case SYM:
dicarloj 10:1163fb31b0a7 324
dicarloj 10:1163fb31b0a7 325 if(isnil(op)) sprintf(out_buf + strlen(out_buf),"()");
dicarloj 10:1163fb31b0a7 326 else sprintf(out_buf + strlen(out_buf),"%s", symname(op));
dicarloj 10:1163fb31b0a7 327 break;
dicarloj 10:1163fb31b0a7 328 case PRIMOP: sprintf(out_buf + strlen(out_buf),"#<PRIMOP>"); break;
dicarloj 10:1163fb31b0a7 329 case PROC: sprintf(out_buf + strlen(out_buf),"#<PROC>"); break;
dicarloj 10:1163fb31b0a7 330 default: myexit(1);
dicarloj 10:1163fb31b0a7 331 }
dicarloj 10:1163fb31b0a7 332 }
dicarloj 10:1163fb31b0a7 333
dicarloj 10:1163fb31b0a7 334 /*** Evaluator (Eval/no Apply) ***/
dicarloj 10:1163fb31b0a7 335 obj *evlis(obj *exps, obj *env);
dicarloj 10:1163fb31b0a7 336
dicarloj 10:1163fb31b0a7 337 obj *eval(obj *exp, obj *env) {
dicarloj 10:1163fb31b0a7 338 if(lisp_exit) return NULL;
dicarloj 10:1163fb31b0a7 339 obj *tmp, *proc, *vals;
dicarloj 10:1163fb31b0a7 340
dicarloj 10:1163fb31b0a7 341 eval_start:
dicarloj 10:1163fb31b0a7 342
dicarloj 10:1163fb31b0a7 343 if(exp == NULL) return nil;
dicarloj 10:1163fb31b0a7 344 if(exp == nil) return nil;
dicarloj 10:1163fb31b0a7 345
dicarloj 10:1163fb31b0a7 346
dicarloj 10:1163fb31b0a7 347 switch(exp->type) {
dicarloj 10:1163fb31b0a7 348 case INT: return exp;
dicarloj 10:1163fb31b0a7 349 case SYM: tmp = assoc(exp, env);
dicarloj 10:1163fb31b0a7 350
dicarloj 10:1163fb31b0a7 351 if(tmp == nil) {
dicarloj 10:1163fb31b0a7 352 sprintf(out_buf + strlen(out_buf), "Unbound symbol ");
dicarloj 10:1163fb31b0a7 353 writeobj(exp);
dicarloj 10:1163fb31b0a7 354 sprintf(out_buf + strlen(out_buf), "\n");
dicarloj 10:1163fb31b0a7 355 return nil;
dicarloj 10:1163fb31b0a7 356 }
dicarloj 10:1163fb31b0a7 357 return cdr(tmp);
dicarloj 10:1163fb31b0a7 358
dicarloj 10:1163fb31b0a7 359
dicarloj 10:1163fb31b0a7 360
dicarloj 10:1163fb31b0a7 361 case CONS:
dicarloj 10:1163fb31b0a7 362 if(car(exp) == s_if) {
dicarloj 10:1163fb31b0a7 363 if(eval(car(cdr(exp)), env) != nil)
dicarloj 10:1163fb31b0a7 364 return eval(car(cdr(cdr(exp))), env);
dicarloj 10:1163fb31b0a7 365 else
dicarloj 10:1163fb31b0a7 366 return eval(car(cdr(cdr(cdr(exp)))), env);
dicarloj 10:1163fb31b0a7 367 }
dicarloj 10:1163fb31b0a7 368 if(car(exp) == s_lambda)
dicarloj 10:1163fb31b0a7 369 return mkproc(car(cdr(exp)), cdr(cdr(exp)), env);
dicarloj 10:1163fb31b0a7 370 if(car(exp) == quote)
dicarloj 10:1163fb31b0a7 371 return car(cdr(exp));
dicarloj 10:1163fb31b0a7 372 if(car(exp) == s_define)
dicarloj 10:1163fb31b0a7 373 return(extend_top(car(cdr(exp)),
dicarloj 10:1163fb31b0a7 374 eval(car(cdr(cdr(exp))), env)));
dicarloj 10:1163fb31b0a7 375 if(car(exp) == s_setb) {
dicarloj 10:1163fb31b0a7 376 obj *pair = assoc(car(cdr(exp)), env);
dicarloj 10:1163fb31b0a7 377 obj *newval = eval(car(cdr(cdr(exp))), env);
dicarloj 10:1163fb31b0a7 378 setcdr(pair, newval);
dicarloj 10:1163fb31b0a7 379 return newval;
dicarloj 10:1163fb31b0a7 380 }
dicarloj 10:1163fb31b0a7 381 if(car(exp) == s_begin) {
dicarloj 10:1163fb31b0a7 382 exp = cdr(exp);
dicarloj 10:1163fb31b0a7 383 if(exp == nil) return nil;
dicarloj 10:1163fb31b0a7 384 for(;;) {
dicarloj 10:1163fb31b0a7 385 if(cdr(exp) == nil) {
dicarloj 10:1163fb31b0a7 386 exp = car(exp);
dicarloj 10:1163fb31b0a7 387 goto eval_start;
dicarloj 10:1163fb31b0a7 388 }
dicarloj 10:1163fb31b0a7 389 eval(car(exp), env);
dicarloj 10:1163fb31b0a7 390 exp = cdr(exp);
dicarloj 10:1163fb31b0a7 391 }
dicarloj 10:1163fb31b0a7 392 }
dicarloj 10:1163fb31b0a7 393 proc = eval(car(exp), env);
dicarloj 10:1163fb31b0a7 394 vals = evlis(cdr(exp), env);
dicarloj 10:1163fb31b0a7 395 if(proc->type == PRIMOP)
dicarloj 10:1163fb31b0a7 396 return (*primopval(proc))(vals);
dicarloj 10:1163fb31b0a7 397 if(proc->type == PROC) {
dicarloj 10:1163fb31b0a7 398 /* For dynamic scope, use env instead of procenv(proc) */
dicarloj 10:1163fb31b0a7 399 env = multiple_extend(procenv(proc), procargs(proc), vals);
dicarloj 10:1163fb31b0a7 400 exp = cons(s_begin, proccode(proc));
dicarloj 10:1163fb31b0a7 401 goto eval_start;
dicarloj 10:1163fb31b0a7 402 }
dicarloj 10:1163fb31b0a7 403 sprintf(out_buf + strlen(out_buf),"Bad PROC type\n");
dicarloj 10:1163fb31b0a7 404 return nil;
dicarloj 10:1163fb31b0a7 405 case PRIMOP: return exp;
dicarloj 10:1163fb31b0a7 406 case PROC: return exp;
dicarloj 10:1163fb31b0a7 407 }
dicarloj 10:1163fb31b0a7 408 /* Not reached */
dicarloj 10:1163fb31b0a7 409 return exp;
dicarloj 10:1163fb31b0a7 410 }
dicarloj 10:1163fb31b0a7 411
dicarloj 10:1163fb31b0a7 412 obj *evlis(obj *exps, obj *env) {
dicarloj 10:1163fb31b0a7 413 if(exps == nil) return nil;
dicarloj 10:1163fb31b0a7 414 return cons(eval(car(exps), env),
dicarloj 10:1163fb31b0a7 415 evlis(cdr(exps), env));
dicarloj 10:1163fb31b0a7 416 }
dicarloj 10:1163fb31b0a7 417
dicarloj 10:1163fb31b0a7 418 /*** Primitives ***/
dicarloj 10:1163fb31b0a7 419 obj *prim_sum(obj *args) {
dicarloj 10:1163fb31b0a7 420 int sum;
dicarloj 10:1163fb31b0a7 421 for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args));
dicarloj 10:1163fb31b0a7 422 return mkint(sum);
dicarloj 10:1163fb31b0a7 423 }
dicarloj 10:1163fb31b0a7 424
dicarloj 10:1163fb31b0a7 425 obj *prim_sub(obj *args) {
dicarloj 10:1163fb31b0a7 426 int sum;
dicarloj 10:1163fb31b0a7 427 for(sum = intval(car(args)), args = cdr(args);
dicarloj 10:1163fb31b0a7 428 !isnil(args);
dicarloj 10:1163fb31b0a7 429 sum -= intval(car(args)), args = cdr(args));
dicarloj 10:1163fb31b0a7 430 return mkint(sum);
dicarloj 10:1163fb31b0a7 431 }
dicarloj 10:1163fb31b0a7 432
dicarloj 10:1163fb31b0a7 433 obj *prim_prod(obj *args) {
dicarloj 10:1163fb31b0a7 434 int prod;
dicarloj 10:1163fb31b0a7 435 for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args));
dicarloj 10:1163fb31b0a7 436 return mkint(prod);
dicarloj 10:1163fb31b0a7 437 }
dicarloj 10:1163fb31b0a7 438 obj *prim_divide(obj *args) {
dicarloj 10:1163fb31b0a7 439 int prod = intval(car(args));
dicarloj 10:1163fb31b0a7 440 args = cdr(args);
dicarloj 10:1163fb31b0a7 441 while(!isnil(args)) {
dicarloj 10:1163fb31b0a7 442 prod /= intval(car(args));
dicarloj 10:1163fb31b0a7 443 args = cdr(args);
dicarloj 10:1163fb31b0a7 444 }
dicarloj 10:1163fb31b0a7 445
dicarloj 10:1163fb31b0a7 446 return mkint(prod);
dicarloj 10:1163fb31b0a7 447 }
dicarloj 10:1163fb31b0a7 448
dicarloj 10:1163fb31b0a7 449 obj *prim_gt(obj *args) {
dicarloj 10:1163fb31b0a7 450 return intval(car(args)) > intval(car(cdr(args))) ? tee : nil;
dicarloj 10:1163fb31b0a7 451 }
dicarloj 10:1163fb31b0a7 452
dicarloj 10:1163fb31b0a7 453 obj *prim_lt(obj *args) {
dicarloj 10:1163fb31b0a7 454 return intval(car(args)) < intval(car(cdr(args))) ? tee : nil;
dicarloj 10:1163fb31b0a7 455 }
dicarloj 10:1163fb31b0a7 456 obj *prim_ge(obj *args) {
dicarloj 10:1163fb31b0a7 457 return intval(car(args)) >= intval(car(cdr(args))) ? tee : nil;
dicarloj 10:1163fb31b0a7 458 }
dicarloj 10:1163fb31b0a7 459 obj *prim_le(obj *args) {
dicarloj 10:1163fb31b0a7 460 return intval(car(args)) <= intval(car(cdr(args))) ? tee : nil;
dicarloj 10:1163fb31b0a7 461 }
dicarloj 10:1163fb31b0a7 462 obj *prim_numeq(obj *args) {
dicarloj 10:1163fb31b0a7 463 return intval(car(args)) == intval(car(cdr(args))) ? tee : nil;
dicarloj 10:1163fb31b0a7 464 }
dicarloj 10:1163fb31b0a7 465
dicarloj 10:1163fb31b0a7 466 obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); }
dicarloj 10:1163fb31b0a7 467 obj *prim_car(obj *args) { return car(car(args)); }
dicarloj 10:1163fb31b0a7 468 obj *prim_cdr(obj *args) { return cdr(car(args)); }
dicarloj 10:1163fb31b0a7 469
dicarloj 10:1163fb31b0a7 470
dicarloj 10:1163fb31b0a7 471 /*** Helpers *****/
dicarloj 10:1163fb31b0a7 472
dicarloj 10:1163fb31b0a7 473 obj *prim_print(obj *args) {
dicarloj 10:1163fb31b0a7 474 while(!isnil(args)) {
dicarloj 10:1163fb31b0a7 475 writeobj(car(args));
dicarloj 10:1163fb31b0a7 476 args = cdr(args);
dicarloj 10:1163fb31b0a7 477 sprintf(out_buf + strlen(out_buf)," ");
dicarloj 10:1163fb31b0a7 478 }
dicarloj 10:1163fb31b0a7 479 sprintf(out_buf + strlen(out_buf),"\n");
dicarloj 10:1163fb31b0a7 480 return nil;
dicarloj 10:1163fb31b0a7 481 }
dicarloj 10:1163fb31b0a7 482
dicarloj 10:1163fb31b0a7 483 /*** Initialization ***/
dicarloj 10:1163fb31b0a7 484 void init_sl3() {
dicarloj 10:1163fb31b0a7 485 nil = mksym("nil");
dicarloj 10:1163fb31b0a7 486 all_symbols = cons(nil, nil);
dicarloj 10:1163fb31b0a7 487 top_env = cons(cons(nil, nil), nil);
dicarloj 10:1163fb31b0a7 488 tee = intern("t");
dicarloj 10:1163fb31b0a7 489 extend_top(tee, tee);
dicarloj 10:1163fb31b0a7 490 quote = intern("quote");
dicarloj 10:1163fb31b0a7 491 s_if = intern("if");
dicarloj 10:1163fb31b0a7 492 s_lambda = intern("lambda");
dicarloj 10:1163fb31b0a7 493 s_define = intern("define");
dicarloj 10:1163fb31b0a7 494 s_setb = intern("set!");
dicarloj 10:1163fb31b0a7 495 s_begin = intern("begin");
dicarloj 10:1163fb31b0a7 496 extend_top(intern("+"), mkprimop(prim_sum));
dicarloj 10:1163fb31b0a7 497 extend_top(intern("-"), mkprimop(prim_sub));
dicarloj 10:1163fb31b0a7 498 extend_top(intern("*"), mkprimop(prim_prod));
dicarloj 10:1163fb31b0a7 499 extend_top(intern("/"), mkprimop(prim_divide));
dicarloj 10:1163fb31b0a7 500 extend_top(intern("="), mkprimop(prim_numeq));
dicarloj 10:1163fb31b0a7 501
dicarloj 10:1163fb31b0a7 502 extend_top(intern(">"), mkprimop(prim_gt));
dicarloj 10:1163fb31b0a7 503 extend_top(intern(">="), mkprimop(prim_ge));
dicarloj 10:1163fb31b0a7 504
dicarloj 10:1163fb31b0a7 505 extend_top(intern("<"), mkprimop(prim_lt));
dicarloj 10:1163fb31b0a7 506 extend_top(intern("<="), mkprimop(prim_le));
dicarloj 10:1163fb31b0a7 507
dicarloj 10:1163fb31b0a7 508 extend_top(intern("cons"), mkprimop(prim_cons));
dicarloj 10:1163fb31b0a7 509 extend_top(intern("car"), mkprimop(prim_car));
dicarloj 10:1163fb31b0a7 510 extend_top(intern("cdr"), mkprimop(prim_cdr));
dicarloj 10:1163fb31b0a7 511
dicarloj 10:1163fb31b0a7 512 extend_top(intern("print"), mkprimop(prim_print));
dicarloj 10:1163fb31b0a7 513 }
dicarloj 10:1163fb31b0a7 514
dicarloj 10:1163fb31b0a7 515 char* get_output()
dicarloj 10:1163fb31b0a7 516 {
dicarloj 10:1163fb31b0a7 517 return out_buf;
dicarloj 10:1163fb31b0a7 518 }
dicarloj 10:1163fb31b0a7 519
dicarloj 10:1163fb31b0a7 520 int lisp_init = 0;
dicarloj 10:1163fb31b0a7 521
dicarloj 10:1163fb31b0a7 522 /*** Main Driver ***/
dicarloj 10:1163fb31b0a7 523 int run_lisp(char* input) {
dicarloj 10:1163fb31b0a7 524 if(!lisp_init)
dicarloj 10:1163fb31b0a7 525 {
dicarloj 10:1163fb31b0a7 526 init_sl3();
dicarloj 10:1163fb31b0a7 527 lisp_init = 1;
dicarloj 10:1163fb31b0a7 528 }
dicarloj 10:1163fb31b0a7 529
dicarloj 10:1163fb31b0a7 530 init_buf();
dicarloj 10:1163fb31b0a7 531
dicarloj 10:1163fb31b0a7 532
dicarloj 10:1163fb31b0a7 533 lisp_exit = 0;
dicarloj 10:1163fb31b0a7 534 strcpy(in_buf, input);
dicarloj 10:1163fb31b0a7 535 if(!strncmp(input,"clear",4)){ clear_all_text(); return 0; }
dicarloj 10:1163fb31b0a7 536 if(!strncmp(input,"mem",3))
dicarloj 10:1163fb31b0a7 537 {
dicarloj 10:1163fb31b0a7 538 char memuse[40];
dicarloj 10:1163fb31b0a7 539 sprintf(memuse,"MEM: %d bytes",total_malloc);
dicarloj 10:1163fb31b0a7 540 draw_vincent_string(memuse);
dicarloj 10:1163fb31b0a7 541 return;
dicarloj 10:1163fb31b0a7 542 }
dicarloj 10:1163fb31b0a7 543 in_buf[in_buf_size - 1] = 0;
dicarloj 10:1163fb31b0a7 544 //new_line();
dicarloj 10:1163fb31b0a7 545 //draw_vincent_string(in_buf);
dicarloj 10:1163fb31b0a7 546 //new_line();
dicarloj 10:1163fb31b0a7 547 //print_vincent_string(in_buf);
dicarloj 10:1163fb31b0a7 548 // if(argc == 2)
dicarloj 10:1163fb31b0a7 549 // {
dicarloj 10:1163fb31b0a7 550 // memcpy(in_buf,argv[1],strlen(argv[1]));
dicarloj 10:1163fb31b0a7 551 // printf("%s\n",in_buf);
dicarloj 9:2a47b9ff8911 552 // }
dicarloj 10:1163fb31b0a7 553 // else
dicarloj 10:1163fb31b0a7 554 //sprintf(in_buf,"(+ 2 2)\n");
dicarloj 10:1163fb31b0a7 555 // char test_in[] = "(+ 2 2)\n";
dicarloj 10:1163fb31b0a7 556 // FILE* input_stream = open_memstream(test_in,8);
dicarloj 10:1163fb31b0a7 557 // fprintf(input_stream,"(+ 2 3)\n");
dicarloj 10:1163fb31b0a7 558 // char test_out[50];
dicarloj 10:1163fb31b0a7 559 // FILE* output_stream = fmemopen(test_out,50,"w");
dicarloj 10:1163fb31b0a7 560 //setinput(input_stream);
dicarloj 10:1163fb31b0a7 561 int lisp_count = 0;
dicarloj 10:1163fb31b0a7 562 while(!lisp_exit) {
dicarloj 10:1163fb31b0a7 563 writeobj(eval(readobj(), top_env));
dicarloj 10:1163fb31b0a7 564 //fflush(output_stream);
dicarloj 10:1163fb31b0a7 565 printf("\n");
dicarloj 10:1163fb31b0a7 566 printf("%s\n",out_buf);
dicarloj 10:1163fb31b0a7 567
dicarloj 10:1163fb31b0a7 568 lisp_count++;
dicarloj 10:1163fb31b0a7 569 if(lisp_count > 500) break;
dicarloj 10:1163fb31b0a7 570 //printf("outstream: %s\n",test_out);
dicarloj 10:1163fb31b0a7 571 }
dicarloj 10:1163fb31b0a7 572 draw_vincent_string(out_buf);
dicarloj 10:1163fb31b0a7 573 //draw_vincent_string("done!");
dicarloj 10:1163fb31b0a7 574 return 0;
dicarloj 10:1163fb31b0a7 575 }
dicarloj 10:1163fb31b0a7 576
dicarloj 10:1163fb31b0a7 577 void myexit(int code) {
dicarloj 10:1163fb31b0a7 578 printf("%d bytes left hanging\n", total_malloc);
dicarloj 10:1163fb31b0a7 579 lisp_exit = 1;
dicarloj 10:1163fb31b0a7 580 }