├── .gitmodules ├── paper └── recursive.pdf ├── tests ├── true-tco.scm ├── exp.scm ├── odin.scm ├── old.scm ├── lisp15.scm └── test.scm ├── .gitignore ├── ols.json ├── .vscode └── launch.json ├── Makefile ├── LICENSE ├── README.md ├── komplott.c └── komplodin.odin /.gitmodules: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /paper/recursive.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/krig/LISP/HEAD/paper/recursive.pdf -------------------------------------------------------------------------------- /tests/true-tco.scm: -------------------------------------------------------------------------------- 1 | (define a (lambda (x) (b x))) 2 | (define b (lambda (x) (a x))) 3 | (a #t) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | komplott 2 | komplott.opt 3 | komplodin 4 | .gdb_history 5 | *.dSYM/** 6 | .DS_Store 7 | -------------------------------------------------------------------------------- /ols.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://raw.githubusercontent.com/DanielGavin/ols/master/misc/ols.schema.json", 3 | "enable_document_symbols": true, 4 | "enable_hover": true, 5 | "enable_snippets": true 6 | } -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /.vscode/launch.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "0.2.0", 3 | "configurations": [ 4 | { 5 | "type": "lldb-dap", 6 | "request": "launch", 7 | "name": "Debug", 8 | "program": "${workspaceRoot}/komplodin", 9 | "args": ["tests/nums.scm"], 10 | "env": [], 11 | "cwd": "${workspaceRoot}" 12 | } 13 | ] 14 | } 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test clean loc 2 | 3 | all: komplott komplodin loc 4 | 5 | loc: 6 | wc -l komplott.c komplodin.odin tests/lisp15.scm 7 | 8 | komplott: komplott.c 9 | $(CC) -g -Og -Wall -Werror -std=c11 -o $@ komplott.c 10 | 11 | komplodin: komplodin.odin 12 | odin build komplodin.odin -file -debug -vet -strict-style -vet-unused 13 | 14 | test: komplott komplodin tests/test.scm tests/exp.scm tests/lisp15.scm 15 | @time -p ./komplott tests/test.scm 16 | ./komplott tests/lisp15.scm 17 | ./komplott tests/exp.scm 18 | @time -p ./komplodin tests/test.scm 19 | ./komplodin tests/lisp15.scm 20 | ./komplodin tests/exp.scm 21 | 22 | clean: 23 | rm -f ./komplott ./komplodin 24 | -------------------------------------------------------------------------------- /tests/odin.scm: -------------------------------------------------------------------------------- 1 | (define displayln (lambda (x) (display x) (newline))) 2 | 3 | (define assert (lambda (expr expect) 4 | (cond ((equal? expr expect) 5 | ((lambda () (display (quote pass:_)) (displayln expr)))) 6 | (else 7 | ((lambda () (display (quote fail:_)) (displayln expr))))))) 8 | 9 | (define length (lambda (l) (cond ((null? l) 0) (else (+ 1 (length (cdr l))))))) 10 | (assert (length (quote (1 2 3))) 3) 11 | 12 | (displayln (quote fac_15)) 13 | 14 | (define fac (lambda (n) 15 | (cond ((equal? n 0) 1) 16 | (else (* n (fac (- n 1))))))) 17 | 18 | (fac 15) 19 | (assert (fac 15) (quote 1307674368000)) 20 | 21 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # komplott / komplodin 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 | ## ! New in 2025! 13 | 14 | The LISP interpreter translated to [Odin](https://odin-lang.org) in 15 | `komplodin.odin`. More lines of code, but I am less familiar with the 16 | language and am translating directly from C, so there are probably ways 17 | to make it a cleaner solution. 18 | 19 | When I posted this to lobste.rs, gingerBill (creator of Odin) was kind 20 | enough to make a more direct translation of the C code into Odin, which 21 | can be viewed in this 22 | [gist: komplott.odin](https://gist.github.com/gingerBill/622bf4dd5208e12076213a41053259cb). 23 | 24 | Since the lobste.rs posting, I have tweaked the Odin version a bit more, 25 | and so it differs from the C version quite a bit in the implementation 26 | details. I've tried to keep the output and functionality of the two 27 | programs the same though. 28 | 29 | ## Features 30 | 31 | * Single file implementation. 32 | * Less than 500 lines of code (~600 lines for the Odin version) 33 | * Scheme-compliant enough for the test programs to be executable by 34 | GNU Guile (not sure if this is true anymore) 35 | * Copying semi-space garbage collector based on Cheney's Algorithm. 36 | 37 | For more details on how it works, Andy Wingo has a great post 38 | about this kind of garbage collector on 39 | [his blog (wingolog)](https://www.wingolog.org/archives/2022/12/10/a-simple-semi-space-collector). 40 | 41 | * Limited tail call optimization (not true TCO; see `tests/true-tco.scm`). 42 | * Near-zero error handling. 43 | * Zero thread safety or security. 44 | 45 | *Also includes:* 46 | 47 | ## `lisp15.scm` 48 | 49 | An implementation of the core of LISP 1.5 from 1962 50 | 51 | ## Instructions 52 | 53 | * To build the `komplott` executable, run `make komplott`. The only dependency 54 | aside from `make` is `gcc`. 55 | 56 | * To build the Odin version (`komplodin`), run `make komplodin`. This depends on 57 | the Odin compiler. 58 | 59 | * To run the LISP 1.5 interpreter and a couple of test cases, run `make test`. 60 | 61 | 62 | ## LISP 1.5 63 | 64 | The version presented in the README is slightly tweaked from the one 65 | that can be found in `tests/lisp15.scm` in order to more closely 66 | resemble early LISP rather than scheme: `#t` and `#f` are written as 67 | `t` and `nil`. 68 | 69 | ``` lisp 70 | 71 | (define pairlis (lambda (x y a) 72 | (cond ((null? x) a) 73 | (t (cons (cons (car x) (car y)) 74 | (pairlis (cdr x) (cdr y) a)))))) 75 | 76 | (define assoc (lambda (x a) 77 | (cond ((equal? (caar a) x) (car a)) 78 | (t (assoc x (cdr a)))))) 79 | 80 | (define atom? (lambda (x) 81 | (cond 82 | ((null? x) t) 83 | ((atom? x) t) 84 | (t nil)))) 85 | 86 | (define evcon (lambda (c a) 87 | (cond 88 | ((eval (caar c) a) (eval (cadar c) a)) 89 | (t (evcon (cdr c) a))))) 90 | 91 | (define evlis (lambda (m a) 92 | (cond 93 | ((null? m) nil) 94 | (t (cons (eval (car m) a) 95 | (evlis (cdr m) a)))))) 96 | 97 | (define apply (lambda (fun x a) 98 | (cond 99 | ((atom? fun) 100 | (cond 101 | ((equal? fun (quote CAR)) (caar x)) 102 | ((equal? fun (quote CDR)) (cdar x)) 103 | ((equal? fun (quote CONS)) (cons (car x) (cadr x))) 104 | ((equal? fun (quote ATOM)) (atom? (car x))) 105 | ((equal? fun (quote EQ)) (equal? (car x) (cadr x))) 106 | (t (apply (eval fun a) x a)))) 107 | 108 | ((equal? (car fun) (quote LAMBDA)) 109 | (eval (caddr fun) (pairlis (cadr fun) x a))) 110 | 111 | ((equal? (car fun) (quote LABEL)) 112 | (apply 113 | (caddr fun) 114 | x 115 | (cons 116 | (cons (cadr fun) (caddr fun)) 117 | a)))))) 118 | 119 | (define eval (lambda (e a) 120 | (cond 121 | ((atom? e) (cdr (assoc e a))) 122 | ((atom? (car e)) 123 | (cond 124 | ((equal? (car e) (quote QUOTE)) (cadr e)) 125 | ((equal? (car e) (quote COND)) (evcon (cdr e) a)) 126 | (t (apply (car e) (evlis (cdr e) a) a)))) 127 | (t (apply (car e) (evlis (cdr e) a) a))))) 128 | 129 | (define evalquote (lambda (fn x) (apply fn x (quote ())))) 130 | 131 | ``` 132 | 133 | Here is an example of actual LISP 1.5 code: 134 | 135 | ``` lisp 136 | ((LABEL MAPCAR 137 | (LAMBDA (FN SEQ) 138 | (COND 139 | ((EQ NIL SEQ) NIL) 140 | (T (CONS (FN (CAR SEQ)) 141 | (MAPCAR FN (CDR SEQ))))))) 142 | DUP LST) 143 | 144 | ; where 145 | ; DUP -> (LAMBDA (X) (CONS X X)) 146 | ; LST -> (A B C) 147 | ``` 148 | 149 | > To prevent reading from continuing indefinitely, each packet should end 150 | > with STOP followed by a large number of right parentheses. An unpaired right parenthesis 151 | > will cause a read error and terminate reading. 152 | 153 | `STOP )))))))))))))))))` 154 | -------------------------------------------------------------------------------- /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 | (displayln 100) 26 | (newline) 27 | 28 | (cond ((equal? 1 0) (displayln 100)) (else (displayln 200))) 29 | (cond ((equal? 1 1) (displayln 100)) (else (displayln 200))) 30 | 31 | (define assert (lambda (expr expect) 32 | (cond ((equal? expr expect) 33 | ((lambda () (display (quote pass:_)) (displayln expr)))) 34 | (else 35 | ((lambda () (display (quote fail:_)) (displayln expr))))))) 36 | 37 | (define sq (lambda (x) (* x x))) 38 | (assert (sq 3) 9) 39 | 40 | (define length (lambda (l) (cond ((null? l) 0) (else (+ 1 (length (cdr l))))))) 41 | (assert (length (quote (1 2 3))) 3) 42 | 43 | 44 | (displayln (quote fac_15)) 45 | 46 | (define fac (lambda (n) 47 | (cond ((equal? n 0) 1) 48 | (else (* n (fac (- n 1))))))) 49 | 50 | (fac 15) 51 | (assert (fac 15) (quote 1307674368000)) 52 | 53 | 54 | (displayln (quote two-in-a-row?)) 55 | 56 | (define member? (lambda (a lat) 57 | (cond 58 | ((null? lat) #f) 59 | ((equal? a (car lat)) #t) 60 | ((member? a (cdr lat)) #t) 61 | (else #f)))) 62 | 63 | (define is-first? (lambda (a lat) 64 | (cond 65 | ((null? lat) #f) 66 | (else (equal? (car lat) a))))) 67 | 68 | (define two-in-a-row? (lambda (lat) 69 | (cond 70 | ((null? lat) #f) 71 | ((is-first? (car lat) (cdr lat)) #t) 72 | ((two-in-a-row? (cdr lat)) #t) 73 | (else #f)))) 74 | 75 | (assert (two-in-a-row? (quote (Italian sardines spaghetti parsley))) #f) 76 | (assert (two-in-a-row? (quote (Italian sardines sardines spaghetti parsley))) #t) 77 | (assert (two-in-a-row? (quote (Italian sardines more sardines spaghetti))) #f) 78 | 79 | 80 | (displayln (quote sum-of-prefixes)) 81 | 82 | (define sum-of-prefixes-helper 83 | (lambda (sonssf tup) 84 | (cond 85 | ((null? tup) (quote ())) 86 | (else (cons (+ sonssf (car tup)) 87 | (sum-of-prefixes-helper 88 | (+ sonssf (car tup)) 89 | (cdr tup))))))) 90 | 91 | (define sum-of-prefixes (lambda (tup) (sum-of-prefixes-helper 0 tup))) 92 | 93 | (assert (sum-of-prefixes (quote (1 1 1))) (quote (1 2 3))) 94 | (assert (sum-of-prefixes (quote (1 1 1 1 1))) (quote (1 2 3 4 5))) 95 | (assert (sum-of-prefixes (quote (2 1 9 17 0))) (quote (2 3 12 29 29))) 96 | 97 | 98 | (displayln (quote lisp-in-lisp)) 99 | 100 | (define pairlis (lambda (x y a) 101 | (cond ((null? x) a) 102 | (else (cons (cons (car x) (car y)) 103 | (pairlis (cdr x) (cdr y) a)))))) 104 | 105 | (define assoc (lambda (x a) 106 | (cond ((equal? (caar a) x) (car a)) 107 | (else (assoc x (cdr a)))))) 108 | 109 | (assert (pairlis (quote (a b c)) (quote (1 2 3)) (quote ())) (quote ((a . 1) (b . 2) (c . 3)))) 110 | (assert (assoc (quote x) (quote ((y . 5) (x . 3) (z . 7)))) (quote (x . 3))) 111 | 112 | (define atom2 (lambda (x) 113 | (cond 114 | ((null? x) #t) 115 | ((atom? x) #t) 116 | (else #f)))) 117 | 118 | (define evcon (lambda (c a) 119 | (cond 120 | ((eval (caar c) a) (eval (cadar c) a)) 121 | (else (evcon (cdr c) a))))) 122 | 123 | (define evlis (lambda (m a) 124 | (cond 125 | ((null? m) #f) 126 | (else (cons (eval (car m) a) 127 | (evlis (cdr m) a)))))) 128 | 129 | (assert (evlis (quote ()) (quote ())) #f) 130 | 131 | (define apply (lambda (fun x a) 132 | (cond 133 | ((atom2 fun) 134 | (cond 135 | ((equal? fun (quote CAR)) (caar x)) 136 | ((equal? fun (quote CDR)) (cdar x)) 137 | ((equal? fun (quote CONS)) (cons (car x) (cadr x))) 138 | ((equal? fun (quote ATOM)) (atom2 (car x))) 139 | ((equal? fun (quote EQ)) (equal? (car x) (cadr x))) 140 | (else (apply (eval fun a) x a)))) 141 | 142 | ((equal? (car fun) (quote LAMBDA)) 143 | (eval (caddr fun) (pairlis (cadr fun) x a))) 144 | 145 | ((equal? (car fun) (quote LABEL)) 146 | (apply 147 | (caddr fun) 148 | x 149 | (cons 150 | (cons (cadr fun) (caddr fun)) 151 | a)))))) 152 | 153 | (define eval (lambda (e a) 154 | (cond 155 | ((atom2 e) (cdr (assoc e a))) 156 | ((atom2 (car e)) 157 | (cond 158 | ((equal? (car e) (quote QUOTE)) (cadr e)) 159 | ((equal? (car e) (quote COND)) (evcon (cdr e) a)) 160 | (else (apply (car e) (evlis (cdr e) a) a)))) 161 | (else (apply (car e) (evlis (cdr e) a) a))))) 162 | 163 | (define evalquote (lambda (fn x) (apply fn x (quote ())))) 164 | 165 | (assert (eval (quote Y) (quote ((X . 1) (Y . 2) (Z . 3)))) 2) 166 | 167 | (assert (eval (quote ((LAMBDA (X) (CAR X)) Z)) (quote ((NIL) (T . #t) (Z . (A B C))))) (quote A)) 168 | 169 | (assert (eval 170 | (quote ((LABEL MAPCAR 171 | (LAMBDA (FN SEQ) 172 | (COND 173 | ((EQ NIL SEQ) NIL) 174 | (T (CONS (FN (CAR SEQ)) 175 | (MAPCAR FN (CDR SEQ))))))) 176 | DUP 177 | LST)) 178 | (quote ((NIL . ()) 179 | (T . #t) 180 | (DUP . (LAMBDA (X) (CONS X X))) 181 | (LST . (A B C))))) 182 | (quote ((A . A) (B . B) (C . C)))) 183 | -------------------------------------------------------------------------------- /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; 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_atom(const char *str) { 86 | return gc_alloc(T_ATOM, (object *)intern_string(str), NULL); 87 | } 88 | 89 | object *new_cons(object *car, object *cdr) { 90 | gc_protect(&car, &cdr, NULL); 91 | object *ret = gc_alloc(T_CONS, car, cdr); 92 | gc_pop(); 93 | return ret; 94 | } 95 | 96 | const char *read_token(FILE *in) { 97 | int n = 0; 98 | while (isspace(token_peek)) 99 | token_peek = fgetc(in); 100 | if (token_peek == '(' || token_peek == ')') { 101 | token_text[n++] = token_peek; 102 | token_peek = fgetc(in); 103 | } else while (ATOMCHAR(token_peek)) { 104 | if (n == TOKEN_MAX) 105 | abort(); 106 | token_text[n++] = token_peek; 107 | token_peek = fgetc(in); 108 | } 109 | if (token_peek == EOF) 110 | exit(0); 111 | token_text[n] = '\0'; 112 | return intern_string(token_text); 113 | } 114 | 115 | object *lisp_read_obj(const char *tok, FILE *in) { 116 | return (tok[0] != '(') ? new_atom(tok) : 117 | lisp_read_list(read_token(in), in); 118 | } 119 | 120 | object *lisp_read_list(const char *tok, FILE *in) { 121 | if (tok[0] == ')') 122 | return NULL; 123 | object *obj = NULL, *tmp = NULL, *obj2 = NULL; 124 | gc_protect(&obj, &tmp, &obj2, NULL); 125 | obj = lisp_read_obj(tok, in); 126 | tok = read_token(in); 127 | if (tok[0] == '.' && tok[1] == '\0') { 128 | tok = read_token(in); 129 | tmp = lisp_read_obj(tok, in); 130 | obj2 = new_cons(obj, tmp); 131 | tok = read_token(in); 132 | gc_pop(); 133 | if (tok[0] == ')') 134 | return obj2; 135 | fputs("Error: Malformed dotted cons\n", stderr); 136 | return NULL; 137 | } 138 | tmp = lisp_read_list(tok, in); 139 | obj2 = new_cons(obj, tmp); 140 | gc_pop(); 141 | return obj2; 142 | } 143 | 144 | object *lisp_read(FILE *in) { 145 | const char *tok = read_token(in); 146 | if (tok == NULL) 147 | return NULL; 148 | if (tok[0] != ')') 149 | return lisp_read_obj(tok, in); 150 | fputs("Error: Unexpected )\n", stderr); 151 | return NULL; 152 | } 153 | 154 | int lisp_equal(object *a, object *b) { 155 | if (a == b) 156 | return 1; 157 | if (a == NULL || b == NULL || a->tag != b->tag) 158 | return 0; 159 | if (a->tag != T_CONS) 160 | return a->car == b->car; 161 | return lisp_equal(a->car, b->car) && lisp_equal(a->cdr, b->cdr); 162 | } 163 | 164 | object *env_lookup(object *needle, object *haystack) { 165 | for (object* cur = haystack; cur != NULL; cur = cur->cdr) { 166 | for (object *item = cur->car; item != NULL; item = item->cdr) { 167 | if (item->car != NULL && lisp_equal(needle, item->car->car)) { 168 | return item->car->cdr; 169 | } 170 | } 171 | } 172 | return NULL; 173 | } 174 | 175 | object *env_set(object *env, object *key, object *value) { 176 | object *pair = NULL, *frame = NULL; 177 | gc_protect(&env, &key, &value, &pair, &frame, NULL); 178 | pair = new_cons(key, value); 179 | frame = new_cons(pair, env->car); 180 | env->car = frame; 181 | gc_pop(); 182 | return env; 183 | } 184 | 185 | object *list_reverse(object *lst) { 186 | if (lst == NULL) 187 | return NULL; 188 | object *prev = NULL, *curr = lst, *next = lst->cdr; 189 | while (curr) { 190 | curr->cdr = prev; 191 | prev = curr; 192 | curr = next; 193 | if (next != NULL) 194 | next = next->cdr; 195 | } 196 | return prev; 197 | } 198 | 199 | object *lisp_eval(object *expr, object *env) { 200 | restart: 201 | if (expr == NULL) 202 | return expr; 203 | if (expr->tag == T_ATOM) 204 | return match_number(TEXT(expr)) ? expr : env_lookup(expr, env); 205 | if (expr->tag != T_CONS) 206 | return expr; 207 | object *head = expr->car; 208 | if (TEXT(head) == TQUOTE) { 209 | return expr->cdr->car; 210 | } else if (TEXT(head) == TCOND) { 211 | object *item = NULL, *cond = NULL; 212 | gc_protect(&expr, &env, &item, &cond, NULL); 213 | for (item = expr->cdr; item != NULL; item = item->cdr) { 214 | cond = item->car; 215 | if (lisp_eval(cond->car, env) != NULL) { 216 | expr = cond->cdr->car; 217 | gc_pop(); 218 | goto restart; 219 | } 220 | } 221 | return NULL; // was abort(), but no match should return nil 222 | } else if (TEXT(head) == TDEFINE) { 223 | object *name = NULL, *value = NULL; 224 | gc_protect(&env, &name, &value, NULL); 225 | name = expr->cdr->car; 226 | value = lisp_eval(expr->cdr->cdr->car, env); 227 | env_set(env, name, value); 228 | gc_pop(); 229 | return value; 230 | } else if (TEXT(head) == TLAMBDA) { 231 | expr->cdr->tag = T_LAMBDA; 232 | return expr->cdr; 233 | } 234 | 235 | object *fn = NULL, *args = NULL, *params = NULL, *param = NULL; 236 | gc_protect(&expr, &env, &fn, &args, ¶ms, ¶m, NULL); 237 | fn = lisp_eval(head, env); 238 | if (fn->tag == T_CFUNC) { 239 | for (params = expr->cdr; params != NULL; params = params->cdr) { 240 | param = lisp_eval(params->car, env); 241 | args = new_cons(param, args); 242 | } 243 | object *ret = ((cfunc)fn->car)(list_reverse(args)); 244 | gc_pop(); 245 | return ret; 246 | } else if (fn->tag == T_LAMBDA) { 247 | object *callenv = new_cons(NULL, env); 248 | args = fn->car; 249 | object *item = NULL; 250 | gc_protect(&callenv, &item, NULL); 251 | for (params = expr->cdr; params != NULL; params = params->cdr, args = args->cdr) { 252 | param = lisp_eval(params->car, env); 253 | env_set(callenv, args->car, param); 254 | } 255 | for (item = fn->cdr; item != NULL; item = item->cdr) { 256 | if (item->cdr == NULL) { 257 | expr = item->car; 258 | env = callenv; 259 | gc_pop(); 260 | gc_pop(); 261 | goto restart; 262 | } 263 | lisp_eval(item->car, callenv); 264 | } 265 | gc_pop(); 266 | gc_pop(); 267 | } 268 | return NULL; 269 | } 270 | 271 | void lisp_print(object *obj) { 272 | if (obj == NULL) { 273 | fputs("()", stdout); 274 | } else if (obj->tag == T_ATOM) { 275 | fputs(TEXT(obj), stdout); 276 | } else if (obj->tag == T_CFUNC) { 277 | printf("", (void *)obj); 278 | } else if (obj->tag == T_LAMBDA) { 279 | fputs("car); 281 | fputs(" ", stdout); 282 | lisp_print(obj->cdr); 283 | fputs(">", stdout); 284 | } else if (obj->tag == T_CONS) { 285 | fputs("(", stdout); 286 | for (;;) { 287 | lisp_print(obj->car); 288 | if (obj->cdr == NULL) 289 | break; 290 | fputs(" ", stdout); 291 | if (obj->cdr->tag != T_CONS) { 292 | fputs(". ", stdout); 293 | lisp_print(obj->cdr); 294 | break; 295 | } 296 | obj = obj->cdr; 297 | } 298 | fputs(")", stdout); 299 | } 300 | } 301 | 302 | object *builtin_car(object *args) { 303 | return args->car->car; 304 | } 305 | 306 | object *builtin_cdr(object *args) { 307 | return args->car->cdr; 308 | } 309 | 310 | object *builtin_cons(object *args) { 311 | return new_cons(args->car, args->cdr->car); 312 | } 313 | 314 | object *builtin_equal(object *args) { 315 | object *cmp = args->car; 316 | for (args = args->cdr; args != NULL; args = args->cdr) 317 | if (!lisp_equal(cmp, args->car)) 318 | return NULL; 319 | return atom_t; 320 | } 321 | 322 | object *builtin_pair(object *args) { 323 | return (args->car != NULL && args->car->tag == T_CONS) ? atom_t : NULL; 324 | } 325 | 326 | object *builtin_null(object *args) { 327 | return (args->car == NULL) ? atom_t : NULL; 328 | } 329 | 330 | object *builtin_sum(object *args) { 331 | long sum = 0; 332 | for (; args != NULL; args = args->cdr) 333 | sum += atol(TEXT(args->car)); 334 | return new_atom(itos(sum)); 335 | } 336 | 337 | object *builtin_sub(object *args) { 338 | long n; 339 | if (args->cdr == NULL) { 340 | n = -atol(TEXT(args->car)); 341 | } else { 342 | n = atol(TEXT(args->car)); 343 | for (args = args->cdr; args != NULL; args = args->cdr) 344 | n = n - atol(TEXT(args->car)); 345 | } 346 | return new_atom(itos(n)); 347 | } 348 | 349 | object *builtin_mul(object *args) { 350 | long sum = 1; 351 | for (; args != NULL; args = args->cdr) 352 | sum *= atol(TEXT(args->car)); 353 | return new_atom(itos(sum)); 354 | } 355 | 356 | object *builtin_display(object *args) { 357 | lisp_print(args->car); 358 | return NULL; 359 | } 360 | 361 | object *builtin_newline(object *args) { 362 | puts(""); 363 | return NULL; 364 | } 365 | 366 | object *builtin_read(object *args) { 367 | return lisp_read(stdin); 368 | } 369 | 370 | void defun(object *env, const char *name, cfunc fn) { 371 | object *key = NULL, *val = NULL; 372 | gc_protect(&env, &key, &val, NULL); 373 | key = new_atom(name); 374 | val = gc_alloc(T_CFUNC, (object *)fn, NULL); 375 | env_set(env, key, val); 376 | gc_pop(); 377 | } 378 | 379 | void gc_copy(object **root) { 380 | if (*root == NULL) 381 | return; 382 | if ((*root)->car == &fwdmarker) { 383 | *root = (*root)->cdr; 384 | } else if (*root < fromspace || *root >= (fromspace + HEAPSIZE)) { 385 | object *p = allocptr++; 386 | memcpy(p, *root, sizeof(object)); 387 | (*root)->car = &fwdmarker; 388 | (*root)->cdr = p; 389 | *root = p; 390 | } 391 | } 392 | 393 | void gc_collect(void) { 394 | object *tmp = fromspace; 395 | fromspace = tospace; 396 | tospace = tmp; 397 | allocptr = fromspace; 398 | 399 | for (size_t i = 0; i < numroots; ++i) 400 | gc_copy(roots[i]); 401 | 402 | for (object* scanptr = fromspace; scanptr < allocptr; ++scanptr) 403 | if (scanptr->tag == T_CONS || scanptr->tag == T_LAMBDA) { 404 | gc_copy(&(scanptr->car)); 405 | gc_copy(&(scanptr->cdr)); 406 | } 407 | } 408 | 409 | void gc_init(void) { 410 | allocptr = fromspace = heap = malloc(sizeof(object) * HEAPSIZE * 2); 411 | tospace = heap + HEAPSIZE; 412 | numroots = roottop = 0; 413 | } 414 | 415 | object *gc_alloc(object_tag tag, object *car, object *cdr) { 416 | if (allocptr + 1 > fromspace + HEAPSIZE) { 417 | if (tag == T_CONS) 418 | gc_protect(&car, &cdr, NULL); 419 | gc_collect(); 420 | if (tag == T_CONS) 421 | gc_pop(); 422 | } 423 | if (allocptr + 1 > fromspace + HEAPSIZE) { 424 | fputs("Out of memory\n", stderr); 425 | abort(); 426 | } 427 | allocptr->tag = tag; 428 | allocptr->car = car; 429 | allocptr->cdr = cdr; 430 | return allocptr++; 431 | } 432 | 433 | void gc_protect(object **r, ...) { 434 | va_list args; 435 | rootstack[roottop++] = numroots; 436 | va_start(args, r); 437 | for (object **p = r; p != NULL; p = va_arg(args, object **)) { 438 | roots[numroots++] = p; 439 | } 440 | va_end(args); 441 | } 442 | 443 | void gc_pop(void) { 444 | numroots = rootstack[--roottop]; 445 | } 446 | 447 | int main(int argc, char* argv[]) { 448 | gc_init(); 449 | TQUOTE = intern_string("quote"); 450 | TLAMBDA = intern_string("lambda"); 451 | TCOND = intern_string("cond"); 452 | TDEFINE = intern_string("define"); 453 | memset(token_text, 0, TOKEN_MAX); 454 | token_peek = ' '; 455 | 456 | object *env = NULL, *atom_f = NULL, *obj = NULL; 457 | gc_protect(&env, &atom_t, &atom_f, &obj, NULL); 458 | env = new_cons(NULL, NULL); 459 | atom_t = new_atom("#t"); 460 | atom_f = new_atom("#f"); 461 | env_set(env, atom_t, atom_t); 462 | env_set(env, atom_f, NULL); 463 | defun(env, "car", &builtin_car); 464 | defun(env, "cdr", &builtin_cdr); 465 | defun(env, "cons", &builtin_cons); 466 | defun(env, "equal?", &builtin_equal); 467 | defun(env, "pair?", &builtin_pair); 468 | defun(env, "null?", &builtin_null); 469 | defun(env, "+", &builtin_sum); 470 | defun(env, "-", &builtin_sub); 471 | defun(env, "*", &builtin_mul); 472 | defun(env, "display", &builtin_display); 473 | defun(env, "newline", &builtin_newline); 474 | defun(env, "read", &builtin_read); 475 | FILE *in = (argc > 1) ? fopen(argv[1], "r") : stdin; 476 | for (;;) { 477 | obj = lisp_read(in); 478 | obj = lisp_eval(obj, env); 479 | lisp_print(obj); 480 | puts(""); 481 | } 482 | return 0; 483 | } 484 | -------------------------------------------------------------------------------- /komplodin.odin: -------------------------------------------------------------------------------- 1 | package komplodin 2 | 3 | import "base:runtime" 4 | import "core:bufio" 5 | import "core:fmt" 6 | import "core:io" 7 | import "core:mem" 8 | import os "core:os/os2" 9 | import "core:strconv" 10 | import "core:strings" 11 | import "core:unicode" 12 | import "core:unicode/utf8" 13 | 14 | HEAP_SIZE :: 16 * mem.Kilobyte 15 | MAX_ROOTS :: 500 16 | MAX_FRAMES :: 50 17 | 18 | Cons :: struct { car, cdr: ^Cons } 19 | Tag :: enum u8 { Cell, Fwd, Builtin, Lambda, Symbol, Int } 20 | Builtin :: #type proc(^Cons) -> ^Cons 21 | 22 | TQUOTE, TLAMBDA, TCOND, TDEFINE: string 23 | atom_t, atom_f, tospace, fromspace, allocptr: ^Cons 24 | heap: []Cons 25 | roots: [MAX_ROOTS]^^Cons 26 | rootstack: [MAX_FRAMES]uint 27 | roottop, numroots: uint 28 | interned: strings.Intern 29 | lisp_reader: bufio.Reader 30 | 31 | intern_string :: proc(s: string) -> string { 32 | r, err := strings.intern_get(&interned, s) 33 | if err != nil { 34 | os.print_error(os.stderr, err, "intern_string") 35 | runtime.trap() 36 | } 37 | return r 38 | } 39 | 40 | cons_tag :: proc(cons: ^Cons) -> Tag { return Tag(uintptr(cons.car) & 0x7) } 41 | tagged_cell :: proc(tag: Tag, data: uintptr) -> Cons { return Cons{(^Cons)(uintptr(tag)), (^Cons)(data)} } 42 | symbol_cell :: proc(ln: u32, s: [^]u8) -> Cons { return Cons{(^Cons)((uintptr(ln) << 32) | uintptr(Tag.Symbol)), (^Cons)(rawptr(s))} } 43 | atom_text :: proc(atom: ^Cons) -> string { return strings.string_from_ptr(([^]u8)(rawptr(atom.cdr)), int(u32(uintptr(atom.car) >> 32))) } 44 | 45 | new_atom :: proc(s: string) -> (ret: ^Cons) { 46 | ret = gc_alloc() 47 | if match_number(s) { 48 | ret^ = tagged_cell(.Int, uintptr(strconv.atoi(s))) 49 | } else { 50 | is := intern_string(s) 51 | ret^ = symbol_cell(u32(len(is)), raw_data(is)) 52 | } 53 | return 54 | } 55 | 56 | new_number :: proc(n: int) -> (ret: ^Cons) { 57 | ret = gc_alloc() 58 | ret^ = tagged_cell(.Int, uintptr(n)) 59 | return 60 | } 61 | 62 | new_cons :: proc(car, cdr: ^Cons) -> ^Cons { 63 | car, cdr := car, cdr 64 | gc_protect(&car, &cdr) 65 | defer gc_pop() 66 | ret := gc_alloc() 67 | ret^ = Cons{car, cdr} 68 | return ret 69 | } 70 | 71 | env_set :: proc(env, key, value: ^Cons) -> ^Cons { 72 | env, key, value := env, key, value 73 | gc_protect(&env, &key, &value) 74 | defer gc_pop() 75 | pair := new_cons(key, value) 76 | frame := new_cons(pair, env.car) 77 | env^ = Cons{frame, env.cdr} 78 | return env 79 | } 80 | 81 | env_lookup :: proc(needle, haystack: ^Cons) -> ^Cons { 82 | for cur := haystack; cur != nil; cur = cur.cdr { 83 | for item := cur.car; item != nil; item = item.cdr { 84 | if item.car != nil && lisp_equal(needle, item.car.car) { 85 | return item.car.cdr 86 | } 87 | } 88 | } 89 | return nil 90 | } 91 | 92 | gc_copy :: proc(root: ^^Cons) { 93 | if root^ == nil { 94 | return 95 | } else if cons_tag(root^) == .Fwd { 96 | root^ = (root^).cdr 97 | } else if uintptr(root^) >= uintptr(tospace) && \ 98 | uintptr(root^) < uintptr(tospace) + HEAP_SIZE*size_of(Cons) { 99 | p := allocptr 100 | allocptr = mem.ptr_offset(allocptr, 1) 101 | mem.copy_non_overlapping(p, root^, size_of(Cons)) 102 | root^^ = Cons{(^Cons)(uintptr(Tag.Fwd)), p} 103 | root^ = p 104 | } 105 | } 106 | 107 | gc_collect :: proc() { 108 | if !gc_full() { return } 109 | fromspace, tospace = tospace, fromspace 110 | allocptr = fromspace 111 | for i :uint = 0; i < numroots; i += 1 { gc_copy(roots[i]) } 112 | for scanptr := fromspace; scanptr < allocptr; scanptr = mem.ptr_offset(scanptr, 1) { 113 | #partial switch cons_tag(scanptr) { 114 | case .Cell: 115 | gc_copy(&(scanptr.car)) 116 | gc_copy(&(scanptr.cdr)) 117 | case .Lambda: 118 | gc_copy(&(scanptr.cdr)) 119 | } 120 | } 121 | if gc_full() { 122 | fmt.eprintln("Out of memory") 123 | runtime.trap() 124 | } 125 | } 126 | 127 | gc_full :: proc() -> bool { 128 | next_alloc_pos := uintptr(allocptr) + size_of(^Cons) 129 | space_end := uintptr(fromspace) + HEAP_SIZE * size_of(^Cons) 130 | return next_alloc_pos >= space_end 131 | } 132 | 133 | gc_alloc :: proc() -> (ret: ^Cons) { 134 | gc_collect() 135 | ret, allocptr = allocptr, mem.ptr_offset(allocptr, 1) 136 | return 137 | } 138 | 139 | gc_protect :: proc(ptrs: ..^^Cons) { 140 | rootstack[roottop] = numroots 141 | roottop += 1 142 | for p in ptrs { 143 | roots[numroots] = p 144 | numroots += 1 145 | } 146 | } 147 | 148 | gc_pop :: proc() { 149 | roottop -= 1 150 | numroots = rootstack[roottop] 151 | } 152 | 153 | lisp_equal :: proc(a, b: ^Cons) -> bool { 154 | if a == b { return true } 155 | if a != nil && b != nil && cons_tag(a) == cons_tag(b) { 156 | #partial switch cons_tag(a) { 157 | case .Cell: 158 | return lisp_equal(a.car, b.car) && lisp_equal(a.cdr, b.cdr) 159 | case .Symbol: 160 | return uintptr(a.car) == uintptr(b.car) && rawptr(a.cdr) == rawptr(b.cdr) 161 | case .Int: 162 | return int(uintptr(a.cdr)) == int(uintptr(b.cdr)) 163 | case .Builtin: 164 | return rawptr(a.cdr) == rawptr(b.cdr) 165 | case .Lambda: 166 | return lisp_equal(a.cdr, b.cdr) 167 | } 168 | } 169 | return false 170 | } 171 | 172 | builtin_car :: proc(args: ^Cons) -> ^Cons { return args.car.car } 173 | builtin_cdr :: proc(args: ^Cons) -> ^Cons { return args.car.cdr } 174 | builtin_cons :: proc(args: ^Cons) -> ^Cons { return new_cons(args.car, args.cdr.car) } 175 | 176 | builtin_equal :: proc(args: ^Cons) -> ^Cons { 177 | args, cmp := args, args.car 178 | for args = args.cdr; args != nil; args = args.cdr { 179 | if !lisp_equal(cmp, args.car) { 180 | return nil 181 | } 182 | } 183 | return atom_t 184 | } 185 | 186 | builtin_pair :: proc(args: ^Cons) -> ^Cons { 187 | return atom_t if args.car != nil && cons_tag(args.car) == .Cell else nil 188 | } 189 | 190 | builtin_null :: proc(args: ^Cons) -> ^Cons { 191 | return atom_t if args.car == nil else nil 192 | } 193 | 194 | builtin_sum :: proc(args: ^Cons) -> ^Cons { 195 | sum :int = 0 196 | for i := args; i != nil; i = i.cdr { 197 | sum += int(uintptr(i.car.cdr)) 198 | } 199 | return new_number(sum) 200 | } 201 | 202 | builtin_sub :: proc(args: ^Cons) -> ^Cons { 203 | sum := int(uintptr(args.car.cdr)) 204 | if args.cdr == nil { 205 | sum = -sum 206 | } else { 207 | for i := args.cdr; i != nil; i = i.cdr { 208 | sum -= int(uintptr(i.car.cdr)) 209 | } 210 | } 211 | return new_number(sum) 212 | } 213 | 214 | builtin_mul :: proc(args: ^Cons) -> ^Cons { 215 | sum :int = 1 216 | for cur := args; cur != nil; cur = cur.cdr { 217 | sum *= int(uintptr(cur.car.cdr)) 218 | } 219 | return new_number(sum) 220 | } 221 | 222 | builtin_display :: proc(args: ^Cons) -> ^Cons { 223 | lisp_print(args.car) 224 | return nil 225 | } 226 | 227 | builtin_newline :: proc(args: ^Cons) -> ^Cons { 228 | fmt.println("") 229 | return nil 230 | } 231 | 232 | builtin_read :: proc(args: ^Cons) -> ^Cons { 233 | obj, err := lisp_read() 234 | if err != nil { 235 | fmt.eprintfln("Error: %v", err) 236 | return nil 237 | } 238 | return obj 239 | } 240 | 241 | BUILTINS :: []struct { name: string, impl: Builtin } { 242 | { "car", builtin_car }, 243 | { "cdr", builtin_cdr }, 244 | { "cons", builtin_cons }, 245 | { "equal?", builtin_equal }, 246 | { "pair?", builtin_pair }, 247 | { "null?", builtin_null }, 248 | { "+", builtin_sum }, 249 | { "-", builtin_sub }, 250 | { "*", builtin_mul }, 251 | { "display", builtin_display }, 252 | { "newline", builtin_newline }, 253 | { "read", builtin_read }, 254 | } 255 | 256 | define_builtins :: proc(env: ^Cons) { 257 | key, val: ^Cons 258 | env := env 259 | gc_protect(&key, &val, &env) 260 | defer gc_pop() 261 | 262 | for def in BUILTINS { 263 | key, val = new_atom(def.name), gc_alloc() 264 | val^ = tagged_cell(.Builtin, uintptr(rawptr(def.impl))) 265 | env_set(env, key, val) 266 | } 267 | } 268 | 269 | token_peek: rune = ' ' 270 | token_builder: strings.Builder 271 | 272 | read_rune :: proc() -> (ret: rune, err: io.Error) { 273 | r, _ := bufio.reader_read_rune(&lisp_reader) or_return 274 | ret = r 275 | return 276 | } 277 | 278 | is_atomchar :: proc(r: rune) -> bool { 279 | return (u32(r) >= '!' && u32(r) <= '\'') || 280 | (u32(r) >= '*' && u32(r) <= '~') || 281 | unicode.is_alpha(r) 282 | } 283 | 284 | match_number :: proc(s: string) -> bool { 285 | start := 1 if len(s) > 1 && (s[0] == '+' || s[0] == '-') else 0 286 | for ch in s[start:] { 287 | if !unicode.is_digit(ch) { 288 | return false 289 | } 290 | } 291 | return true 292 | } 293 | 294 | read_token :: proc() -> (tok: string, err: io.Error) { 295 | strings.builder_reset(&token_builder) 296 | for unicode.is_space(token_peek) { 297 | token_peek = read_rune() or_return 298 | } 299 | if token_peek == '(' || token_peek == ')' { 300 | strings.write_rune(&token_builder, token_peek) 301 | token_peek = read_rune() or_return 302 | } else { 303 | for is_atomchar(token_peek) { 304 | strings.write_rune(&token_builder, token_peek) 305 | token_peek = read_rune() or_return 306 | if strings.builder_len(token_builder) > 256 { 307 | return "", .EOF 308 | } 309 | } 310 | } 311 | if token_peek == utf8.RUNE_ERROR { 312 | return "", .EOF 313 | } 314 | tok = intern_string(strings.to_string(token_builder)) 315 | return 316 | } 317 | 318 | lisp_read_obj :: proc(tok: string) -> (obj: ^Cons, err: io.Error) { 319 | if tok[0] != '(' { 320 | obj = new_atom(tok) 321 | } else { 322 | next := read_token() or_return 323 | obj = lisp_read_list(next) or_return 324 | } 325 | return 326 | } 327 | 328 | lisp_read_list :: proc(tok: string) -> (ret: ^Cons, err: io.Error) { 329 | tok := tok 330 | if tok[0] == ')' { 331 | ret = nil 332 | return 333 | } 334 | obj, obj2, tmp: ^Cons 335 | gc_protect(&obj, &obj2, &tmp) 336 | defer gc_pop() 337 | obj = lisp_read_obj(tok) or_return 338 | tok = read_token() or_return 339 | if len(tok) == 1 && tok[0] == '.' { 340 | tok = read_token() or_return 341 | tmp = lisp_read_obj(tok) or_return 342 | obj2 = new_cons(obj, tmp) 343 | tok = read_token() or_return 344 | if tok[0] == ')' { 345 | ret = obj2 346 | return 347 | } 348 | fmt.eprintln("Error: Malformed dotted cons") 349 | return nil, .Unknown 350 | } 351 | tmp = lisp_read_list(tok) or_return 352 | ret = new_cons(obj, tmp) 353 | return 354 | } 355 | 356 | lisp_read :: proc() -> (obj: ^Cons, err: io.Error) { 357 | tok := read_token() or_return 358 | if len(tok) == 0 { 359 | obj = nil 360 | return 361 | } 362 | if tok[0] != ')' { 363 | return lisp_read_obj(tok) 364 | } 365 | fmt.eprintln("Error: unexpected )") 366 | return nil, .Unknown 367 | } 368 | 369 | list_reverse :: proc(lst: ^Cons) -> ^Cons { 370 | if lst == nil { 371 | return nil 372 | } 373 | curr, prev, next: ^Cons = lst, nil, lst.cdr 374 | for curr != nil { 375 | curr.cdr = prev 376 | prev, curr = curr, next 377 | if next != nil { 378 | next = next.cdr 379 | } 380 | } 381 | return prev 382 | } 383 | 384 | lisp_eval :: proc(expr, env: ^Cons) -> ^Cons { 385 | expr, env := expr, env 386 | restart: for { 387 | if expr == nil { 388 | return expr 389 | } 390 | tag := cons_tag(expr) 391 | if tag == .Int { 392 | return expr 393 | } else if tag == .Symbol { 394 | return env_lookup(expr, env) 395 | } else if tag != .Cell { 396 | return expr 397 | } 398 | 399 | head := expr.car 400 | symbol := atom_text(head) 401 | if symbol == TQUOTE { 402 | return expr.cdr.car 403 | } else if symbol == TCOND { 404 | item, cond: ^Cons 405 | gc_protect(&expr, &env, &item, &cond) 406 | defer gc_pop() 407 | for item = expr.cdr; item != nil; item = item.cdr { 408 | cond = item.car 409 | if lisp_eval(cond.car, env) != nil { 410 | expr = cond.cdr.car 411 | continue restart 412 | } 413 | } 414 | return nil 415 | } else if symbol == TDEFINE { 416 | name, value: ^Cons 417 | gc_protect(&expr, &env, &name, &value) 418 | defer gc_pop() 419 | name = expr.cdr.car 420 | value = lisp_eval(expr.cdr.cdr.car, env) 421 | env_set(env, name, value) 422 | return value 423 | } else if symbol == TLAMBDA { 424 | lamb: ^Cons 425 | gc_protect(&expr, &env, &lamb) 426 | defer gc_pop() 427 | lamb = gc_alloc() 428 | lamb^ = Cons{ 429 | (^Cons)(uintptr(Tag.Lambda)), 430 | expr.cdr, 431 | } 432 | return lamb 433 | } 434 | 435 | 436 | fn := lisp_eval(head, env) 437 | gc_protect(&expr, &env, &fn) 438 | defer gc_pop() 439 | funtag := cons_tag(fn) 440 | if funtag == .Builtin { 441 | args, params, param: ^Cons 442 | gc_protect(&args, ¶ms, ¶m) 443 | defer gc_pop() 444 | for params = expr.cdr; params != nil; params = params.cdr { 445 | param = lisp_eval(params.car, env) 446 | args = new_cons(param, args) 447 | } 448 | return ((Builtin)(rawptr(fn.cdr)))(list_reverse(args)) 449 | } else if funtag == .Lambda { 450 | args, callenv, params, param, item: ^Cons 451 | args, item = fn.cdr.car, fn.cdr.cdr 452 | gc_protect(&args, &callenv, ¶ms, ¶m, &item) 453 | defer gc_pop() 454 | callenv = new_cons(nil, env) 455 | for params = expr.cdr; params != nil; { 456 | param = lisp_eval(params.car, env) 457 | env_set(callenv, args.car, param) 458 | 459 | params = params.cdr 460 | args = args.cdr 461 | } 462 | for ; item != nil; item = item.cdr { 463 | if item.cdr == nil { 464 | expr, env = item.car, callenv 465 | continue restart 466 | } 467 | lisp_eval(item.car, callenv) 468 | } 469 | } 470 | return nil 471 | } 472 | } 473 | 474 | lisp_print :: proc(obj: ^Cons) { 475 | obj := obj 476 | if obj == nil { 477 | fmt.print("()") 478 | return 479 | } 480 | inlist := false 481 | outer: for { 482 | tag := cons_tag(obj) 483 | switch tag { 484 | case .Fwd: 485 | fmt.printf("", obj.cdr) 486 | case .Symbol: 487 | fmt.printf("%s", atom_text(obj)) 488 | case .Int: 489 | fmt.printf("%d", int(uintptr(obj.cdr))) 490 | case .Builtin: 491 | fmt.printf("", Builtin(rawptr(obj.cdr))) 492 | case .Lambda: 493 | fmt.print("") 498 | case .Cell: 499 | if !inlist { 500 | fmt.print("(") 501 | inlist = true 502 | } 503 | lisp_print(obj.car) 504 | if obj.cdr == nil { 505 | break outer 506 | } 507 | fmt.print(" ") 508 | if cons_tag(obj.cdr) != .Cell { 509 | fmt.print(". ") 510 | lisp_print(obj.cdr) 511 | break outer 512 | } 513 | obj = obj.cdr 514 | continue outer 515 | } 516 | break outer 517 | } 518 | if inlist { 519 | fmt.print(")") 520 | } 521 | } 522 | 523 | main :: proc() { 524 | heap = make([]Cons, HEAP_SIZE * 2) 525 | defer delete(heap) 526 | fromspace, tospace = &heap[0], &heap[HEAP_SIZE] 527 | allocptr = fromspace 528 | numroots, roottop = 0, 0 529 | 530 | token_builder = strings.builder_make() 531 | defer strings.builder_destroy(&token_builder) 532 | strings.intern_init(&interned) 533 | defer strings.intern_destroy(&interned) 534 | TQUOTE, _ = strings.intern_get(&interned, "quote") 535 | TLAMBDA, _ = strings.intern_get(&interned, "lambda") 536 | TCOND, _ = strings.intern_get(&interned, "cond") 537 | TDEFINE, _ = strings.intern_get(&interned, "define") 538 | 539 | env: ^Cons 540 | gc_protect(&env, &atom_t, &atom_f) 541 | defer gc_pop() 542 | 543 | env, atom_t, atom_f = new_cons(nil, nil), new_atom("#t"), new_atom("#f") 544 | 545 | env_set(env, atom_t, atom_t) 546 | env_set(env, atom_f, nil) 547 | 548 | define_builtins(env) 549 | 550 | f := os.stdin 551 | buffer: [1024]byte 552 | 553 | if len(os.args) > 1 { 554 | ferr: os.Error 555 | f, ferr = os.open(os.args[1]) 556 | if ferr != nil { 557 | fmt.eprintfln("Error: failed to open file (Error: %v)", ferr) 558 | return 559 | } 560 | } 561 | 562 | bufio.reader_init_with_buf(&lisp_reader, f.stream, buffer[:]) 563 | defer if f != os.stdin { os.close(f) } 564 | defer bufio.reader_destroy(&lisp_reader) 565 | 566 | for { 567 | obj, err := lisp_read() 568 | if err != nil { 569 | break 570 | } 571 | obj = lisp_eval(obj, env) 572 | if f == os.stdin || ODIN_DEBUG { 573 | lisp_print(obj) 574 | fmt.println() 575 | } 576 | } 577 | } --------------------------------------------------------------------------------