├── .gitignore ├── LICENSE ├── README.md ├── compiler.c ├── compiler.lisp └── runtime.S /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | *.dfsl 5 | *.pfsl 6 | *.d64fsl 7 | *.p64fsl 8 | *.lx64fsl 9 | *.lx32fsl 10 | *.dx64fsl 11 | *.dx32fsl 12 | *.fx64fsl 13 | *.fx32fsl 14 | *.sx64fsl 15 | *.sx32fsl 16 | *.wx64fsl 17 | *.wx32fsl 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 OpenProgger 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Minimal LISP Compiler 2 | 3 | This compiler translates a minimal set of LISP primitives to x86_64 assembly code. 4 | It requires a assembler/compiler that accepts intel syntax to create a executable. 5 | 6 | Any compiled program requires a runtime, containing primitive calls, heap initialization etc. 7 | Currently only a x86_64 runtime is available. 8 | 9 | The set of supported LISP primitives are enough to provide the compiler source in LISP itself. 10 | 11 | ## Build Instructions 12 | 13 | First create the bootstrap compiler. 14 | ``` 15 | clang compiler.c -o bootstrap 16 | ``` 17 | 18 | Now compile the LISP source. 19 | ``` 20 | cat compiler.lisp | ./bootstrap > output.S 21 | ``` 22 | 23 | Use the provided runtime to create a working binary. 24 | ``` 25 | clang -static -nostartfiles -nodefaultlibs -masm=intel output.S runtime.S -o LISPC 26 | ``` 27 | 28 | After bootstrapping you can use the new LISPC executable to compile compiler.lisp again to verify its output is identical. 29 | 30 | ``` 31 | cat compiler.lisp | ./LISPC > output.S 32 | clang -static -nostartfiles -nodefaultlibs -masm=intel output.S runtime.S -o LISPC 33 | ``` 34 | Repeat these steps everytime when compiling LISP source files. 35 | 36 | ## Customizations 37 | 38 | The supported subset of LISP matches the primitives from Paul Graham's "The Roots of Lisp". 39 | This subset itself is enough for self-evaluation but it provides no interaction with the OS. 40 | To fix this the runtime introduces 2 additional primitives to make a self-hosted code generator possible: 41 | - **read**: Reads an S-Expression and transforms to an internal representation for the compiler. Whitespaces were accepted as valid token for symbols if escaped(e.g. '\ ') except of '\n' which will be replaced with the ASCII newline(0xA). 42 | - **print**: Prints the given object according to its representation. It doesn't create a newline at the end and returns always an empty list. 43 | 44 | The LISP compiler and it's runtime have no external dependencies except the entry point ____start___ and the syscalls **read** and **write** on Linux. 45 | For bare-metal platforms, only these 3 parts of the runtime need to be rewritten. 46 | 47 | ## Related sources 48 | [The Roots of Lisp](http://www.paulgraham.com/rootsoflisp.html) - Minimal primitives to eval LISP 49 | [A. Carl Douglas' Micro Lisp](https://github.com/carld/micro-lisp) - Inspiration for the parser and source evaluation of the compiler 50 | -------------------------------------------------------------------------------- /compiler.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | // Required Object types at compile-time 6 | enum Type { 7 | SYMBOL, 8 | CELL 9 | }; 10 | 11 | // Generic Object Declaration 12 | typedef struct Object { 13 | enum Type type; 14 | union { 15 | struct { 16 | struct Object* cdr; 17 | struct Object* car; 18 | } list; 19 | char* symbol; 20 | }; 21 | } Object; 22 | 23 | // Last entry of the internal symbol list 24 | Object* symbols; 25 | 26 | // Peeked integer from input 27 | int peek; 28 | 29 | // Fetch Token from stdin 30 | void gettoken(char* token) { 31 | int index = 0; 32 | 33 | // Skip any whitespaces and newline 34 | while(peek == ' ' || peek == '\n' || peek == '\t') 35 | peek = getchar(); 36 | 37 | if (peek == '(' || peek == ')') { 38 | // Fetch only one char 39 | token[index++] = peek; 40 | peek = getchar(); 41 | } else { 42 | 43 | // Read symbol name until a terminating char is reached 44 | while(peek != 0 && peek != ' ' && peek != '\n' && peek != '\t' && peek != '(' && peek != ')') { 45 | 46 | // Take terminating char if escaped 47 | if(peek == '\\') { 48 | peek = getchar(); 49 | 50 | // Handle newline 51 | if (peek == 'n') 52 | peek = '\n'; 53 | } 54 | 55 | token[index++] = peek; 56 | peek = getchar(); 57 | } 58 | } 59 | 60 | // Terminate token buffer 61 | token[index] = '\0'; 62 | } 63 | 64 | // Create list object from given objects 65 | Object* cons(Object* _car, Object* _cdr) { 66 | Object *_pair = calloc(1, sizeof(Object)); 67 | *_pair = (Object) {.type = CELL, .list = {.car = _car, .cdr = _cdr}}; 68 | return _pair; 69 | } 70 | 71 | // Get address of given string from symbol table or create a new one 72 | Object* symbol(char *sym) { 73 | Object* _pair = symbols; 74 | for (;_pair; _pair = _pair->list.cdr) 75 | if (strncmp(sym, _pair->list.car->symbol, 64)==0) 76 | return _pair->list.car; 77 | 78 | // No matching string found, create new one and append to list 79 | Object *symbol = calloc(1, sizeof(Object)); 80 | *symbol = (Object) {.type = SYMBOL, .symbol = strdup(sym)}; 81 | symbols = cons(symbol, symbols); 82 | return symbol; 83 | } 84 | 85 | // Parse list from tokens 86 | Object* getlist() { 87 | 88 | // Fetch first element for list 89 | char token[64] = {0}; 90 | gettoken(token); 91 | 92 | // Return if end of list reached 93 | if (token[0] == ')') 94 | return 0; 95 | 96 | // Parse two elements and create new list from them 97 | Object* car = token[0] == '(' ? getlist() : symbol(token); 98 | return cons(car, getlist()); 99 | } 100 | 101 | // Codegen for fetching symbols 102 | int getsymbol(Object* sym, int label) { 103 | 104 | // Assembly code to fetch symbols at runtime 105 | printf("push rdi\n"); 106 | printf("jmp L%d_skip\n", label); 107 | printf("L%d_str:\n", label); 108 | printf(".asciz \"%s\"\n", sym->symbol); 109 | printf("L%d_skip:\n", label); 110 | printf("lea rdi, [rip + L%d_str]\n", label); 111 | printf("call symbol\n"); 112 | printf("pop rdi\n"); 113 | return label + 1; 114 | } 115 | 116 | // Recursive function to bind values to their parameters 117 | int applylist(Object* exp, int label) { 118 | if(exp) { 119 | 120 | // Take value from parameter 121 | printf("push rdi\n"); 122 | printf("call car\n"); 123 | printf("mov rdi, rax\n"); 124 | printf("push rdi\n"); 125 | 126 | // Fetch symbol name 127 | int new_label = getsymbol(exp->list.car, label); 128 | printf("mov rdi, rax\n"); 129 | printf("pop rsi\n"); 130 | 131 | // Create variable binding 132 | printf("call set_var\n"); 133 | printf("pop rdi\n"); 134 | printf("call cdr\n"); 135 | printf("mov rdi, rax\n"); 136 | return applylist(exp->list.cdr, new_label); 137 | } 138 | return label; 139 | } 140 | 141 | // Codegen for constants 142 | int gendata(Object* exp, int label) { 143 | if(!exp) { 144 | 145 | // NULL if no data available 146 | printf("xor eax, eax\n"); 147 | return label; 148 | } else if(exp->type == SYMBOL) { 149 | 150 | // Just fetch the symbol 151 | return getsymbol(exp, label); 152 | } else { 153 | 154 | // Process first element 155 | int new_label = gendata(exp->list.car, label); 156 | printf("push rax\n"); 157 | 158 | // Process second element 159 | int gen_label = gendata(exp->list.cdr, new_label); 160 | printf("mov rsi, rax\n"); 161 | printf("pop rdi\n"); 162 | printf("call cons\n"); 163 | return gen_label; 164 | } 165 | } 166 | 167 | int compile(Object* exp, int label); 168 | 169 | // Generate conditionals with unique labels 170 | int gencond(Object* exp, int label, int prev_label, int endlabel) { 171 | if(exp) { 172 | 173 | // Conditional label 174 | printf("L%d:\n", prev_label); 175 | int comp_label = compile(exp->list.car->list.car, label); 176 | 177 | // Check condition 178 | printf("test rax, rax\n"); 179 | 180 | // Jump to next condition or to end if last condition 181 | printf("jz L%d\n", exp->list.cdr ? comp_label : endlabel); 182 | int comp2_label = compile(exp->list.car->list.cdr->list.car, comp_label + 1); 183 | 184 | // Jump to end after branch finished 185 | printf("jmp L%d\n", endlabel); 186 | return gencond(exp->list.cdr, comp2_label, comp_label, endlabel); 187 | } 188 | printf("L%d:\n", endlabel); 189 | return label; 190 | } 191 | 192 | // Evaluate parameter list 193 | int evlist(Object* exp, int label, _Bool first) { 194 | if(exp) { 195 | 196 | // Save entry to first parameter on first run 197 | if(first) { 198 | int comp_label = compile(exp->list.car, label); 199 | printf("mov rdi, rax\n"); 200 | printf("xor esi, esi\n"); 201 | printf("call cons\n"); 202 | printf("push rax\n"); 203 | printf("add rax, 9\n"); 204 | return evlist(exp->list.cdr, comp_label, 0); 205 | } else { 206 | 207 | // Chain remaining parameters to each other 208 | printf("push rax\n"); 209 | int comp_label = compile(exp->list.car, label); 210 | printf("mov rdi, rax\n"); 211 | printf("xor esi, esi\n"); 212 | printf("call cons\n"); 213 | printf("pop rdi\n"); 214 | printf("mov [rdi], rax\n"); 215 | printf("add rax, 9\n"); 216 | return evlist(exp->list.cdr, comp_label, 0); 217 | } 218 | } 219 | 220 | // Take parameter list and closure data to call it 221 | printf("xor esi, esi\n"); 222 | if(!first) { 223 | printf("pop rsi\n"); 224 | } 225 | printf("pop rdi\n"); 226 | printf("call apply\n"); 227 | return label; 228 | } 229 | 230 | int compile(Object* exp, int label) { 231 | if(!exp) { 232 | 233 | // NULL if no expression present 234 | printf("xor eax, eax\n"); 235 | return label; 236 | } else if ( exp->type == SYMBOL ) { 237 | 238 | // Resolve symbol 239 | int symbol_label = getsymbol(exp, label); 240 | printf("mov rdi, rax\n"); 241 | printf("call get_val\n"); 242 | return symbol_label; 243 | } else if (exp->list.car == symbol("quote")) { 244 | 245 | // Generate constant data 246 | return gendata(exp->list.cdr->list.car, label); 247 | } else if (exp->list.car == symbol("cond")) { 248 | 249 | // Generate condition 250 | return gencond(exp->list.cdr, label + 2, label + 1, label); 251 | } else if (exp->list.car == symbol("lambda")) { 252 | 253 | // Create entry for function 254 | printf("call L%d\n", label); 255 | 256 | // Apply parameters 257 | int apply_label = applylist(exp->list.cdr->list.car, label + 1); 258 | int comp_label = compile(exp->list.cdr->list.cdr->list.car, apply_label); 259 | printf("ret\n"); 260 | 261 | // Skip label to prevent early execution 262 | printf("L%d:\n", label); 263 | 264 | // Take address of function entry 265 | printf("pop rdi\n"); 266 | printf("call gen_closure\n"); 267 | return comp_label; 268 | } else { 269 | 270 | // Generate function call 271 | int comp_label = compile(exp->list.car, label); 272 | printf("push rax\n"); 273 | return evlist(exp->list.cdr, comp_label, 1); 274 | } 275 | } 276 | 277 | int main() { 278 | // Prefix for GAS 279 | printf(".globl app\napp:\n"); 280 | 281 | // Trigger parsing 282 | peek = getchar(); 283 | char token[64] = {0}; 284 | gettoken(token); 285 | 286 | // Generate Assembler output 287 | compile(token[0] == '(' ? getlist() : symbol(token), 0); 288 | printf("ret\n"); 289 | return 0; 290 | } 291 | -------------------------------------------------------------------------------- /compiler.lisp: -------------------------------------------------------------------------------- 1 | (cond 2 | ((print (quote .globl\ app\napp:\n)) 3 | ()) 4 | (((lambda (printnum increment) 5 | ((lambda (getsymbol) 6 | ((lambda (applylist gendata gencond evlist) 7 | ((lambda (compile) 8 | (compile compile (read) (quote (0)))) 9 | (lambda (compile exp label) 10 | (cond 11 | ((eq exp ()) 12 | (cond ((eq (print (quote xor\ eax,\ eax\n)) ()) label))) 13 | ((atom exp) 14 | ((lambda (symbol_label) 15 | (cond 16 | ((print (quote mov\ rdi,\ rax\n)) ()) 17 | ((eq (print (quote call\ get_val\n)) ()) symbol_label))) 18 | (getsymbol exp label))) 19 | ((eq (car exp) (quote quote)) 20 | (gendata gendata (car (cdr exp)) label)) 21 | ((eq (car exp) (quote cond)) 22 | (gencond gencond 23 | compile 24 | (cdr exp) 25 | (increment increment (increment increment label)) 26 | (increment increment label) 27 | label)) 28 | ((eq (car exp) (quote lambda)) 29 | (cond 30 | ((print (quote call\ L)) 31 | ()) 32 | ((printnum printnum label) 33 | ()) 34 | ((eq (print (quote \n)) ()) 35 | ((lambda (apply_label) 36 | ((lambda (comp_label) 37 | (cond 38 | ((print (quote ret\nL)) ()) 39 | ((printnum printnum label) ()) 40 | ((print (quote :\n)) ()) 41 | ((print (quote pop\ rdi\n)) ()) 42 | ((eq (print (quote call\ gen_closure\n)) ()) comp_label))) 43 | (compile compile (car (cdr (cdr exp))) apply_label))) 44 | (applylist applylist (car (cdr exp)) (increment increment label)))))) 45 | ((quote t) 46 | ((lambda (comp_label) 47 | (cond 48 | ((eq (print (quote push\ rax\n)) ()) 49 | (evlist evlist compile (cdr exp) comp_label (quote t))))) 50 | (compile compile (car exp) label))))))) 51 | (lambda (applylist exp label) 52 | (cond 53 | ((eq exp ()) 54 | label) 55 | ((print (quote push\ rdi\n)) 56 | ()) 57 | ((print (quote call\ car\n)) 58 | ()) 59 | ((print (quote mov\ rdi,\ rax\n)) 60 | ()) 61 | ((eq (print (quote push\ rdi\n)) ()) 62 | ((lambda (new_label) 63 | (cond 64 | ((print (quote mov\ rdi,\ rax\n)) ()) 65 | ((print (quote pop\ rsi\n)) ()) 66 | ((print (quote call\ set_var\n)) ()) 67 | ((print (quote pop\ rdi\n)) ()) 68 | ((print (quote call\ cdr\n)) ()) 69 | ((eq (print (quote mov\ rdi,\ rax\n)) ()) (applylist applylist (cdr exp) new_label)))) 70 | (getsymbol (car exp) label))))) 71 | (lambda (gendata exp label) 72 | (cond 73 | ((eq exp ()) 74 | (cond ((eq (print (quote xor\ eax,\ eax\n)) ()) label))) 75 | ((atom exp) 76 | (getsymbol exp label)) 77 | ((quote t) 78 | ((lambda (new_label) 79 | (cond 80 | ((eq (print (quote push\ rax\n)) ()) 81 | ((lambda (gen_label) 82 | (cond 83 | ((print (quote mov\ rsi,\ rax\n)) ()) 84 | ((print (quote pop\ rdi\n)) ()) 85 | ((eq (print (quote call\ cons\n)) ()) gen_label))) 86 | (gendata gendata (cdr exp) new_label))))) 87 | (gendata gendata (car exp) label))))) 88 | (lambda (gencond compile exp label prev_label endlabel) 89 | (cond 90 | ((eq exp ()) 91 | (cond 92 | ((print (quote L)) ()) 93 | ((printnum printnum endlabel) ()) 94 | ((eq (print (quote :\n)) ()) label))) 95 | ((print (quote L)) 96 | ()) 97 | ((printnum printnum prev_label) 98 | ()) 99 | ((print (quote :\n)) 100 | ()) 101 | ((quote t) 102 | ((lambda (comp_label) 103 | (cond 104 | ((print (quote test\ rax,\ rax\n)) 105 | ()) 106 | ((print (quote jz\ L)) 107 | ()) 108 | ((printnum printnum 109 | (cond 110 | ((eq (cdr exp) ()) endlabel) 111 | ((quote t) comp_label))) 112 | ()) 113 | ((print (quote \n)) 114 | ()) 115 | ((quote t) 116 | ((lambda (comp2_label) 117 | (cond 118 | ((print (quote jmp\ L)) 119 | ()) 120 | ((printnum printnum endlabel) 121 | ()) 122 | ((eq (print (quote \n)) ()) 123 | (gencond gencond compile (cdr exp) comp2_label comp_label endlabel)))) 124 | (compile compile (car (cdr (car exp))) (increment increment comp_label)))))) 125 | (compile compile (car (car exp)) label))))) 126 | (lambda (evlist compile exp label first) 127 | (cond 128 | ((eq exp ()) 129 | (cond 130 | ((print (quote xor\ esi,\ esi\n)) ()) 131 | ((cond ((eq first ()) (print (quote pop\ rsi\n)))) ()) 132 | ((print (quote pop\ rdi\n)) ()) 133 | ((eq (print (quote call\ apply\n)) ()) label))) 134 | ((eq first ()) 135 | (cond 136 | ((print (quote push\ rax\n)) 137 | ()) 138 | ((quote t) 139 | ((lambda (comp_label) 140 | (cond 141 | ((print (quote mov\ rdi,\ rax\n)) 142 | ()) 143 | ((print (quote xor\ esi,\ esi\n)) 144 | ()) 145 | ((print (quote call\ cons\n)) 146 | ()) 147 | ((print (quote pop\ rdi\n)) 148 | ()) 149 | ((print (quote mov\ [rdi],\ rax\n)) 150 | ()) 151 | ((eq (print (quote add\ rax,\ 9\n)) ()) 152 | (evlist evlist compile (cdr exp) comp_label ())))) 153 | (compile compile (car exp) label))))) 154 | ((quote t) 155 | ((lambda (comp_label) 156 | (cond 157 | ((print (quote mov\ rdi,\ rax\n)) 158 | ()) 159 | ((print (quote xor\ esi,\ esi\n)) 160 | ()) 161 | ((print (quote call\ cons\n)) 162 | ()) 163 | ((print (quote push\ rax\n)) 164 | ()) 165 | ((eq (print (quote add\ rax,\ 9\n)) ()) 166 | (evlist evlist compile (cdr exp) comp_label ())))) 167 | (compile compile (car exp) label))))))) 168 | (lambda (sym label) 169 | (cond 170 | ((print (quote push\ rdi\n)) ()) 171 | ((print (quote jmp\ L)) ()) 172 | ((printnum printnum label) ()) 173 | ((print (quote _skip\nL)) ()) 174 | ((printnum printnum label) ()) 175 | ((print (quote _str:\n)) ()) 176 | ((print (quote .asciz\ \\")) ()) 177 | ((print sym) ()) 178 | ((print (quote \\"\nL)) ()) 179 | ((printnum printnum label) ()) 180 | ((print (quote _skip:\n)) ()) 181 | ((print (quote lea\ rdi,\ [rip\ +\ L)) ()) 182 | ((printnum printnum label) ()) 183 | ((print (quote _str]\n)) ()) 184 | ((print (quote call\ symbol\n)) ()) 185 | ((eq (print (quote pop\ rdi\n)) ()) (increment increment label)))))) 186 | (lambda (printnum number) 187 | (cond 188 | ((eq (cdr number) ()) (print (car number))) 189 | ((eq (printnum printnum (cdr number)) ()) (print (car number))))) 190 | (lambda (increment number) 191 | (cond 192 | ((eq number ()) (cons (quote 1) ())) 193 | ((eq (car number) (quote 0)) (cons (quote 1) (cdr number))) 194 | ((eq (car number) (quote 1)) (cons (quote 2) (cdr number))) 195 | ((eq (car number) (quote 2)) (cons (quote 3) (cdr number))) 196 | ((eq (car number) (quote 3)) (cons (quote 4) (cdr number))) 197 | ((eq (car number) (quote 4)) (cons (quote 5) (cdr number))) 198 | ((eq (car number) (quote 5)) (cons (quote 6) (cdr number))) 199 | ((eq (car number) (quote 6)) (cons (quote 7) (cdr number))) 200 | ((eq (car number) (quote 7)) (cons (quote 8) (cdr number))) 201 | ((eq (car number) (quote 8)) (cons (quote 9) (cdr number))) 202 | ((eq (car number) (quote 9)) (cons (quote 0) (increment increment (cdr number))))))) 203 | (print (quote ret\n))) 204 | ((quote t) (print (quote ret\n)))) 205 | -------------------------------------------------------------------------------- /runtime.S: -------------------------------------------------------------------------------- 1 | # Lisp Runtime 2 | # r12: Heap ptr 3 | # r13: Environment ptr 4 | # r14: Symbol ptr 5 | # r15: Peek char 6 | 7 | .globl _start, gen_closure, apply, get_val, set_var, symbol, car, cdr, cons 8 | _start: 9 | sub rsp, 4194304 10 | mov r12, rsp # Heap: 4 MB 11 | xor r13, r13 # Reset Environment 12 | xor r14, r14 # Reset symbol table 13 | mov r15, 0x20 # Reset peek char 14 | lea rdi, [rip + proc_atom] # Get address for atom function 15 | mov rsi, 0x6D6F7461 # 'atom' 16 | call gen_proc # Create atom closure 17 | lea rdi, [rip + proc_eq] # Get address for eq function 18 | mov rsi, 0x7165 # 'eq' 19 | call gen_proc # Create eq closure 20 | lea rdi, [rip + proc_car] # Get address for car function 21 | mov rsi, 0x726163 # 'car' 22 | call gen_proc # Create car closure 23 | lea rdi, [rip + proc_cdr] # Get address for cdr function 24 | mov rsi, 0x726463 # 'cdr' 25 | call gen_proc # Create cdr closure 26 | lea rdi, [rip + proc_cons] # Get address for cons function 27 | mov rsi, 0x736E6F63 # 'cons' 28 | call gen_proc # Create cons closure 29 | lea rdi, [rip + proc_print] # Get address for print function 30 | mov rsi, 0x746E697270 # 'print' 31 | call gen_proc # Create print closure 32 | lea rdi, [rip + proc_read] # Get address for read function 33 | mov rsi, 0x64616572 # 'read' 34 | call gen_proc # Create read closure 35 | call app # Run compiled binary 36 | mov eax, 60 # Call OS-Exit 37 | xor rdi, rdi 38 | syscall 39 | 40 | gen_proc: 41 | push rsi # Preserve string buffer 42 | call gen_closure # Create closure 43 | mov rdi, rsp # Take address to string buffer 44 | push rax # Preserve closure address 45 | call symbol # Create Symbol 46 | mov rdi, rax # Take symbol 47 | pop rsi # Take closure address 48 | pop rax # Delete string buffer 49 | call set_var # Bind closure to symbol 50 | ret 51 | 52 | gen_closure: # Create closure with current environment 53 | mov rsi, r13 # Catch current environment 54 | call cons # Bind procedure to current environment 55 | mov cl, 2 56 | mov [rax], cl # Apply Function(2) tag 57 | ret 58 | 59 | apply: 60 | push r13 # Create new environment frame 61 | push rsi # Preserve parameter 62 | push rdi # Preserve closure 63 | call cdr # Take environment from closure 64 | pop rdi # Take closure 65 | mov r13, rax # Set catched environment frame 66 | call car # Get procedure address 67 | pop rdi # Take parameter 68 | call rax # Call procedure 69 | pop r13 # Closre environment frame 70 | ret 71 | 72 | set_var: # Create new symbol mapping for current Environment Frame 73 | call cons # Create mapping 74 | mov cl, 3 75 | mov [rax], cl # Apply Environment Map(3) tag 76 | mov rdi, rax # Apply new mapping 77 | mov rsi, r13 # Chain to previous mapping 78 | call cons # Create mapping 79 | mov r13, rax # Set new head address 80 | ret 81 | 82 | get_val: # Get value of given variable 83 | push rdi # Preserve search criteria 84 | mov rcx, r13 # Set iteration pointer 85 | search_loop: 86 | test rcx, rcx 87 | jz search_exit # End of environment reached(shouldn't happen) 88 | mov rdi, rcx 89 | call car # Access entry 90 | mov rdi, rax 91 | call car # Take symbol address 92 | mov rdi, [rsp] 93 | cmp rax, rdi 94 | je search_loop_end # Exit on match 95 | mov rdi, rcx 96 | call cdr # Move to next entry 97 | mov rcx, rax 98 | jmp search_loop # Continue search if search criteria is not matching 99 | search_loop_end: 100 | mov rdi, rcx 101 | call car # Access entry 102 | mov rdi, rax 103 | call cdr # Return value for symbol 104 | search_exit: 105 | pop rdi # Clear stack 106 | ret 107 | 108 | symbol: # Get/Create Symbol 109 | push rdi # Save search criteria 110 | mov rax, r14 # Start iteration 111 | search_sym_loop: 112 | test rax, rax 113 | jz search_sym_loop_end # Exit if no symbols left 114 | mov rdi, rax 115 | push rax # Save current iteration 116 | call car # Take symbol address 117 | mov rsi, rax 118 | inc rsi # Skip tag 119 | pop rax 120 | mov rdi, [rsp] # Take search criteria 121 | push rax 122 | call cmp # Compare buffers 123 | test rax, rax 124 | jz no_match # Continue iteration if no match 125 | pop rax # Restore iteration 126 | mov rdi, rax 127 | call car # Return symbol address 128 | pop rdi 129 | ret 130 | no_match: 131 | pop rax # Restore iteration 132 | mov rdi, rax 133 | call cdr # Move to next entry 134 | jmp search_sym_loop 135 | search_sym_loop_end: 136 | pop rdi # Take string buffer 137 | call dup # Create symbol object 138 | mov rdi, rax 139 | mov rsi, r14 140 | call cons # Create entry 141 | mov r14, rax # Apply new head of symbols 142 | mov rdi, rax 143 | call car # Return symbol address 144 | ret 145 | 146 | cmp: # Compare 2 strings 147 | mov al, [rdi] # Read bytes 148 | mov bl, [rsi] 149 | inc rdi # Move to next byte 150 | inc rsi 151 | cmp al, bl 152 | jne differ # Exit if not equal 153 | test al, al 154 | jnz cmp # Equality if termination reached 155 | mov eax, 1 # Return equal 156 | ret 157 | differ: 158 | xor eax, eax # Return unequal 159 | ret 160 | 161 | dup: # Create string object from buffer 162 | push r12 # Save new address 163 | xor eax, eax 164 | mov [r12], al # Apply Symbol(0) tag 165 | inc r12 166 | copy_loop: 167 | mov al, [rdi] # Take byte 168 | inc rdi 169 | mov [r12], al # Save byte 170 | inc r12 171 | test al, al 172 | jnz copy_loop # Terminate on 0 173 | pop rax # Return to new object 174 | ret 175 | 176 | cons: # Create list from 2 elements 177 | mov al, 1 178 | mov [r12], al # Apply List(1) tag 179 | mov [r12 + 1], rdi # Set first element 180 | mov [r12 + 9], rsi # Set second element 181 | mov rax, r12 # Return address to new object 182 | add r12, 17 183 | ret 184 | 185 | car: # Take first element from list 186 | mov rax, [rdi + 1] 187 | ret 188 | 189 | cdr: # Take elements except of the first one from list 190 | mov rax, [rdi + 9] 191 | ret 192 | 193 | proc_atom: # Check if given item is an atom 194 | call car # Access parameter 195 | mov bl, [rax] # Take tag 196 | cmp bl, 1 197 | jne is_atom # Check for list tag 198 | xor eax, eax # Return false on list 199 | ret 200 | is_atom: 201 | mov ax, 0x74 # 't' 202 | push ax 203 | mov rdi, rsp # Take string buffer address 204 | call symbol # Create truthly symbol 205 | pop di # Clear stack 206 | ret 207 | 208 | proc_eq: # Compare symbols 209 | push rdi # Preserve parameter 210 | call car # Access first parameter 211 | pop rdi # Take parameters 212 | push rax # Preserve first parameter 213 | call cdr 214 | mov rdi, rax 215 | call car # Access second parameter 216 | mov rdi, rax 217 | pop rsi # Take first parameter 218 | cmp rdi, rsi 219 | je equal # Same address is also equal 220 | test rdi, rdi 221 | jz unequal 222 | test rsi, rsi 223 | jz unequal 224 | inc rdi # Skip tags 225 | inc rsi 226 | call cmp # Compare 227 | test rax, rax 228 | jnz equal 229 | unequal: 230 | xor eax, eax # Return unequal 231 | ret 232 | equal: 233 | mov ax, 0x74 # 't' 234 | push ax 235 | mov rdi, rsp # Take string buffer address 236 | call symbol # Create truthly symbol 237 | pop di # Clear stack 238 | ret 239 | 240 | proc_car: # car procedure 241 | call car # Access parameter 242 | mov rdi, rax 243 | call car # Return first element 244 | ret 245 | 246 | proc_cdr: # cdr procedure 247 | call car # Access parameter 248 | mov rdi, rax 249 | call cdr # Restur rest of list 250 | ret 251 | 252 | proc_cons: # cons procedure 253 | push rdi # Preserve parameter 254 | call car # Access first parameter 255 | pop rdi # Take parameters 256 | push rax # Preserve first parameter 257 | call cdr 258 | mov rdi, rax 259 | call car # Access second parameter 260 | pop rdi # Take first parameter 261 | mov rsi, rax 262 | call cons # Create new list 263 | ret 264 | 265 | proc_print: # print procedure 266 | call car # Access first parameter 267 | mov rdi, rax 268 | mov esi, 1 # Mark as first element 269 | call print # Print object 270 | xor eax, eax # Always return empty list 271 | ret 272 | 273 | print: 274 | test rdi, rdi 275 | jnz take_tag 276 | mov rdi, 0x28 277 | call write 278 | mov rdi, 0x29 279 | call write 280 | xor eax, eax 281 | ret 282 | take_tag: 283 | mov bl, [rdi] # Take tag 284 | cmp bl, 1 285 | je is_pair # Check for list tag 286 | inc rdi # Skip tag 287 | call print_symbol # Print symbol 288 | ret 289 | is_pair: 290 | push rdi # Preserve parameter 291 | test rsi, rsi 292 | jz no_head # Check for first element 293 | mov rdi, 0x28 # '(' 294 | call write 295 | no_head: 296 | mov rdi, [rsp] 297 | call car # Access parameter 298 | mov rdi, rax 299 | mov esi, 1 300 | call print # Print first element 301 | pop rdi # Take parameter 302 | call cdr # Take second parameter 303 | test rax, rax 304 | jz end_list # Don't print if empty 305 | push rax # Preserve element 306 | mov rdi, 0x20 # ' ' 307 | call write 308 | pop rdi # Take element 309 | xor esi, esi 310 | call print 311 | ret 312 | end_list: 313 | mov rdi, 0x29 # ')' 314 | call write 315 | ret 316 | 317 | print_symbol: # Print symbol name 318 | xor eax, eax # Clear register for usage 319 | mov al, [rdi] # Read byte 320 | test al, al 321 | jz print_symbol_end # Terminate on 0 322 | push rdi # Preserve buffer address 323 | mov edi, eax 324 | call write # Print char 325 | pop rdi # Restore buffer address 326 | inc rdi # Move to next char 327 | jmp print_symbol 328 | print_symbol_end: 329 | ret 330 | 331 | proc_read: # Read expression 332 | sub rsp, 32 # Make 32-byte string buffer 333 | mov rdi, rsp 334 | call gettoken # Get first token 335 | mov al, [rsp] 336 | cmp al, 0x28 # '(' 337 | jne read_token # Parse list on paranthese 338 | add rsp, 32 # Clear buffer 339 | call getlist # Parse list 340 | ret 341 | read_token: 342 | mov rdi, rsp 343 | call symbol # Make symbol from token 344 | add rsp, 32 # Clear buffer 345 | ret 346 | 347 | gettoken: # Get next token 348 | push rdi 349 | xor rcx, rcx # Reset index 350 | whitespace_loop: 351 | cmp r15, 0x20 # ' ' 352 | je skip_byte # Skip byte on whitespace 353 | cmp r15, 0x9 # '\t' 354 | je skip_byte 355 | cmp r15, 0xA 356 | jne whitespace_loop_end 357 | skip_byte: 358 | push rcx 359 | call read # Read next byte 360 | pop rcx 361 | mov r15, rax # Save peek char 362 | jmp whitespace_loop 363 | whitespace_loop_end: 364 | cmp r15, 0x28 # '(' 365 | je peek_one # Save only one byte on list 366 | cmp r15, 0x29 # ')' 367 | je peek_one 368 | read_byte_loop: 369 | test r15, r15 370 | jz terminate_token # Exit on null 371 | cmp r15, 0x20 # ' ' 372 | je terminate_token # Exit on non-symbol char 373 | cmp r15, 0x9 # '\t' 374 | je terminate_token 375 | cmp r15, 0xA # '\n' 376 | je terminate_token 377 | cmp r15, 0x28 # '(' 378 | je terminate_token 379 | cmp r15, 0x29 # ')' 380 | je terminate_token 381 | cmp r15, 0x5C # '\' 382 | jne no_escape 383 | push rcx 384 | call read 385 | pop rcx 386 | cmp rax, 0x6E # 'n' 387 | jne no_newline 388 | mov rax, 0xA # '\n' 389 | no_newline: 390 | mov r15, rax 391 | no_escape: 392 | mov rdi, [rsp] # Take string buffer 393 | mov [rdi + rcx], r15b # Save peek char 394 | inc rcx # Increment index 395 | push rcx # Preserve counter 396 | call read # Read next byte 397 | pop rcx # Restore counter 398 | mov r15, rax # Save new peek char 399 | jmp read_byte_loop 400 | peek_one: 401 | mov rdi, [rsp] # Take string buffer 402 | mov [rdi + rcx], r15b # Save peek char 403 | inc rcx # Increment index 404 | push rcx # Preserve counter 405 | call read # Read next byte 406 | pop rcx # Restore counter 407 | mov r15, rax # Save new peek char 408 | terminate_token: 409 | xor eax, eax 410 | pop rdi 411 | mov [rdi + rcx], al # Save termination byte 412 | ret 413 | 414 | getlist: # Parse list 415 | sub rsp, 32 # Make 32-byte string buffer 416 | mov rdi, rsp 417 | call gettoken # Get next token 418 | mov al, [rsp] # Take first byte 419 | cmp al, 0x29 # ')' 420 | jne make_list # Check if list has ended 421 | add rsp, 32 422 | xor eax, eax # Return empty list 423 | ret 424 | make_list: 425 | cmp al, 0x28 # '(' 426 | jne take_token # Check for next list 427 | add rsp, 32 428 | call getlist # Parse list 429 | jmp take_token_end 430 | take_token: 431 | mov rdi, rsp 432 | call symbol # Create symbol 433 | add rsp, 32 434 | take_token_end: 435 | push rax # Preserve first element 436 | call getlist # Parse next list 437 | pop rdi # Take first element 438 | mov rsi, rax 439 | call cons # Create and return new list 440 | ret 441 | 442 | write: # OS-Write 443 | push di 444 | mov eax, 1 445 | mov edi, eax 446 | mov rsi, rsp 447 | mov edx, eax 448 | syscall 449 | pop di 450 | ret 451 | 452 | read: # OS-Read 453 | xor eax, eax 454 | xor edi, edi 455 | push rax 456 | mov rsi, rsp 457 | mov edx, 1 458 | syscall 459 | pop rax 460 | ret 461 | --------------------------------------------------------------------------------