├── README.md ├── corelib.lisp └── sl3.c /README.md: -------------------------------------------------------------------------------- 1 | # Mini-Lisp in C 2 | 3 | This is a very small and limited Lisp interpreter based on 4 | [Andru Luvisi's](http://www.sonoma.edu/users/l/luvisi/sl3.c). 5 | Its lightweightness 6 | is very useful in learning how Lisp and Scheme internals work! 7 | 8 | It's a single C source file which you can run like this: 9 | 10 | ```bash 11 | gcc sl3.c && ((cat corelib.lisp; cat /dev/stdin) | ./a.out ) 12 | ``` 13 | 14 | This will compile the interpreter, 15 | load the corelib and get you ready 16 | with a "repl" where you can experiment. 17 | Once the interpreter is running, you could try 18 | 19 | ```scheme 20 | (+ 1 1) 21 | (cdr '(1 2)) 22 | (is-prime 103) 23 | (define X '(3 4 5)) 24 | (print 'first element 'of 'list 'X 'is (cdr X)) 25 | ``` -------------------------------------------------------------------------------- /corelib.lisp: -------------------------------------------------------------------------------- 1 | 2 | ; This is a very basic library 3 | ; for a rather basic LISP 4 | ; interpreter. 5 | ; 6 | ; by Kristian Lein-Mathisen 7 | ; 2011, built on Andru 8 | ; Luvisi's lisp 9 | ; interpreter. 10 | ; 11 | ; 12 | ; GPL License 13 | 14 | 15 | 16 | 17 | '===================== 18 | '|..loading-corelib..| 19 | '===================== 20 | 21 | ; use better naming (according 22 | ; to this article I read, you 23 | ; don't wanna use cdr) 24 | (define rest cdr) 25 | 26 | (define list-length 27 | (lambda (L) 28 | (if L 29 | (+ 1 (list-length (cdr L))) 30 | 0))) 31 | 32 | 33 | ; I am looking forward to get this working: 34 | (define rest-test ; that's not rest as in rest services ... but I hope 35 | ; you already knew that 36 | (lambda (a &rest b) 37 | (begin 38 | (print 'a 'is a) 39 | (print 'rest 'is &rest) 40 | (print 'b 'is b)))) 41 | 42 | (define not 43 | (lambda (x) 44 | (if x 45 | nil 46 | t))) 47 | 48 | 49 | (define factorial 50 | (lambda (N) 51 | (if (= N 1) 52 | 1 53 | (* N (factorial (- N 1)))))) 54 | 55 | ; remainder (% operator) 56 | ; returns 0 if x is divisible 57 | ; by d. the implementation is 58 | ; tricky: we count on the 59 | ; "rounding-off" at division and 60 | ; subtrack from the original 61 | 62 | (define rem 63 | (lambda (x d) 64 | (- x (* (/ x d) d)))) 65 | 66 | (define is-even 67 | (lambda (x) 68 | (if (= 0 (rem x 2)) 69 | t 70 | nil))) 71 | 72 | (define is-odd 73 | (lambda (x) 74 | (if (is-even x) 75 | nil 76 | t))) 77 | 78 | ; does y divide x? 79 | (define is-divisible 80 | (lambda (x y) 81 | (if (= y 1) 82 | nil 83 | (if (>= y x) 84 | nil 85 | (if (= 0 (rem x y)) 86 | t 87 | nil))))) 88 | 89 | (define is-prime 90 | (lambda (x) 91 | (if (is-even x) 92 | nil 93 | (is-prime-rec x 1)))) 94 | ; assumes x is odd 95 | (define is-prime-rec 96 | (lambda (x y) 97 | (if (is-divisible x y) 98 | nil 99 | (if (>= y x) 100 | t 101 | (is-prime-rec x (+ 2 y)))))) 102 | 103 | (define is-prime-on-list 104 | (lambda (x) 105 | (if (not x) 106 | nil 107 | (begin 108 | (print 'prime-check (car x) (is-prime (car x) 1)) 109 | (is-prime-on-list (rest x)))))) 110 | 111 | 112 | (is-prime-on-list '(1 2 3 4 5 6 7 8 9 10 11 12 13 103)) 113 | 114 | 115 | 116 | 117 | 118 | -------------------------------------------------------------------------------- /sl3.c: -------------------------------------------------------------------------------- 1 | /* A minimal Lisp interpreter 2 | Copyright 2004 Andru Luvisi 3 | 4 | This program is free software; you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation; either version 2 of the License , or 7 | (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program. If not, write to the Free Software 16 | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 17 | */ 18 | 19 | 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | 26 | #define error(X) do { fprintf(stderr, "%s\n", X); exit(1); } while (0) 27 | 28 | int line_num = 1; 29 | int total_malloc = 0; 30 | 31 | /*** List Structured Memory ***/ 32 | enum otype { INT, SYM, CONS, PROC, PRIMOP }; 33 | typedef struct obj { 34 | enum otype type; 35 | int line_num; 36 | struct obj *p[1]; 37 | } obj; 38 | typedef obj * (*primop)(obj *); 39 | obj *all_symbols, *top_env, *nil, *tee, *quote, 40 | *s_if, *s_lambda, *s_define, *s_setb, *s_begin; 41 | 42 | #define cons(X, Y) omake(CONS, 2, (X), (Y)) 43 | 44 | obj *car(obj *X) { 45 | if(X == 0) { 46 | fprintf(stderr, "warning: car argument null on line %d\n", line_num); 47 | return nil; 48 | } 49 | if(X == nil) 50 | return nil; 51 | if(X->type != CONS) { 52 | fprintf(stderr, "warning: car argument not a list (%d) on line %d\n", X->p[0], X->line_num); 53 | return nil; 54 | } 55 | return X->p[0]; 56 | } 57 | 58 | obj *cdr(obj *X) { 59 | if(X == nil) 60 | return nil; 61 | if(X->type != CONS) { 62 | fprintf(stderr, "warning: cdr argument not a list on line %d\n", X->line_num); 63 | return nil; 64 | } 65 | if(X->p[1] == 0) { 66 | fprintf(stderr, "error: cdr list element is zero-pointer at %d\n", X->line_num); 67 | return nil; 68 | } 69 | return X->p[1]; 70 | } 71 | 72 | #define setcar(X,Y) (((X)->p[0]) = (Y)) 73 | #define setcdr(X,Y) (((X)->p[1]) = (Y)) 74 | #define mkint(X) omake(INT, 1, (obj *)(X)) 75 | #define intval(X) ((int)((X)->type == INT ? (X)->p[0] : 0)) // intval for INT only 76 | #define mksym(X) omake(SYM, 1, (obj *)(X)) 77 | #define symname(X) ((char *)((X)->p[0])) 78 | #define mkprimop(X) omake(PRIMOP, 1, (obj *)(X)) 79 | #define primopval(X) ((primop)(X)->p[0]) 80 | #define mkproc(X,Y,Z) omake(PROC, 3, (X), (Y), (Z)) 81 | #define procargs(X) ((X)->p[0]) 82 | #define proccode(X) ((X)->p[1]) 83 | #define procenv(X) ((X)->p[2]) 84 | #define isnil(X) ((X) == nil) 85 | 86 | obj *omake(enum otype type, int count, ...) { 87 | obj *ret; 88 | va_list ap; 89 | int i; 90 | va_start(ap, count); 91 | int object_size = sizeof(obj) + (count - 1)*sizeof(obj *); 92 | total_malloc += object_size; 93 | 94 | ret = (obj *) malloc(object_size); 95 | ret->type = type; 96 | ret->line_num = line_num; 97 | for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *); 98 | va_end(ap); 99 | return ret; 100 | } 101 | 102 | obj *findsym(char *name) { 103 | obj *symlist; 104 | for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist)) 105 | if(!strcmp(name, symname(car(symlist)))) 106 | return symlist; 107 | return nil; 108 | } 109 | 110 | obj *intern(char *name) { 111 | obj *op = findsym(name); 112 | if(!isnil(op)) return car(op); 113 | op = mksym(name); 114 | all_symbols = cons(op, all_symbols); 115 | return op; 116 | } 117 | 118 | /*** Environment ***/ 119 | #define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV))) 120 | 121 | obj *multiple_extend(obj *env, obj *syms, obj *vals) { 122 | return isnil(syms) ? 123 | env : 124 | multiple_extend(extend(env, car(syms), car(vals)), 125 | cdr(syms), cdr(vals)); 126 | } 127 | 128 | obj *extend_top(obj *sym, obj *val) { 129 | setcdr(top_env, cons(cons(sym, val), cdr(top_env))); 130 | return val; 131 | } 132 | 133 | obj *assoc(obj *key, obj *alist) { 134 | if(isnil(alist)) return nil; 135 | if(car(car(alist)) == key) return car(alist); 136 | return assoc(key, cdr(alist)); 137 | } 138 | 139 | /*** Input/Output ***/ 140 | FILE *ifp; 141 | char *token_la; 142 | int la_valid = 0; 143 | #define MAXLEN 100 144 | char buf[MAXLEN]; 145 | int bufused; 146 | 147 | void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; } 148 | char *buf2str() { buf[bufused++] = '\0'; return strdup(buf); } 149 | void setinput(FILE *fp) { ifp = fp; } 150 | void putback_token(char *token) { token_la = token; la_valid = 1; } 151 | 152 | void myexit(int code); 153 | 154 | char *gettoken() { 155 | int ch; 156 | char comment=0; 157 | 158 | bufused = 0; 159 | if(la_valid) { la_valid = 0; return token_la; } 160 | do { 161 | if((ch = getc(ifp)) == EOF) myexit(0); 162 | 163 | if(ch == ';') comment = 1; 164 | if(ch == '\n') { 165 | comment = 0; 166 | line_num++; 167 | } 168 | 169 | } while(isspace(ch) || comment); 170 | 171 | 172 | add_to_buf(ch); 173 | if(strchr("()\'", ch)) return buf2str(); 174 | for(;;) { 175 | if((ch = getc(ifp)) == EOF) myexit(0); 176 | if(strchr("()\'", ch) || isspace(ch)) { 177 | ungetc(ch, ifp); 178 | return buf2str(); 179 | } 180 | add_to_buf(ch); 181 | } 182 | } 183 | 184 | obj *readlist(); 185 | obj *readobj() { 186 | char *token; 187 | 188 | token = gettoken(); 189 | if(!strcmp(token, "(")) return readlist(); 190 | if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil)); 191 | 192 | if(token[strspn(token, "0123456789")] == '\0' 193 | || (token[0] == '-' && strlen(token) > 1)) 194 | return mkint(atoi(token)); 195 | return intern(token); 196 | } 197 | 198 | obj *readlist() { 199 | char *token = gettoken(); 200 | obj *tmp; 201 | if(!strcmp(token, ")")) return nil; 202 | if(!strcmp(token, ".")) { 203 | tmp = readobj(); 204 | if(strcmp(gettoken(), ")")) exit(1); 205 | return tmp; 206 | } 207 | putback_token(token); 208 | tmp = readobj(); /* Must force evaluation order */ 209 | return cons(tmp, readlist()); 210 | } 211 | 212 | void writeobj(FILE *ofp, obj *op) { 213 | switch(op->type) { 214 | case INT: fprintf(ofp, "%d", intval(op)); break; 215 | case CONS: 216 | fprintf(ofp, "("); 217 | for(;;) { 218 | writeobj(ofp, car(op)); 219 | if(isnil(cdr(op))) { 220 | fprintf(ofp, ")"); 221 | break; 222 | } 223 | op = cdr(op); 224 | if(op->type != CONS) { 225 | fprintf(ofp, " . "); 226 | writeobj(ofp, op); 227 | fprintf(ofp, ")"); 228 | break; 229 | } 230 | fprintf(ofp, " "); 231 | } 232 | break; 233 | case SYM: 234 | if(isnil(op)) fprintf(ofp, "()"); 235 | else fprintf(ofp, "%s", symname(op)); 236 | break; 237 | case PRIMOP: fprintf(ofp, "#"); break; 238 | case PROC: fprintf(ofp, "#"); break; 239 | default: exit(1); 240 | } 241 | } 242 | 243 | /*** Evaluator (Eval/no Apply) ***/ 244 | obj *evlis(obj *exps, obj *env); 245 | 246 | obj *eval(obj *exp, obj *env) { 247 | obj *tmp, *proc, *vals; 248 | 249 | eval_start: 250 | 251 | if(exp == nil) return nil; 252 | 253 | switch(exp->type) { 254 | case INT: return exp; 255 | case SYM: tmp = assoc(exp, env); 256 | 257 | if(tmp == nil) { 258 | fprintf(stderr, "Unbound symbol "); 259 | writeobj(stderr, exp); 260 | fprintf(stderr, "\n"); 261 | return nil; 262 | } 263 | return cdr(tmp); 264 | 265 | 266 | 267 | case CONS: 268 | if(car(exp) == s_if) { 269 | if(eval(car(cdr(exp)), env) != nil) 270 | return eval(car(cdr(cdr(exp))), env); 271 | else 272 | return eval(car(cdr(cdr(cdr(exp)))), env); 273 | } 274 | if(car(exp) == s_lambda) 275 | return mkproc(car(cdr(exp)), cdr(cdr(exp)), env); 276 | if(car(exp) == quote) 277 | return car(cdr(exp)); 278 | if(car(exp) == s_define) 279 | return(extend_top(car(cdr(exp)), 280 | eval(car(cdr(cdr(exp))), env))); 281 | if(car(exp) == s_setb) { 282 | obj *pair = assoc(car(cdr(exp)), env); 283 | obj *newval = eval(car(cdr(cdr(exp))), env); 284 | setcdr(pair, newval); 285 | return newval; 286 | } 287 | if(car(exp) == s_begin) { 288 | exp = cdr(exp); 289 | if(exp == nil) return nil; 290 | for(;;) { 291 | if(cdr(exp) == nil) { 292 | exp = car(exp); 293 | goto eval_start; 294 | } 295 | eval(car(exp), env); 296 | exp = cdr(exp); 297 | } 298 | } 299 | proc = eval(car(exp), env); 300 | vals = evlis(cdr(exp), env); 301 | if(proc->type == PRIMOP) 302 | return (*primopval(proc))(vals); 303 | if(proc->type == PROC) { 304 | /* For dynamic scope, use env instead of procenv(proc) */ 305 | env = multiple_extend(procenv(proc), procargs(proc), vals); 306 | exp = cons(s_begin, proccode(proc)); 307 | goto eval_start; 308 | } 309 | printf("Bad PROC type\n"); 310 | return nil; 311 | case PRIMOP: return exp; 312 | case PROC: return exp; 313 | } 314 | /* Not reached */ 315 | return exp; 316 | } 317 | 318 | obj *evlis(obj *exps, obj *env) { 319 | if(exps == nil) return nil; 320 | return cons(eval(car(exps), env), 321 | evlis(cdr(exps), env)); 322 | } 323 | 324 | /*** Primitives ***/ 325 | obj *prim_sum(obj *args) { 326 | int sum; 327 | for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args)); 328 | return mkint(sum); 329 | } 330 | 331 | obj *prim_sub(obj *args) { 332 | int sum; 333 | for(sum = intval(car(args)), args = cdr(args); 334 | !isnil(args); 335 | sum -= intval(car(args)), args = cdr(args)); 336 | return mkint(sum); 337 | } 338 | 339 | obj *prim_prod(obj *args) { 340 | int prod; 341 | for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args)); 342 | return mkint(prod); 343 | } 344 | obj *prim_divide(obj *args) { 345 | int prod = intval(car(args)); 346 | args = cdr(args); 347 | while(!isnil(args)) { 348 | prod /= intval(car(args)); 349 | args = cdr(args); 350 | } 351 | 352 | return mkint(prod); 353 | } 354 | 355 | obj *prim_gt(obj *args) { 356 | return intval(car(args)) > intval(car(cdr(args))) ? tee : nil; 357 | } 358 | 359 | obj *prim_lt(obj *args) { 360 | return intval(car(args)) < intval(car(cdr(args))) ? tee : nil; 361 | } 362 | obj *prim_ge(obj *args) { 363 | return intval(car(args)) >= intval(car(cdr(args))) ? tee : nil; 364 | } 365 | obj *prim_le(obj *args) { 366 | return intval(car(args)) <= intval(car(cdr(args))) ? tee : nil; 367 | } 368 | obj *prim_numeq(obj *args) { 369 | return intval(car(args)) == intval(car(cdr(args))) ? tee : nil; 370 | } 371 | 372 | obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); } 373 | obj *prim_car(obj *args) { return car(car(args)); } 374 | obj *prim_cdr(obj *args) { return cdr(car(args)); } 375 | 376 | 377 | /*** Helpers *****/ 378 | 379 | obj *prim_print(obj *args) { 380 | while(!isnil(args)) { 381 | writeobj(stdout, car(args)); 382 | args = cdr(args); 383 | printf(" "); 384 | } 385 | printf("\n"); 386 | return nil; 387 | } 388 | 389 | /*** Initialization ***/ 390 | void init_sl3() { 391 | nil = mksym("nil"); 392 | all_symbols = cons(nil, nil); 393 | top_env = cons(cons(nil, nil), nil); 394 | tee = intern("t"); 395 | extend_top(tee, tee); 396 | quote = intern("quote"); 397 | s_if = intern("if"); 398 | s_lambda = intern("lambda"); 399 | s_define = intern("define"); 400 | s_setb = intern("set!"); 401 | s_begin = intern("begin"); 402 | extend_top(intern("+"), mkprimop(prim_sum)); 403 | extend_top(intern("-"), mkprimop(prim_sub)); 404 | extend_top(intern("*"), mkprimop(prim_prod)); 405 | extend_top(intern("/"), mkprimop(prim_divide)); 406 | extend_top(intern("="), mkprimop(prim_numeq)); 407 | 408 | extend_top(intern(">"), mkprimop(prim_gt)); 409 | extend_top(intern(">="), mkprimop(prim_ge)); 410 | 411 | extend_top(intern("<"), mkprimop(prim_lt)); 412 | extend_top(intern("<="), mkprimop(prim_le)); 413 | 414 | extend_top(intern("cons"), mkprimop(prim_cons)); 415 | extend_top(intern("car"), mkprimop(prim_car)); 416 | extend_top(intern("cdr"), mkprimop(prim_cdr)); 417 | 418 | extend_top(intern("print"), mkprimop(prim_print)); 419 | } 420 | 421 | /*** Main Driver ***/ 422 | int main() { 423 | init_sl3(); 424 | setinput(stdin); 425 | for(;;) { 426 | writeobj(stdout, eval(readobj(), top_env)); 427 | printf("\n"); 428 | } 429 | return 0; 430 | } 431 | 432 | void myexit(int code) { 433 | fprintf(stderr, "%d bytes left hanging\n", total_malloc); 434 | exit(code); 435 | } 436 | --------------------------------------------------------------------------------