├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── komplott.c ├── paper └── recursive.pdf └── tests ├── exp.scm ├── lisp15.scm ├── old.scm ├── test.scm └── true-tco.scm /.gitignore: -------------------------------------------------------------------------------- 1 | komplott 2 | komplott.opt 3 | .gdb_history 4 | *.dSYM/** 5 | .DS_Store 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Kristoffer Grönlund 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test clean 2 | 3 | all: komplott 4 | 5 | komplott: komplott.c 6 | $(CC) -g -Og -Wall -Werror -std=c11 -o $@ komplott.c 7 | wc -l $^ tests/lisp15.scm 8 | 9 | test: komplott tests/test.scm 10 | time -p ./komplott tests/test.scm 11 | ./komplott tests/lisp15.scm 12 | ./komplott tests/exp.scm 13 | 14 | clean: 15 | rm -f ./komplott 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # komplott 2 | 3 | A tribute to: 4 | 5 | > Recursive Functions of Symbolic Expressions 6 | > and Their Computation by Machine, Part I 7 | 8 | (as found in `paper/recursive.pdf`) 9 | 10 | A micro-subset of scheme / the original LISP in a single C file: `komplott.c` 11 | 12 | ### Features 13 | 14 | * Single file implementation. 15 | * Scheme-compliant enough for the test programs to be executable by 16 | GNU Guile. 17 | * Copying garbage collector based on Cheney's Algorithm. 18 | * Limited tail call optimization (not true TCO; see `tests/true-tco.scm`). 19 | * Near-zero error handling. 20 | * Zero thread safety or security. 21 | 22 | *Also includes:* 23 | 24 | ## `lisp15.scm` 25 | 26 | An implementation of the core of LISP 1.5 from 1962 27 | 28 | ## Instructions 29 | 30 | * To build the `komplott` executable, run `make`. The only dependency 31 | aside from `make` is `gcc`. 32 | 33 | * To run the LISP 1.5 interpreter and a couple of test cases, run `make lisp15`. 34 | 35 | ## LISP 1.5 36 | 37 | The version presented in the README is slightly tweaked from the one 38 | that can be found in `tests/lisp15.scm` in order to more closely 39 | resemble early LISP rather than scheme: `#t` and `#f` are written as 40 | `t` and `nil`. 41 | 42 | ``` lisp 43 | 44 | (define pairlis (lambda (x y a) 45 | (cond ((null? x) a) 46 | (t (cons (cons (car x) (car y)) 47 | (pairlis (cdr x) (cdr y) a)))))) 48 | 49 | (define assoc (lambda (x a) 50 | (cond ((equal? (caar a) x) (car a)) 51 | (t (assoc x (cdr a)))))) 52 | 53 | (define atom? (lambda (x) 54 | (cond 55 | ((null? x) t) 56 | ((atom? x) t) 57 | (t nil)))) 58 | 59 | (define evcon (lambda (c a) 60 | (cond 61 | ((eval (caar c) a) (eval (cadar c) a)) 62 | (t (evcon (cdr c) a))))) 63 | 64 | (define evlis (lambda (m a) 65 | (cond 66 | ((null? m) nil) 67 | (t (cons (eval (car m) a) 68 | (evlis (cdr m) a)))))) 69 | 70 | (define apply (lambda (fun x a) 71 | (cond 72 | ((atom? fun) 73 | (cond 74 | ((equal? fun (quote CAR)) (caar x)) 75 | ((equal? fun (quote CDR)) (cdar x)) 76 | ((equal? fun (quote CONS)) (cons (car x) (cadr x))) 77 | ((equal? fun (quote ATOM)) (atom? (car x))) 78 | ((equal? fun (quote EQ)) (equal? (car x) (cadr x))) 79 | (t (apply (eval fun a) x a)))) 80 | 81 | ((equal? (car fun) (quote LAMBDA)) 82 | (eval (caddr fun) (pairlis (cadr fun) x a))) 83 | 84 | ((equal? (car fun) (quote LABEL)) 85 | (apply 86 | (caddr fun) 87 | x 88 | (cons 89 | (cons (cadr fun) (caddr fun)) 90 | a)))))) 91 | 92 | (define eval (lambda (e a) 93 | (cond 94 | ((atom? e) (cdr (assoc e a))) 95 | ((atom? (car e)) 96 | (cond 97 | ((equal? (car e) (quote QUOTE)) (cadr e)) 98 | ((equal? (car e) (quote COND)) (evcon (cdr e) a)) 99 | (t (apply (car e) (evlis (cdr e) a) a)))) 100 | (t (apply (car e) (evlis (cdr e) a) a))))) 101 | 102 | (define evalquote (lambda (fn x) (apply fn x (quote ())))) 103 | 104 | ``` 105 | 106 | Here is an example of actual LISP 1.5 code: 107 | 108 | ``` lisp 109 | ((LABEL MAPCAR 110 | (LAMBDA (FN SEQ) 111 | (COND 112 | ((EQ NIL SEQ) NIL) 113 | (T (CONS (FN (CAR SEQ)) 114 | (MAPCAR FN (CDR SEQ))))))) 115 | DUP LST) 116 | 117 | ; where 118 | ; DUP -> (LAMBDA (X) (CONS X X)) 119 | ; LST -> (A B C) 120 | ``` 121 | 122 | > To prevent reading from continuing indefinitely, each packet should end 123 | > with STOP followed by a large number of right parentheses. An unpaired right parenthesis 124 | > will cause a read error and terminate reading. 125 | 126 | `STOP )))))))))))))))))` 127 | -------------------------------------------------------------------------------- /komplott.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | typedef enum { T_CONS, T_ATOM, T_CFUNC, T_LAMBDA } object_tag; 9 | 10 | struct object_t; 11 | typedef struct object_t *(*cfunc)(struct object_t *); 12 | 13 | typedef struct object_t { 14 | struct object_t *car, *cdr; 15 | object_tag tag; 16 | } object; 17 | 18 | #define TOKEN_MAX 256 19 | #define HASHMAP_SIZE 2048 20 | #define ATOMCHAR(ch) (((ch) >= '!' && (ch) <= '\'') || ((ch) >= '*' && (ch) <= '~')) 21 | #define TEXT(x) (((x) && (x)->tag == T_ATOM) ? ((const char *)((x)->car)) : "") 22 | #define HEAPSIZE 16384 23 | #define MAXROOTS 500 24 | #define MAXFRAMES 50 25 | 26 | const char *TQUOTE = NULL, *TLAMBDA = NULL, *TCOND = NULL, *TDEFINE = NULL; 27 | char token_text[TOKEN_MAX]; 28 | int token_peek = 0; 29 | object *atom_t = NULL; 30 | object *heap, *tospace, *fromspace, *allocptr, *scanptr; 31 | object ** roots[MAXROOTS]; 32 | size_t rootstack[MAXFRAMES]; 33 | size_t roottop, numroots; 34 | object fwdmarker = { .tag = T_ATOM, .car = 0, .cdr = 0 }; 35 | 36 | void gc_init(void); 37 | object *gc_alloc(object_tag tag, object *car, object *cdr); 38 | void gc_protect(object **r, ...); 39 | void gc_pop(void); 40 | object *lisp_read_list(const char *tok, FILE *in); 41 | object *lisp_read_obj(const char *tok, FILE *in); 42 | object *lisp_read(FILE *in); 43 | void lisp_print(object *obj); 44 | object *lisp_eval(object *obj, object *env); 45 | 46 | size_t djbhash(const unsigned char *str) { 47 | size_t hash = 5381; 48 | for (int c = *str++; c; c = *str++) 49 | hash = (hash << 5) + hash + c; 50 | return hash; 51 | } 52 | 53 | const char *intern_string(const char *str) { 54 | typedef struct node { struct node *next; char data[]; } node_t; 55 | static node_t* nodes[HASHMAP_SIZE] = {0}; 56 | size_t hash = djbhash((const unsigned char *)str) % HASHMAP_SIZE; 57 | for (node_t* is = nodes[hash]; is != NULL; is = is->next) 58 | if (strcmp(is->data, str) == 0) 59 | return is->data; 60 | size_t sz = strlen(str) + 1; 61 | node_t *item = malloc(sizeof(node_t) + sz); 62 | memcpy(item->data, str, sz); 63 | item->next = nodes[hash]; 64 | nodes[hash] = item; 65 | return item->data; 66 | } 67 | 68 | int match_number(const char *s) { 69 | if (*s == '-' || *s == '+') s++; 70 | do { if (*s < '0' || *s > '9') return 0; } while (*++s != '\0'); 71 | return 1; 72 | } 73 | 74 | const char* itos(long n) { 75 | char buf[TOKEN_MAX], reversed[TOKEN_MAX]; 76 | char *p1 = buf, *p2 = reversed; 77 | unsigned long u = (unsigned long)n; 78 | if (n < 0) { *p1++ = '-'; u = ~u + 1; } 79 | do { *p2++ = (char)(u % 10) + '0'; u /= 10; } while (u > 0); 80 | do { *p1++ = *--p2; } while (p2 != reversed); 81 | *p1 = '\0'; 82 | return intern_string(buf); 83 | } 84 | 85 | object *new_cfunc(cfunc func) { 86 | return gc_alloc(T_CFUNC, (object *)func, NULL); 87 | } 88 | 89 | object *new_atom(const char *str) { 90 | return gc_alloc(T_ATOM, (object *)intern_string(str), NULL); 91 | } 92 | 93 | object *new_cons(object *car, object *cdr) { 94 | gc_protect(&car, &cdr, NULL); 95 | object *ret = gc_alloc(T_CONS, car, cdr); 96 | gc_pop(); 97 | return ret; 98 | } 99 | 100 | const char *read_token(FILE *in) { 101 | int n = 0; 102 | while (isspace(token_peek)) 103 | token_peek = fgetc(in); 104 | if (token_peek == '(' || token_peek == ')') { 105 | token_text[n++] = token_peek; 106 | token_peek = fgetc(in); 107 | } else while (ATOMCHAR(token_peek)) { 108 | if (n == TOKEN_MAX) 109 | abort(); 110 | token_text[n++] = token_peek; 111 | token_peek = fgetc(in); 112 | } 113 | if (token_peek == EOF) 114 | exit(0); 115 | token_text[n] = '\0'; 116 | return intern_string(token_text); 117 | } 118 | 119 | object *lisp_read_obj(const char *tok, FILE *in) { 120 | return (tok[0] != '(') ? new_atom(tok) : 121 | lisp_read_list(read_token(in), in); 122 | } 123 | 124 | object *lisp_read_list(const char *tok, FILE *in) { 125 | if (tok[0] == ')') 126 | return NULL; 127 | object *obj = NULL, *tmp = NULL, *obj2 = NULL; 128 | gc_protect(&obj, &tmp, &obj2, NULL); 129 | obj = lisp_read_obj(tok, in); 130 | tok = read_token(in); 131 | if (tok[0] == '.' && tok[1] == '\0') { 132 | tok = read_token(in); 133 | tmp = lisp_read_obj(tok, in); 134 | obj2 = new_cons(obj, tmp); 135 | tok = read_token(in); 136 | gc_pop(); 137 | if (tok[0] == ')') 138 | return obj2; 139 | fputs("Error: Malformed dotted cons\n", stderr); 140 | return NULL; 141 | } 142 | tmp = lisp_read_list(tok, in); 143 | obj2 = new_cons(obj, tmp); 144 | gc_pop(); 145 | return obj2; 146 | } 147 | 148 | object *lisp_read(FILE *in) { 149 | const char *tok = read_token(in); 150 | if (tok == NULL) 151 | return NULL; 152 | if (tok[0] != ')') 153 | return lisp_read_obj(tok, in); 154 | fputs("Error: Unexpected )\n", stderr); 155 | return NULL; 156 | } 157 | 158 | int lisp_equal(object *a, object *b) { 159 | if (a == b) 160 | return 1; 161 | if (a == NULL || b == NULL || a->tag != b->tag) 162 | return 0; 163 | if (a->tag != T_CONS) 164 | return a->car == b->car; 165 | return lisp_equal(a->car, b->car) && lisp_equal(a->cdr, b->cdr); 166 | } 167 | 168 | object *list_find_pair(object *needle, object *haystack) { 169 | for (; haystack != NULL; haystack = haystack->cdr) 170 | if (haystack->car != NULL && lisp_equal(needle, haystack->car->car)) 171 | return haystack->car; 172 | return NULL; 173 | } 174 | 175 | object *env_lookup(object *needle, object *haystack) { 176 | for (object *pair; haystack != NULL; haystack = haystack->cdr) 177 | if ((pair = list_find_pair(needle, haystack->car)) != NULL) 178 | return pair->cdr; 179 | return NULL; 180 | } 181 | 182 | object *env_set(object *env, object *key, object *value) { 183 | object *pair = NULL, *frame = NULL; 184 | gc_protect(&env, &key, &value, &pair, &frame, NULL); 185 | pair = new_cons(key, value); 186 | frame = new_cons(pair, env->car); 187 | env->car = frame; 188 | gc_pop(); 189 | return env; 190 | } 191 | 192 | object *list_reverse(object *lst) { 193 | if (lst == NULL) 194 | return NULL; 195 | object *prev = NULL, *curr = lst, *next = lst->cdr; 196 | while (curr) { 197 | curr->cdr = prev; 198 | prev = curr; 199 | curr = next; 200 | if (next != NULL) 201 | next = next->cdr; 202 | } 203 | return prev; 204 | } 205 | 206 | object *lisp_eval(object *expr, object *env) { 207 | restart: 208 | if (expr == NULL) 209 | return expr; 210 | if (expr->tag == T_ATOM) 211 | return match_number(TEXT(expr)) ? expr : env_lookup(expr, env); 212 | if (expr->tag != T_CONS) 213 | return expr; 214 | object *head = expr->car; 215 | if (TEXT(head) == TQUOTE) { 216 | return expr->cdr->car; 217 | } else if (TEXT(head) == TCOND) { 218 | object *item = NULL, *cond = NULL; 219 | gc_protect(&expr, &env, &item, &cond, NULL); 220 | for (item = expr->cdr; item != NULL; item = item->cdr) { 221 | cond = item->car; 222 | if (lisp_eval(cond->car, env) != NULL) { 223 | expr = cond->cdr->car; 224 | gc_pop(); 225 | goto restart; 226 | } 227 | } 228 | return NULL; // was abort(), but no match should return nil 229 | } else if (TEXT(head) == TDEFINE) { 230 | object *name = NULL, *value = NULL; 231 | gc_protect(&env, &name, &value, NULL); 232 | name = expr->cdr->car; 233 | value = lisp_eval(expr->cdr->cdr->car, env); 234 | env_set(env, name, value); 235 | gc_pop(); 236 | return value; 237 | } else if (TEXT(head) == TLAMBDA) { 238 | expr->cdr->tag = T_LAMBDA; 239 | return expr->cdr; 240 | } 241 | 242 | object *fn = NULL, *args = NULL, *params = NULL, *param = NULL; 243 | gc_protect(&expr, &env, &fn, &args, ¶ms, ¶m, NULL); 244 | fn = lisp_eval(head, env); 245 | if (fn->tag == T_CFUNC) { 246 | for (params = expr->cdr; params != NULL; params = params->cdr) { 247 | param = lisp_eval(params->car, env); 248 | args = new_cons(param, args); 249 | } 250 | object *ret = ((cfunc)fn->car)(list_reverse(args)); 251 | gc_pop(); 252 | return ret; 253 | } else if (fn->tag == T_LAMBDA) { 254 | object *callenv = new_cons(NULL, env); 255 | args = fn->car; 256 | object *item = NULL; 257 | gc_protect(&callenv, &item, NULL); 258 | for (params = expr->cdr; params != NULL; params = params->cdr, args = args->cdr) { 259 | param = lisp_eval(params->car, env); 260 | env_set(callenv, args->car, param); 261 | } 262 | for (item = fn->cdr; item != NULL; item = item->cdr) { 263 | if (item->cdr == NULL) { 264 | expr = item->car; 265 | env = callenv; 266 | gc_pop(); 267 | gc_pop(); 268 | goto restart; 269 | } 270 | lisp_eval(item->car, callenv); 271 | } 272 | gc_pop(); 273 | gc_pop(); 274 | } 275 | return NULL; 276 | } 277 | 278 | void lisp_print(object *obj) { 279 | if (obj == NULL) { 280 | fputs("()", stdout); 281 | } else if (obj->tag == T_ATOM) { 282 | fputs(TEXT(obj), stdout); 283 | } else if (obj->tag == T_CFUNC) { 284 | printf("", (void *)obj); 285 | } else if (obj->tag == T_LAMBDA) { 286 | fputs("car); 288 | fputs(">", stdout); 289 | } else if (obj->tag == T_CONS) { 290 | fputs("(", stdout); 291 | for (;;) { 292 | lisp_print(obj->car); 293 | if (obj->cdr == NULL) 294 | break; 295 | fputs(" ", stdout); 296 | if (obj->cdr->tag != T_CONS) { 297 | fputs(". ", stdout); 298 | lisp_print(obj->cdr); 299 | break; 300 | } 301 | obj = obj->cdr; 302 | } 303 | fputs(")", stdout); 304 | } 305 | } 306 | 307 | object *builtin_car(object *args) { 308 | return args->car->car; 309 | } 310 | 311 | object *builtin_cdr(object *args) { 312 | return args->car->cdr; 313 | } 314 | 315 | object *builtin_cons(object *args) { 316 | return new_cons(args->car, args->cdr->car); 317 | } 318 | 319 | object *builtin_equal(object *args) { 320 | object *cmp = args->car; 321 | for (args = args->cdr; args != NULL; args = args->cdr) 322 | if (!lisp_equal(cmp, args->car)) 323 | return NULL; 324 | return atom_t; 325 | } 326 | 327 | object *builtin_pair(object *args) { 328 | return (args->car != NULL && args->car->tag == T_CONS) ? atom_t : NULL; 329 | } 330 | 331 | object *builtin_null(object *args) { 332 | return (args->car == NULL) ? atom_t : NULL; 333 | } 334 | 335 | object *builtin_sum(object *args) { 336 | long sum = 0; 337 | for (; args != NULL; args = args->cdr) 338 | sum += atol(TEXT(args->car)); 339 | return new_atom(itos(sum)); 340 | } 341 | 342 | object *builtin_sub(object *args) { 343 | long n; 344 | if (args->cdr == NULL) { 345 | n = -atol(TEXT(args->car)); 346 | } else { 347 | n = atol(TEXT(args->car)); 348 | for (args = args->cdr; args != NULL; args = args->cdr) 349 | n = n - atol(TEXT(args->car)); 350 | } 351 | return new_atom(itos(n)); 352 | } 353 | 354 | object *builtin_mul(object *args) { 355 | long sum = 1; 356 | for (; args != NULL; args = args->cdr) 357 | sum *= atol(TEXT(args->car)); 358 | return new_atom(itos(sum)); 359 | } 360 | 361 | object *builtin_display(object *args) { 362 | lisp_print(args->car); 363 | return NULL; 364 | } 365 | 366 | object *builtin_newline(object *args) { 367 | puts(""); 368 | return NULL; 369 | } 370 | 371 | object *builtin_read(object *args) { 372 | return lisp_read(stdin); 373 | } 374 | 375 | void defun(object *env, const char *name, cfunc fn) { 376 | object *key = NULL, *val = NULL; 377 | gc_protect(&env, &key, &val, NULL); 378 | key = new_atom(name); 379 | val = new_cfunc(fn); 380 | env_set(env, key, val); 381 | gc_pop(); 382 | } 383 | 384 | void gc_copy(object **root) { 385 | if (*root == NULL) 386 | return; 387 | if ((*root)->car == &fwdmarker) { 388 | *root = (*root)->cdr; 389 | } else if (*root < fromspace || *root >= (fromspace + HEAPSIZE)) { 390 | object *p = allocptr++; 391 | memcpy(p, *root, sizeof(object)); 392 | (*root)->car = &fwdmarker; 393 | (*root)->cdr = p; 394 | *root = p; 395 | } 396 | } 397 | 398 | void gc_collect(void) { 399 | object *tmp = fromspace; 400 | fromspace = tospace; 401 | tospace = tmp; 402 | allocptr = scanptr = fromspace; 403 | 404 | for (size_t i = 0; i < numroots; ++i) 405 | gc_copy(roots[i]); 406 | 407 | for (; scanptr < allocptr; ++scanptr) 408 | if (scanptr->tag == T_CONS || scanptr->tag == T_LAMBDA) { 409 | gc_copy(&(scanptr->car)); 410 | gc_copy(&(scanptr->cdr)); 411 | } 412 | } 413 | 414 | void gc_init(void) { 415 | allocptr = fromspace = heap = malloc(sizeof(object) * HEAPSIZE * 2); 416 | scanptr = tospace = heap + HEAPSIZE; 417 | numroots = roottop = 0; 418 | } 419 | 420 | object *gc_alloc(object_tag tag, object *car, object *cdr) { 421 | if (allocptr + 1 > fromspace + HEAPSIZE) { 422 | if (tag == T_CONS) 423 | gc_protect(&car, &cdr, NULL); 424 | gc_collect(); 425 | if (tag == T_CONS) 426 | gc_pop(); 427 | } 428 | if (allocptr + 1 > fromspace + HEAPSIZE) { 429 | fputs("Out of memory\n", stderr); 430 | abort(); 431 | } 432 | allocptr->tag = tag; 433 | allocptr->car = car; 434 | allocptr->cdr = cdr; 435 | return allocptr++; 436 | } 437 | 438 | void gc_protect(object **r, ...) { 439 | va_list args; 440 | rootstack[roottop++] = numroots; 441 | va_start(args, r); 442 | for (object **p = r; p != NULL; p = va_arg(args, object **)) { 443 | roots[numroots++] = p; 444 | } 445 | va_end(args); 446 | } 447 | 448 | void gc_pop(void) { 449 | numroots = rootstack[--roottop]; 450 | } 451 | 452 | int main(int argc, char* argv[]) { 453 | gc_init(); 454 | TQUOTE = intern_string("quote"); 455 | TLAMBDA = intern_string("lambda"); 456 | TCOND = intern_string("cond"); 457 | TDEFINE = intern_string("define"); 458 | memset(token_text, 0, TOKEN_MAX); 459 | token_peek = ' '; 460 | 461 | object *env = NULL, *atom_f = NULL, *obj = NULL; 462 | gc_protect(&env, &atom_t, &atom_f, &obj, NULL); 463 | env = new_cons(NULL, NULL); 464 | atom_t = new_atom("#t"); 465 | atom_f = new_atom("#f"); 466 | env_set(env, atom_t, atom_t); 467 | env_set(env, atom_f, NULL); 468 | defun(env, "car", &builtin_car); 469 | defun(env, "cdr", &builtin_cdr); 470 | defun(env, "cons", &builtin_cons); 471 | defun(env, "equal?", &builtin_equal); 472 | defun(env, "pair?", &builtin_pair); 473 | defun(env, "null?", &builtin_null); 474 | defun(env, "+", &builtin_sum); 475 | defun(env, "-", &builtin_sub); 476 | defun(env, "*", &builtin_mul); 477 | defun(env, "display", &builtin_display); 478 | defun(env, "newline", &builtin_newline); 479 | defun(env, "read", &builtin_read); 480 | FILE *in = (argc > 1) ? fopen(argv[1], "r") : stdin; 481 | for (;;) { 482 | obj = lisp_read(in); 483 | obj = lisp_eval(obj, env); 484 | if (in == stdin) { 485 | lisp_print(obj); 486 | puts(""); 487 | } 488 | } 489 | return 0; 490 | } 491 | -------------------------------------------------------------------------------- /paper/recursive.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/krig/LISP/0260bd5907e29a7b8f166045a54b91e15b9e8c6f/paper/recursive.pdf -------------------------------------------------------------------------------- /tests/exp.scm: -------------------------------------------------------------------------------- 1 | (define exp (lambda (base pow) 2 | (cond ((equal? pow 0) 1) 3 | (#t (* base (exp base (- pow 1))))))) 4 | 5 | (define displayln (lambda (x) 6 | (display x) 7 | (newline))) 8 | 9 | (define main (lambda () 10 | (displayln (exp 2 16)))) 11 | 12 | (main) 13 | -------------------------------------------------------------------------------- /tests/lisp15.scm: -------------------------------------------------------------------------------- 1 | (define cadr (lambda (c) (car (cdr c)))) 2 | (define cdar (lambda (c) (cdr (car c)))) 3 | (define caar (lambda (c) (car (car c)))) 4 | (define cddr (lambda (c) (cdr (cdr c)))) 5 | (define caadr (lambda (c) (car (car (cdr c))))) 6 | (define cadar (lambda (c) (car (cdr (car c))))) 7 | (define caaar (lambda (c) (car (car (car c))))) 8 | (define caddr (lambda (c) (car (cdr (cdr c))))) 9 | (define cdadr (lambda (c) (cdr (car (cdr c))))) 10 | (define cddar (lambda (c) (cdr (cdr (car c))))) 11 | (define cdaar (lambda (c) (cdr (car (car c))))) 12 | (define cdddr (lambda (c) (cdr (cdr (cdr c))))) 13 | (define not (lambda (x) (cond ((null? x) #t) (#t #f)))) 14 | (define atom? (lambda (x) (cond ((null? x) #f) ((pair? x) #f) (#t #t)))) 15 | (define else #t) 16 | 17 | (define assert (lambda (expr expect) 18 | (display (cond ((equal? expr expect) (quote pass:_)) (else (quote fail:_)))) 19 | (display expr) 20 | (newline))) 21 | 22 | (define pairlis (lambda (x y a) 23 | (cond ((null? x) a) 24 | (else (cons (cons (car x) (car y)) 25 | (pairlis (cdr x) (cdr y) a)))))) 26 | 27 | (define assoc (lambda (x a) 28 | (cond ((equal? (caar a) x) (car a)) 29 | (else (assoc x (cdr a)))))) 30 | 31 | (define atom2 (lambda (x) 32 | (cond 33 | ((null? x) #t) 34 | ((atom? x) #t) 35 | (else #f)))) 36 | 37 | (define evcon (lambda (c a) 38 | (cond 39 | ((eval (caar c) a) (eval (cadar c) a)) 40 | (else (evcon (cdr c) a))))) 41 | 42 | (define evlis (lambda (m a) 43 | (cond 44 | ((null? m) #f) 45 | (else (cons (eval (car m) a) 46 | (evlis (cdr m) a)))))) 47 | 48 | (define apply (lambda (fun x a) 49 | (cond 50 | ((atom2 fun) 51 | (cond 52 | ((equal? fun (quote CAR)) (caar x)) 53 | ((equal? fun (quote CDR)) (cdar x)) 54 | ((equal? fun (quote CONS)) (cons (car x) (cadr x))) 55 | ((equal? fun (quote ATOM)) (atom2 (car x))) 56 | ((equal? fun (quote EQ)) (equal? (car x) (cadr x))) 57 | (else (apply (eval fun a) x a)))) 58 | 59 | ((equal? (car fun) (quote LAMBDA)) 60 | (eval (caddr fun) (pairlis (cadr fun) x a))) 61 | 62 | ((equal? (car fun) (quote LABEL)) 63 | (apply 64 | (caddr fun) 65 | x 66 | (cons 67 | (cons (cadr fun) (caddr fun)) 68 | a)))))) 69 | 70 | (define eval (lambda (e a) 71 | (cond 72 | ((atom2 e) (cdr (assoc e a))) 73 | ((atom2 (car e)) 74 | (cond 75 | ((equal? (car e) (quote QUOTE)) (cadr e)) 76 | ((equal? (car e) (quote COND)) (evcon (cdr e) a)) 77 | (else (apply (car e) (evlis (cdr e) a) a)))) 78 | (else (apply (car e) (evlis (cdr e) a) a))))) 79 | 80 | (define evalquote (lambda (fn x) (apply fn x (quote ())))) 81 | 82 | (assert (pairlis (quote (a b c)) (quote (1 2 3)) (quote ())) (quote ((a . 1) (b . 2) (c . 3)))) 83 | (assert (assoc (quote x) (quote ((y . 5) (x . 3) (z . 7)))) (quote (x . 3))) 84 | (assert (evlis (quote ()) (quote ())) #f) 85 | (assert (eval (quote Y) (quote ((X . 1) (Y . 2) (Z . 3)))) 2) 86 | (assert (eval 87 | (quote ((LABEL MAPCAR 88 | (LAMBDA (FN SEQ) 89 | (COND 90 | ((EQ NIL SEQ) NIL) 91 | (T (CONS (FN (CAR SEQ)) 92 | (MAPCAR FN (CDR SEQ))))))) 93 | DUP 94 | LST)) 95 | (quote ((NIL . ()) 96 | (T . #t) 97 | (DUP . (LAMBDA (X) (CONS X X))) 98 | (LST . (A B C))))) 99 | (quote ((A . A) (B . B) (C . C)))) 100 | (assert (evalquote (quote (LAMBDA (X Y) (CONS (CAR X) Y))) (quote ((A B) (C D)))) (quote (A C D))) 101 | -------------------------------------------------------------------------------- /tests/old.scm: -------------------------------------------------------------------------------- 1 | (define atom? (lambda (x) (cond ((null? x) #f) ((pair? x) #f) (#t #t)))) 2 | (define cadr (lambda (x) (car (cdr x)))) 3 | (define displayln (lambda (x) (display x) (newline))) 4 | 5 | (displayln (quote hello-world)) 6 | (displayln (car (quote (hello-world goodbye-world)))) 7 | (displayln (cadr (quote (hello-world goodbye-world)))) 8 | (displayln ((lambda (x) (x (quote (1 2)))) car)) 9 | (displayln ((lambda (x) (x (quote (1 2)))) cadr)) 10 | 11 | (define ff (lambda (x) 12 | (cond 13 | ((pair? x) (ff (car x))) 14 | (#t x)))) 15 | 16 | (define mapcar (lambda (f l) 17 | (cond 18 | ((null? l) #f) 19 | (#t (cons (f (car l)) (mapcar f (cdr l))))))) 20 | 21 | (displayln (mapcar ff (quote ((5 2) 3)))) 22 | -------------------------------------------------------------------------------- /tests/test.scm: -------------------------------------------------------------------------------- 1 | (define cadr (lambda (c) (car (cdr c)))) 2 | (define cdar (lambda (c) (cdr (car c)))) 3 | (define caar (lambda (c) (car (car c)))) 4 | (define cddr (lambda (c) (cdr (cdr c)))) 5 | (define caadr (lambda (c) (car (car (cdr c))))) 6 | (define cadar (lambda (c) (car (cdr (car c))))) 7 | (define caaar (lambda (c) (car (car (car c))))) 8 | (define caddr (lambda (c) (car (cdr (cdr c))))) 9 | (define cdadr (lambda (c) (cdr (car (cdr c))))) 10 | (define cddar (lambda (c) (cdr (cdr (car c))))) 11 | (define cdaar (lambda (c) (cdr (car (car c))))) 12 | (define cdddr (lambda (c) (cdr (cdr (cdr c))))) 13 | 14 | (define not (lambda (x) (cond ((null? x) #t) (#t #f)))) 15 | 16 | (define atom? (lambda (x) 17 | (cond ((null? x) #f) 18 | ((pair? x) #f) 19 | (#t #t)))) 20 | 21 | (define else #t) 22 | 23 | (define displayln (lambda (x) (display x) (newline))) 24 | 25 | (define assert (lambda (expr expect) 26 | (cond ((equal? expr expect) 27 | ((lambda () (display (quote pass:_)) (displayln expr)))) 28 | (else 29 | ((lambda () (display (quote fail:_)) (displayln expr))))))) 30 | 31 | (define sq (lambda (x) (* x x))) 32 | (assert (sq 3) 9) 33 | 34 | (define length (lambda (l) (cond ((null? l) 0) (else (+ 1 (length (cdr l))))))) 35 | (assert (length (quote (1 2 3))) 3) 36 | 37 | 38 | (displayln (quote fac_15)) 39 | 40 | (define fac (lambda (n) 41 | (cond ((equal? n 0) 1) 42 | (else (* n (fac (- n 1))))))) 43 | 44 | (fac 15) 45 | (assert (fac 15) (quote 1307674368000)) 46 | 47 | 48 | (displayln (quote two-in-a-row?)) 49 | 50 | (define member? (lambda (a lat) 51 | (cond 52 | ((null? lat) #f) 53 | ((equal? a (car lat)) #t) 54 | ((member? a (cdr lat)) #t) 55 | (else #f)))) 56 | 57 | (define is-first? (lambda (a lat) 58 | (cond 59 | ((null? lat) #f) 60 | (else (equal? (car lat) a))))) 61 | 62 | (define two-in-a-row? (lambda (lat) 63 | (cond 64 | ((null? lat) #f) 65 | ((is-first? (car lat) (cdr lat)) #t) 66 | ((two-in-a-row? (cdr lat)) #t) 67 | (else #f)))) 68 | 69 | (assert (two-in-a-row? (quote (Italian sardines spaghetti parsley))) #f) 70 | (assert (two-in-a-row? (quote (Italian sardines sardines spaghetti parsley))) #t) 71 | (assert (two-in-a-row? (quote (Italian sardines more sardines spaghetti))) #f) 72 | 73 | 74 | (displayln (quote sum-of-prefixes)) 75 | 76 | (define sum-of-prefixes-helper 77 | (lambda (sonssf tup) 78 | (cond 79 | ((null? tup) (quote ())) 80 | (else (cons (+ sonssf (car tup)) 81 | (sum-of-prefixes-helper 82 | (+ sonssf (car tup)) 83 | (cdr tup))))))) 84 | 85 | (define sum-of-prefixes (lambda (tup) (sum-of-prefixes-helper 0 tup))) 86 | 87 | (assert (sum-of-prefixes (quote (1 1 1))) (quote (1 2 3))) 88 | (assert (sum-of-prefixes (quote (1 1 1 1 1))) (quote (1 2 3 4 5))) 89 | (assert (sum-of-prefixes (quote (2 1 9 17 0))) (quote (2 3 12 29 29))) 90 | 91 | 92 | (displayln (quote lisp-in-lisp)) 93 | 94 | (define pairlis (lambda (x y a) 95 | (cond ((null? x) a) 96 | (else (cons (cons (car x) (car y)) 97 | (pairlis (cdr x) (cdr y) a)))))) 98 | 99 | (define assoc (lambda (x a) 100 | (cond ((equal? (caar a) x) (car a)) 101 | (else (assoc x (cdr a)))))) 102 | 103 | (assert (pairlis (quote (a b c)) (quote (1 2 3)) (quote ())) (quote ((a . 1) (b . 2) (c . 3)))) 104 | (assert (assoc (quote x) (quote ((y . 5) (x . 3) (z . 7)))) (quote (x . 3))) 105 | 106 | (define atom2 (lambda (x) 107 | (cond 108 | ((null? x) #t) 109 | ((atom? x) #t) 110 | (else #f)))) 111 | 112 | (define evcon (lambda (c a) 113 | (cond 114 | ((eval (caar c) a) (eval (cadar c) a)) 115 | (else (evcon (cdr c) a))))) 116 | 117 | (define evlis (lambda (m a) 118 | (cond 119 | ((null? m) #f) 120 | (else (cons (eval (car m) a) 121 | (evlis (cdr m) a)))))) 122 | 123 | (assert (evlis (quote ()) (quote ())) #f) 124 | 125 | (define apply (lambda (fun x a) 126 | (cond 127 | ((atom2 fun) 128 | (cond 129 | ((equal? fun (quote CAR)) (caar x)) 130 | ((equal? fun (quote CDR)) (cdar x)) 131 | ((equal? fun (quote CONS)) (cons (car x) (cadr x))) 132 | ((equal? fun (quote ATOM)) (atom2 (car x))) 133 | ((equal? fun (quote EQ)) (equal? (car x) (cadr x))) 134 | (else (apply (eval fun a) x a)))) 135 | 136 | ((equal? (car fun) (quote LAMBDA)) 137 | (eval (caddr fun) (pairlis (cadr fun) x a))) 138 | 139 | ((equal? (car fun) (quote LABEL)) 140 | (apply 141 | (caddr fun) 142 | x 143 | (cons 144 | (cons (cadr fun) (caddr fun)) 145 | a)))))) 146 | 147 | (define eval (lambda (e a) 148 | (cond 149 | ((atom2 e) (cdr (assoc e a))) 150 | ((atom2 (car e)) 151 | (cond 152 | ((equal? (car e) (quote QUOTE)) (cadr e)) 153 | ((equal? (car e) (quote COND)) (evcon (cdr e) a)) 154 | (else (apply (car e) (evlis (cdr e) a) a)))) 155 | (else (apply (car e) (evlis (cdr e) a) a))))) 156 | 157 | (define evalquote (lambda (fn x) (apply fn x (quote ())))) 158 | 159 | (assert (eval (quote Y) (quote ((X . 1) (Y . 2) (Z . 3)))) 2) 160 | 161 | (assert (eval (quote ((LAMBDA (X) (CAR X)) Z)) (quote ((NIL) (T . #t) (Z . (A B C))))) (quote A)) 162 | 163 | (assert (eval 164 | (quote ((LABEL MAPCAR 165 | (LAMBDA (FN SEQ) 166 | (COND 167 | ((EQ NIL SEQ) NIL) 168 | (T (CONS (FN (CAR SEQ)) 169 | (MAPCAR FN (CDR SEQ))))))) 170 | DUP 171 | LST)) 172 | (quote ((NIL . ()) 173 | (T . #t) 174 | (DUP . (LAMBDA (X) (CONS X X))) 175 | (LST . (A B C))))) 176 | (quote ((A . A) (B . B) (C . C)))) 177 | -------------------------------------------------------------------------------- /tests/true-tco.scm: -------------------------------------------------------------------------------- 1 | (define a (lambda (x) (b x))) 2 | (define b (lambda (x) (a x))) 3 | (a #t) 4 | --------------------------------------------------------------------------------