├── .github └── workflows │ └── main.yml ├── .gitignore ├── LICENSE ├── README.org ├── alloc.c ├── alloc.h ├── env.c ├── env.h ├── examples ├── examples.bnl ├── math.bnl ├── socket.bnl └── streams.bnl ├── lib.bnl ├── lisp.c ├── lisp.h ├── locals.h ├── machine.c ├── machine.h ├── makefile ├── obj.h ├── parser.c ├── parser.h ├── prim.c ├── prim.h ├── symbol.c ├── symbol.h ├── util.c └── util.h /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | jobs: 4 | kernel: 5 | runs-on: ubuntu-latest 6 | name: build bnlisp 7 | steps: 8 | - uses: AaronJackson/2.11BSD-Action@v1.0 9 | with: 10 | path: /root 11 | run: | 12 | make 13 | ./lisp < examples/examples.bnl 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | lisp -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2019, Aaron S. Jackson + Robert Smith 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * bnlisp, a lisp for 2.11BSD 2 | 3 | [[https://github.com/aaronjackson/bnlisp/actions/workflows/main.yml/badge.svg]] 4 | 5 | #+BEGIN_SRC 6 | [2017-08-02 19:16:49] C is great because it lets me write scheme 7 | #+END_SRC 8 | 9 | bnl (Marc Cleave) was a fan of, among other things, Lisp, PDP-11s and 10 | UNIX. In bnlisp, we try to encapsulate some of these interests by 11 | building a lisp interpreter which runs on the PDP-11 under 2.11BSD. 12 | 13 | It is currently full of memory leaks, so, enjoy. 14 | 15 | ** Primitives 16 | 17 | - PROGN 18 | - QUOTE 19 | - WHILE 20 | - IF 21 | - SETQ 22 | - LAMBDA 23 | - + 24 | - CONS 25 | - CAR 26 | - CDR 27 | - RPLACA 28 | - RPLACD 29 | - EVAL 30 | - PRINT 31 | - ALL-SYMBOLS 32 | - EQ (as in pointers) 33 | - = (numeric) 34 | - STRING= 35 | - READ (read a lisp expression) 36 | - LOAD (load a `.bnl` lisp file) 37 | - CONCATENATE (strings only at the moment) 38 | - STREAM-OPEN (open file or network stream) 39 | - STREAM-CLOSE 40 | - STREAM-READ 41 | - STREAM-EOF? 42 | 43 | We all miss you bnl :heart: 44 | -------------------------------------------------------------------------------- /alloc.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "util.h" 4 | #include "obj.h" 5 | #include "machine.h" 6 | #include "alloc.h" 7 | 8 | 9 | obj_t * alloc_obj(type) 10 | obj_type_t type; 11 | { 12 | obj_t *o; 13 | 14 | if (VM->alloc_offset == VM->semispace_size) gc(); 15 | /* if (VM->alloc_offset == VM->semispace_size) fuck("game over"); */ 16 | 17 | o = &VM->from_space[++VM->alloc_offset]; 18 | o->type = type; 19 | return o; 20 | } 21 | 22 | obj_t *alloc_int(val) 23 | int val; 24 | { 25 | obj_t * x = alloc_obj(TINT); 26 | x->value.i = val; 27 | return x; 28 | } 29 | 30 | obj_t *alloc_float(val) 31 | float val; 32 | { 33 | obj_t * x = alloc_obj(TFLOAT); 34 | x->value.f = val; 35 | return x; 36 | } 37 | 38 | obj_t * alloc_string(s) 39 | char * s; 40 | { 41 | obj_t *x = alloc_obj(TSTRING); 42 | x->value.str = s; 43 | return x; 44 | } 45 | 46 | obj_t * alloc_cons(ca, cd) 47 | obj_t *ca, *cd; 48 | { 49 | obj_t *x = alloc_obj(TCONS); 50 | CAR(x) = ca; 51 | CDR(x) = cd; 52 | return x; 53 | } 54 | 55 | obj_t *alloc_primitive(code) 56 | primitive_t code; 57 | { 58 | obj_t *x = alloc_obj(TPRIMITIVE); 59 | x->value.prim.code = code; 60 | return x; 61 | } 62 | 63 | obj_t *alloc_function(params, body, env) 64 | obj_t *params, *body, *env; 65 | { 66 | obj_t *x = alloc_obj(TFUNCTION); 67 | x->value.fun.params = params; 68 | x->value.fun.body = body; 69 | x->value.fun.env = env; 70 | return x; 71 | } 72 | 73 | obj_t *alloc_socket(socket) 74 | int socket; 75 | { 76 | obj_t * x = alloc_obj(TSOCKET); 77 | x->value.i = socket; 78 | return x; 79 | } 80 | 81 | 82 | obj_t *alloc_stream(stream) 83 | FILE *stream; 84 | { 85 | obj_t *x = alloc_obj(TSTREAM); 86 | x->value.stream = stream; 87 | return x; 88 | } 89 | -------------------------------------------------------------------------------- /alloc.h: -------------------------------------------------------------------------------- 1 | 2 | obj_t *alloc_obj(); 3 | obj_t *alloc_int(); 4 | obj_t *alloc_float(); 5 | obj_t *alloc_string(); 6 | obj_t *alloc_cons(); 7 | obj_t *alloc_primitive(); 8 | obj_t *alloc_function(); 9 | obj_t *alloc_socket(); 10 | obj_t *alloc_stream(); 11 | -------------------------------------------------------------------------------- /env.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "util.h" 5 | #include "obj.h" 6 | #include "alloc.h" 7 | #include "lisp.h" 8 | #include "symbol.h" 9 | #include "env.h" 10 | 11 | obj_t *lookup_env(env, sym) 12 | obj_t *env, *sym; 13 | { 14 | obj_t *entry; 15 | assert(TSYMBOL == sym->type); 16 | for (; nil != env; env = CDR(env)) { 17 | entry = CAR(env); 18 | assert(TCONS == entry->type); 19 | if (sym == CAR(entry)) 20 | return entry; 21 | } 22 | return NULL; 23 | } 24 | 25 | obj_t *push_env(env, sym, val) 26 | obj_t *env, *sym, *val; 27 | { 28 | obj_t *entry = alloc_cons(sym, val); 29 | return alloc_cons(entry, env); 30 | } 31 | 32 | /* syms: list of symbols 33 | vals: list of evaluated values */ 34 | obj_t *augment_env(env, syms, vals) 35 | obj_t *env, *syms, *vals; 36 | { 37 | obj_t *entry; 38 | obj_t *aug_env = env; 39 | if (list_length(syms) != list_length(vals)) fuck("fun/arg mismatch"); 40 | while (nil != syms) { 41 | entry = alloc_cons(CAR(syms), CAR(vals)); 42 | aug_env = alloc_cons(entry, aug_env); 43 | syms = CDR(syms); 44 | vals = CDR(vals); 45 | } 46 | assert(nil == syms); 47 | assert(nil == vals); 48 | return aug_env; 49 | } 50 | 51 | obj_t *pop_env(env) 52 | obj_t *env; 53 | { 54 | /* memory leak */ 55 | if (nil == env) return nil; 56 | return CDR(env); 57 | } 58 | -------------------------------------------------------------------------------- /env.h: -------------------------------------------------------------------------------- 1 | obj_t *lookup_env(); 2 | obj_t *push_env(); 3 | obj_t *augment_env(); 4 | obj_t *pop_env(); 5 | -------------------------------------------------------------------------------- /examples/examples.bnl: -------------------------------------------------------------------------------- 1 | (+ 1 2) 2 | (QUOTE (+ 1 2)) 3 | (CONS 2 1) 4 | (EVAL (CONS '+ (CONS 1 (CONS 2 NIL)))) 5 | (EVAL (CONS + (CONS 1 (CONS 2 NIL)))) 6 | (EVAL (QUOTE (+ 1 2))) 7 | (IF 1 (PRINT 'something) (PRINT 'something-else)) 8 | (IF NIL (PRINT 'something) (PRINT 'something-else)) 9 | (PROGN (PRINT 'something) (PRINT 'something-else)) 10 | -------------------------------------------------------------------------------- /examples/math.bnl: -------------------------------------------------------------------------------- 1 | ;; ROW MAJOR MODE MATRIX STUFF 2 | 3 | ;; matrix definition 4 | ;; w h elems 5 | (SETQ M '(2 2 (1 0 0 1))) 6 | 7 | ;; there is no multiply prim atm 8 | (SETQ * (LAMBDA (A B) 9 | ((LAMBDA (C Z A B) 10 | (WHILE (NOT (= C B)) 11 | (SETQ C (+ C 1)) 12 | (SETQ Z (+ Z A))) 13 | Z) 14 | 0 0 A B))) 15 | 16 | (SETQ MATRIX-NUMEL 17 | (LAMBDA (MAT) 18 | (* (CAR MAT) (CAR (CDR MAT))))) 19 | 20 | (SETQ MATRIX-PRINT 21 | (LAMBDA (MAT) 22 | (SETQ count (MATRIX-NUMEL MAT)) 23 | (SETQ c 0) 24 | (SETQ cc 0) 25 | (SETQ tail (CAR (CDR (CDR MAT)))) 26 | (WHILE (NOT (= c count)) 27 | (SETQ c (+ c 1)) 28 | (IF (= cc (CAR MAT)) 29 | (PROGN 30 | (SETQ cc 0) 31 | (PRINC "\n")) 32 | ()) 33 | (SETQ cc (+ cc 1)) 34 | (PRINC (CAR tail)) 35 | (PRINC "\t") 36 | (SETQ tail (CDR tail))) 37 | (PRINC "\n") 38 | MAT)) 39 | 40 | (SETQ MATRIX-GET-IJ 41 | (LAMBDA (MAT I J) 42 | (SETQ COUNT 0) 43 | (SETQ IDX (+ (* I (CAR MAT)) J)) 44 | (SETQ TAIL (CAR (CDR (CDR MAT)))) 45 | (WHILE (NOT (= COUNT IDX)) 46 | (SETQ COUNT (+ COUNT 1)) 47 | (SETQ TAIL (CDR TAIL))) 48 | (CAR TAIL))) 49 | 50 | (SETQ APPEND (LAMBDA (A B) 51 | (IF (EQ A NIL) 52 | B 53 | (CONS (CAR A) (APPEND (CDR A) B))))) 54 | 55 | (SETQ MATRIX-TRANSPOSE 56 | (LAMBDA (MAT) 57 | (SETQ I 0) 58 | (SETQ M (CAR (CDR (CDR MAT)))) 59 | (SETQ OUT ()) 60 | (WHILE (NOT (= I (CAR MAT))) 61 | (SETQ J 0) 62 | (WHILE (NOT (= J (CAR (CDR MAT)))) 63 | (SETQ OUT (APPEND OUT (CONS (MATRIX-GET-IJ MAT J I) NIL))) 64 | (SETQ J (+ J 1))) 65 | (SETQ I (+ I 1))) 66 | (CONS (CAR (CDR MAT)) (CONS (CAR MAT) (CONS OUT NIL) NIL)))) 67 | 68 | (SETQ MATRIX-GET-ROW 69 | (LAMBDA (M R) ;; get row R of matrix M 70 | (SETQ OUT ()) 71 | (SETQ COUNT 0) 72 | (WHILE (NOT (= COUNT (CAR M))) 73 | (SETQ OUT (APPEND OUT (CONS (MATRIX-GET-IJ M R COUNT) NIL))) 74 | (SETQ COUNT (+ COUNT 1))) 75 | OUT)) 76 | ;; (CONS (CAR M) (CONS 1 (CONS OUT NIL) NIL)))) 77 | 78 | (SETQ MATRIX-GET-COL 79 | (LAMBDA (M J) ;; get col J of matrix M 80 | (SETQ OUT ()) 81 | (SETQ COUNT 0) 82 | (WHILE (NOT (= COUNT (CAR (CDR M)))) 83 | (SETQ OUT (APPEND OUT (CONS (MATRIX-GET-IJ M COUNT J) NIL))) 84 | (SETQ COUNT (+ COUNT 1))) 85 | OUT)) 86 | 87 | (SETQ SUM 88 | (LAMBDA (V) 89 | (SETQ S 0) 90 | (SETQ TAIL V) 91 | (WHILE (NOT (EQ TAIL NIL)) 92 | (SETQ S (+ S (CAR TAIL))) 93 | (SETQ TAIL (CDR TAIL))) 94 | S)) 95 | 96 | 97 | ;; (CONS 1 (CONS (CAR (CDR M)) (CONS OUT NIL) NIL)))) 98 | (SETQ DOT-PRODUCT 99 | (LAMBDA (A B) 100 | (SETQ TAIL-A A) 101 | (SETQ TAIL-B B) 102 | (SETQ OUT ()) 103 | (WHILE (NOT (EQ TAIL-A NIL)) 104 | (SETQ OUT (APPEND OUT (CONS (* (CAR TAIL-A) (CAR TAIL-B)) NIL))) 105 | (SETQ TAIL-A (CDR TAIL-A)) 106 | (SETQ TAIL-B (CDR TAIL-B))) 107 | (SUM OUT))) 108 | 109 | 110 | ;; assumes dimensions A[x,y] = B[y,z] 111 | (SETQ MATRIX-MULTIPLY 112 | (LAMBDA (A B) 113 | (SETQ OUT-W (CAR (CDR A))) 114 | (SETQ OUT-H (CAR B)) 115 | (SETQ OUT ()) 116 | (SETQ J 0) 117 | (WHILE (NOT (= J OUT-H)) 118 | (SETQ I 0) 119 | (WHILE (NOT (= I OUT-W)) 120 | (SETQ OUT 121 | (APPEND OUT (CONS (DOT-PRODUCT 122 | (MATRIX-GET-ROW A I) 123 | (MATRIX-GET-COL B J)) NIL))) 124 | (SETQ I (+ I 1))) 125 | (SETQ J (+ J 1)) 126 | ) 127 | (CONS OUT-W (CONS OUT-H (CONS OUT NIL))))) 128 | 129 | (SETQ M '(2 3 (1 2 3 4 5 6))) 130 | (PRINC "Here is matrix M:\n") 131 | (MATRIX-PRINT M) 132 | (PRINC "\nHere is the transpose of M:\n") 133 | (MATRIX-PRINT (MATRIX-TRANSPOSE M)) 134 | 135 | (PRINC "\n\n\n") 136 | 137 | (SETQ V '(1 5 (1 2 3 4 5))) 138 | (PRINC "Here is column vector V:\n") 139 | (MATRIX-PRINT V) 140 | (PRINC "\n... and here is its transpose:\n") 141 | (MATRIX-PRINT (MATRIX-TRANSPOSE V)) 142 | 143 | (PRINC "\n\n\n") 144 | (SETQ M '(2 3 (1 2 3 4 5 6))) 145 | 146 | (MATRIX-PRINT M) 147 | (PRINT M) 148 | (PRINT (MATRIX-GET-ROW M 2)) 149 | (PRINT (MATRIX-GET-ROW M 0)) 150 | 151 | (PRINC "\n\n\n") 152 | (PRINT (DOT-PRODUCT (MATRIX-GET-ROW M 2) (MATRIX-GET-ROW M 0))) 153 | (PRINC "\n") 154 | M 155 | (MATRIX-PRINT (MATRIX-MULTIPLY M (MATRIX-TRANSPOSE M))) 156 | 157 | 158 | 159 | ;; $ cat math.bnl | ./lisp -s 160 | ;; welcome to bnlisp 161 | ;; Here is matrix M: 162 | ;; 1 2 163 | ;; 3 4 164 | ;; 5 6 165 | ;; 166 | ;; Here is the transpose of M: 167 | ;; 1 3 5 168 | ;; 2 4 6 169 | -------------------------------------------------------------------------------- /examples/socket.bnl: -------------------------------------------------------------------------------- 1 | (SETQ p (STREAM-OPEN 'TCP "aaronsplace.co.uk" 80)) 2 | (STREAM-WRITE p "GET / HTTP/1.1\r\n") 3 | (STREAM-WRITE p "Host: aaronsplace.co.uk\r\n") 4 | (STREAM-WRITE p "Connection: close\r\n\r\n"); 5 | 6 | (SETQ last-char "") 7 | (WHILE (NOT (EQ last-char NIL)) 8 | (SETQ last-char (STREAM-READ p)) 9 | (PRINT last-char)) 10 | (STREAM-CLOSE p) 11 | 12 | -------------------------------------------------------------------------------- /examples/streams.bnl: -------------------------------------------------------------------------------- 1 | (SETQ stream (STREAM-OPEN 'FILE "lib.bnl")) 2 | (WHILE (NOT (STREAM-EOF? stream)) 3 | (PRINT (STREAM-READ stream))) 4 | (STREAM-CLOSE stream) 5 | -------------------------------------------------------------------------------- /lib.bnl: -------------------------------------------------------------------------------- 1 | ;;; library functions 2 | 3 | (SETQ ZEROP (LAMBDA (X) (= 0 X))) 4 | 5 | (SETQ NULL (LAMBDA (X) (EQ NIL X))) 6 | 7 | (SETQ MAP (LAMBDA (F L) 8 | (IF (NULL L) 9 | NIL 10 | (CONS (F (CAR L)) 11 | (MAP F (CDR L)))))) 12 | 13 | (SETQ DOUBLE (LAMBDA (X) (+ X X))) 14 | 15 | (SETQ COMPOSE (LAMBDA (F G) (LAMBDA (X) (F (G X))))) 16 | 17 | (SETQ REPL (LAMBDA () 18 | (WHILE T 19 | (PRINT (EVAL (READ)))))) 20 | 21 | (SETQ TAKE (LAMBDA (N L) 22 | (IF (= 0 N) 23 | NIL 24 | (CONS (TAKE (CDR L) (+ N -1)) 25 | (CAR L))))) 26 | -------------------------------------------------------------------------------- /lisp.c: -------------------------------------------------------------------------------- 1 | /* bnlisp - lisp for the PDP-11 under 2.11BSD 2 | * dedicated to Marc Cleave 3 | * 4 | * by Robert Smith and Aaron Jackson 5 | */ 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | #include "util.h" 14 | #include "obj.h" 15 | #include "machine.h" 16 | #include "alloc.h" 17 | #include "parser.h" 18 | #include "symbol.h" 19 | #include "env.h" 20 | #include "prim.h" 21 | #include "lisp.h" 22 | 23 | /* eval each element of a list */ 24 | obj_t *evlis(args, env) 25 | obj_t *args, **env; 26 | { 27 | obj_t * head = NULL; 28 | obj_t * current = NULL; 29 | obj_t * node; 30 | 31 | if (nil == args) return nil; 32 | 33 | for (node = args; node != nil; node = CDR(node)) { 34 | if (!current) { 35 | current = alloc_cons(nil, nil); 36 | head = current; 37 | } else { 38 | current->value.c.cdr = alloc_cons(nil, nil); 39 | current = current->value.c.cdr; 40 | } 41 | current->value.c.car = eval(node->value.c.car, env); 42 | } 43 | return head; 44 | } 45 | 46 | obj_t *apply(fn, args, env) 47 | obj_t *fn, *args, **env; 48 | { 49 | obj_t *aug_env, *eargs; 50 | 51 | if (TPRIMITIVE == fn->type) { 52 | return fn->value.prim.code(env, args); 53 | } else if (TFUNCTION == fn->type) { 54 | /* env is ignored, because of lexical scope */ 55 | eargs = evlis(args, env); 56 | aug_env = augment_env(fn->value.fun.env, fn->value.fun.params, eargs); 57 | return primitive_progn(&aug_env, fn->value.fun.body); 58 | } else { 59 | fuck("can't apply this thing"); 60 | } 61 | fuck("cant reach here"); 62 | return NULL; 63 | } 64 | 65 | obj_t *eval(form, env) 66 | obj_t *form, **env; 67 | { 68 | obj_t *op, *args, *val; 69 | 70 | switch (form->type) { 71 | /* self evaluating forms */ 72 | case TNIL: 73 | case TTRUE: 74 | case TINT: 75 | case TFLOAT: 76 | case TSTRING: 77 | case TPRIMITIVE: 78 | case TFUNCTION: 79 | case TSOCKET: 80 | case TSTREAM: 81 | return form; 82 | 83 | case TSYMBOL: 84 | val = lookup_env(*env, form); 85 | if (!val) { 86 | printf("undefined: "); 87 | print(form); 88 | putchar('\n'); 89 | fuck("undefined variable"); 90 | } 91 | return CDR(val); 92 | 93 | /* a form to evaluate: (f x1 x2 ...) */ 94 | case TCONS: 95 | if (!proper_list_p(form)) fuck("no bueno thing being eval'd"); 96 | 97 | op = eval(CAR(form), env); 98 | args = CDR(form); 99 | 100 | if (TPRIMITIVE != op->type && TFUNCTION != op->type){ 101 | printf("got type %d\n", op->type); 102 | fuck("bad operator type"); 103 | } 104 | 105 | return apply(op, args, env); 106 | fuck("bug: shouldn't get here in eval"); 107 | default: 108 | fuck("i don't know how to eval this object"); 109 | } 110 | fuck("shouldn't get here"); 111 | return NULL; 112 | } 113 | 114 | 115 | void print(o) 116 | obj_t *o; 117 | { 118 | int i; 119 | char c; 120 | switch (o->type) { 121 | case TCONS: 122 | putchar('('); 123 | for (;;) { 124 | print(CAR(o)); 125 | if (nil == CDR(o)) 126 | break; 127 | if (TCONS != CDR(o)->type) { 128 | printf(" . "); 129 | print(CDR(o)); 130 | break; 131 | } 132 | putchar(' '); 133 | o = CDR(o); 134 | } 135 | putchar(')'); 136 | return; 137 | 138 | case TSTRING: 139 | putchar('"'); 140 | for (i = 0; o->value.str[i]; i++) { 141 | c = o->value.str[i]; 142 | if ('\t' == c) 143 | printf("\\t"); 144 | else if ('"' == c) 145 | printf("\\\""); 146 | else if ('\\' == c) 147 | printf("\\\\"); 148 | else if ('\n' == c) 149 | printf("\\n"); 150 | else if ('\r' == c) 151 | printf("\\r"); 152 | else 153 | putchar(c); 154 | } 155 | putchar('"'); 156 | return; 157 | 158 | case TSYMBOL: 159 | printf("%s", o->value.sym.name); 160 | return; 161 | 162 | case TINT: 163 | printf("%d", o->value.i); 164 | return; 165 | 166 | case TFLOAT: 167 | printf("%f", o->value.f); 168 | return; 169 | 170 | case TTRUE: 171 | printf("T"); 172 | return; 173 | 174 | case TNIL: 175 | printf("NIL"); 176 | return; 177 | 178 | case TPRIMITIVE: 179 | printf(""); 180 | return; 181 | 182 | case TFUNCTION: 183 | printf("value.fun.params); 185 | printf(">"); 186 | return; 187 | 188 | case TSTREAM: 189 | printf(""); 190 | return; 191 | 192 | case TSOCKET: 193 | printf(""); 194 | return; 195 | 196 | default: 197 | fuck("print: unknown type"); 198 | } 199 | } 200 | 201 | void init_lisp () 202 | { 203 | obj_t **env; 204 | VM = alloc_vm(NUM_OBJECTS * OBJ_SIZE); 205 | nil = alloc_obj(TNIL); 206 | tru = alloc_obj(TTRUE); 207 | VM->symbols = nil; 208 | VM->global_bindings = nil; 209 | env = &VM->global_bindings; 210 | *env = push_env(*env, 211 | intern("PROGN"), 212 | alloc_primitive(primitive_progn)); 213 | *env = push_env(*env, 214 | intern("QUOTE"), 215 | alloc_primitive(primitive_quote)); 216 | *env = push_env(*env, 217 | intern("WHILE"), 218 | alloc_primitive(primitive_while)); 219 | *env = push_env(*env, 220 | intern("IF"), 221 | alloc_primitive(primitive_if)); 222 | *env = push_env(*env, 223 | intern("SETQ"), 224 | alloc_primitive(primitive_setq)); 225 | *env = push_env(*env, 226 | intern("LAMBDA"), 227 | alloc_primitive(primitive_lambda)); 228 | *env = push_env(*env, 229 | intern("+"), 230 | alloc_primitive(primitive_add)); 231 | *env = push_env(*env, 232 | intern("-"), 233 | alloc_primitive(primitive_subtract)); 234 | *env = push_env(*env, 235 | intern("*"), 236 | alloc_primitive(primitive_multiply)); 237 | *env = push_env(*env, 238 | intern("CONS"), 239 | alloc_primitive(primitive_cons)); 240 | *env = push_env(*env, 241 | intern("CAR"), 242 | alloc_primitive(primitive_car)); 243 | *env = push_env(*env, 244 | intern("CDR"), 245 | alloc_primitive(primitive_cdr)); 246 | *env = push_env(*env, 247 | intern("RPLACA"), 248 | alloc_primitive(primitive_rplaca)); 249 | *env = push_env(*env, 250 | intern("RPLACD"), 251 | alloc_primitive(primitive_rplacd)); 252 | *env = push_env(*env, 253 | intern("EVAL"), 254 | alloc_primitive(primitive_eval)); 255 | *env = push_env(*env, 256 | intern("PRINT"), 257 | alloc_primitive(primitive_print)); 258 | *env = push_env(*env, 259 | intern("PRINC"), 260 | alloc_primitive(primitive_princ)); 261 | *env = push_env(*env, 262 | intern("ALL-SYMBOLS"), 263 | alloc_primitive(primitive_all_symbols)); 264 | *env = push_env(*env, 265 | intern("EQ"), 266 | alloc_primitive(primitive_eq)); 267 | *env = push_env(*env, 268 | intern("="), 269 | alloc_primitive(primitive_number_equals)); 270 | *env = push_env(*env, 271 | intern(">"), 272 | alloc_primitive(primitive_number_gt)); 273 | *env = push_env(*env, 274 | intern("STRING="), 275 | alloc_primitive(primitive_string_equals)); 276 | *env = push_env(*env, 277 | intern("NOT"), 278 | alloc_primitive(primitive_not)); 279 | *env = push_env(*env, 280 | intern("READ-CHAR"), 281 | alloc_primitive(primitive_readchar)); 282 | *env = push_env(*env, 283 | intern("READ"), 284 | alloc_primitive(primitive_read)); 285 | *env = push_env(*env, 286 | intern("LOAD"), 287 | alloc_primitive(primitive_load)); 288 | *env = push_env(*env, 289 | intern("CONCATENATE"), 290 | alloc_primitive(primitive_concatenate)); 291 | 292 | /* SOCKETS and STREAMS */ 293 | *env = push_env(*env, 294 | intern("STREAM-OPEN"), 295 | alloc_primitive(primitive_stream_open)); 296 | *env = push_env(*env, 297 | intern("STREAM-CLOSE"), 298 | alloc_primitive(primitive_stream_close)); 299 | *env = push_env(*env, 300 | intern("STREAM-READ"), 301 | alloc_primitive(primitive_stream_read)); 302 | *env = push_env(*env, 303 | intern("STREAM-WRITE"), 304 | alloc_primitive(primitive_stream_write)); 305 | *env = push_env(*env, 306 | intern("STREAM-EOF?"), 307 | alloc_primitive(primitive_stream_iseof)); 308 | 309 | } 310 | 311 | void eval_form(f, env) 312 | obj_t *f, **env; 313 | { 314 | printf("\n INPUT: "); 315 | print(f); 316 | putchar('\n'); 317 | f = eval(f, env); 318 | printf("OUTPUT: "); 319 | print(f); 320 | printf("\n"); 321 | } 322 | 323 | int main (argc, argv) 324 | int argc; 325 | char *argv[]; 326 | { 327 | obj_t *form; 328 | int silent = 0; 329 | 330 | silent = (argc > 1 && 0 == strcmp(argv[1], "-s")); 331 | 332 | init_lisp(); 333 | stream_i = stdin; 334 | stream_o = stdout; 335 | 336 | fprintf(stderr, "welcome to bnlisp\n"); 337 | 338 | for (;;) { 339 | form = read_sexp(); 340 | if (!form) break; 341 | if (silent) { 342 | eval(form, &VM->global_bindings); 343 | } else { 344 | eval_form(form, &VM->global_bindings); 345 | } 346 | } 347 | 348 | exit(0); 349 | } 350 | -------------------------------------------------------------------------------- /lisp.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #ifndef BNLISP_LISP_H 4 | #define BNLISP_LISP_H 5 | 6 | /* initialized by init_lisp */ 7 | obj_t *nil; 8 | obj_t *tru; 9 | 10 | #define NUM_OBJECTS 1048576 11 | 12 | void eval_form(); 13 | obj_t *eval(); 14 | obj_t *evlis(); 15 | obj_t *apply(); 16 | void print(); 17 | 18 | FILE *stream_i; /* input stream */ 19 | FILE *stream_o; /* output stream */ 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /locals.h: -------------------------------------------------------------------------------- 1 | #ifndef BNLISP_LOCALS_H 2 | #define BNLISP_LOCALS_H 3 | 4 | /* as bnl would say, this is 5 | 6 | m # # " 7 | mm#mm # mm mmm #mmm mmm mmmm 8 | # #" # #" # #" "# # #" "# 9 | # # # #"""" # # # # # 10 | "mm # # "#mm" ##m#" mm#mm "#m"# 11 | m # 12 | "" 13 | 14 | # " m 15 | mmm# mmm m mm mm#mm m m 16 | #" "# # #" " # "m m" 17 | # # # # # #m# 18 | "#m## mm#mm # "mm "# 19 | m" 20 | "" 21 | 22 | this file defines some macros for keeping track of 23 | pointers to lisp objects in C so that they can be properly 24 | referenced after a garbage collection 25 | */ 26 | 27 | /* frame pointer variable name*/ 28 | #define FP frame_pointer 29 | 30 | #define END_FRAME ((void *) -1) 31 | 32 | /* the ugly end of C */ 33 | 34 | #define LOCALS1(name1) \ 35 | void *locals_frame_[3] = {}; \ 36 | obj_t **name1 = (obj_t **)(locals_frame_ + 1); \ 37 | locals_frame_[0] = FP; \ 38 | locals_frame_[2] = END_FRAME; \ 39 | FP = locals_frame_; 40 | 41 | #define LOCALS2(name1, name2) \ 42 | void *locals_frame_[4] = {}; \ 43 | obj_t **name1 = (obj_t **)(locals_frame_ + 1); \ 44 | obj_t **name2 = (obj_t **)(locals_frame_ + 2); \ 45 | locals_frame_[0] = FP; \ 46 | locals_frame_[3] = END_FRAME; \ 47 | FP = locals_frame_; 48 | 49 | #define LOCALS3(name1, name2, name3) \ 50 | void *locals_frame_[5] = {}; \ 51 | obj_t **name1 = (obj_t **)(locals_frame_ + 1); \ 52 | obj_t **name2 = (obj_t **)(locals_frame_ + 2); \ 53 | obj_t **name3 = (obj_t **)(locals_frame_ + 3); \ 54 | locals_frame_[0] = FP; \ 55 | locals_frame_[4] = END_FRAME; \ 56 | FP = locals_frame_; 57 | 58 | #define LOCALS4(name1, name2, name3, name4) \ 59 | void *locals_frame_[6] = {}; \ 60 | obj_t **name1 = (obj_t **)(locals_frame_ + 1); \ 61 | obj_t **name2 = (obj_t **)(locals_frame_ + 2); \ 62 | obj_t **name3 = (obj_t **)(locals_frame_ + 3); \ 63 | obj_t **name4 = (obj_t **)(locals_frame_ + 4); \ 64 | locals_frame_[0] = FP; \ 65 | locals_frame_[5] = END_FRAME; \ 66 | FP = locals_frame_; 67 | 68 | #endif 69 | -------------------------------------------------------------------------------- /machine.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "util.h" 4 | #include "obj.h" 5 | #include "machine.h" 6 | 7 | vm_t *alloc_vm(size) 8 | size_t size; 9 | { 10 | vm_t *vm = calloc(1, sizeof (vm_t)); 11 | vm->semispace_size = size / OBJ_SIZE; 12 | vm->from_space = calloc(size, OBJ_SIZE); 13 | vm->to_space = calloc(size, OBJ_SIZE); 14 | vm->alloc_offset = 0; 15 | vm->to_space_offset = 0; 16 | vm->symbols = NULL; 17 | vm->global_bindings = NULL; 18 | return vm; 19 | } 20 | 21 | #if 0 22 | /* forward o to the to_space, and return where it ended up */ 23 | obj_t *forward(o) 24 | obj_t *o; 25 | { 26 | obj_t *ca, *cd; 27 | /* if it has already been moved, just return it */ 28 | if (STATE_FORWARDED == o->type) return o; 29 | switch (o->type) { 30 | case TNIL: 31 | case TTRUE: 32 | case TINT: 33 | case TSTRING: 34 | case TSYMBOL: 35 | case TPRIMITIVE: 36 | memcpy((void *)(VM->to_space + VM->to_space_offset), o, OBJ_SIZE); 37 | o->type = STATE_FORWARDED; 38 | o->value.new_location = VM->to_space + VM->to_space_offset; 39 | VM->to_space_offset++; 40 | return o->value.new_location; 41 | 42 | case TCONS: 43 | ca = CAR(o); 44 | cd = CDR(o); 45 | memcpy((void *)(VM->to_space + VM->to_space_offset), o, OBJ_SIZE); 46 | o->type = STATE_FORWARDED; 47 | o->value.new_location = VM->to_space + VM->to_space_offset; 48 | VM->to_space_offset++; 49 | CAR(o->value.new_location) = forward(ca); 50 | CDR(o->value.new_location) = forward(cd); 51 | return o->value.new_location; 52 | 53 | default: 54 | fuck("unknown type to forward"); 55 | } 56 | /* unreachable */ 57 | return NULL; 58 | } 59 | 60 | #endif 61 | 62 | void gc() { 63 | #if 0 64 | obj_t *tmp; 65 | size_t allocated = VM->alloc_offset; 66 | int i, j; 67 | obj_t **frame_pointer; 68 | 69 | fprintf(stderr, "\ngc start... "); 70 | 71 | /* traverse the constants */ 72 | fprintf(stderr, "c"); 73 | forward(nil); 74 | forward(tru); 75 | 76 | /* traverse stack */ 77 | fprintf(stderr, "S"); 78 | /* TODO */ 79 | 80 | /* traverse the symbols */ 81 | fprintf(stderr, "s"); 82 | VM->symbols = forward(VM->symbols); 83 | 84 | /* traverse the global bindings */ 85 | fprintf(stderr, "g"); 86 | VM->global_bindings = forward(VM->global_bindings); 87 | 88 | /* expunge and swap */ 89 | VM->alloc_offset = VM->to_space_offset; 90 | VM->to_space_offset = 0; 91 | memset(VM->from_space, 0, VM->semispace_size * OBJ_SIZE); 92 | tmp = VM->from_space; 93 | VM->from_space = VM->to_space; 94 | VM->to_space = VM->from_space; 95 | 96 | 97 | fprintf(stderr, " done: %zu -> %zu\n", allocated, VM->alloc_offset); 98 | #endif 99 | return; 100 | } 101 | -------------------------------------------------------------------------------- /machine.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #ifndef BNLISP_MACHINE_H 4 | #define BNLISP_MACHINE_H 5 | 6 | typedef struct vm { 7 | /* memory */ 8 | size_t semispace_size; 9 | obj_t *from_space; 10 | obj_t *to_space; 11 | size_t alloc_offset; 12 | size_t to_space_offset; 13 | /* symbol intern table - lisp list of symbols */ 14 | obj_t *symbols; 15 | /* global environment - lisp list of cons cells */ 16 | obj_t *global_bindings; 17 | } vm_t; 18 | 19 | #define FRAME_END ((obj_t *) (-1)) 20 | 21 | vm_t *alloc_vm(); 22 | void *forward(); 23 | void gc(); 24 | 25 | vm_t *VM; 26 | 27 | 28 | #endif /* BNLISP_MACHINE_H */ 29 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | OBJS = machine.o util.o alloc.o parser.o symbol.o env.o prim.o lisp.o 2 | CC = cc 3 | CFLAGS = 4 | 5 | lisp: ${OBJS} 6 | ${CC} -o lisp ${CFLAGS} ${OBJS} 7 | 8 | lisp.o: 9 | ${CC} ${CFLAGS} -c lisp.c 10 | 11 | machine.o: 12 | ${CC} ${CFLAGS} -c machine.c 13 | 14 | util.o: 15 | ${CC} ${CFLAGS} -c util.c 16 | 17 | parser.o: 18 | ${CC} ${CFLAGS} -c parser.c 19 | 20 | alloc.o: 21 | ${CC} ${CFLAGS} -c alloc.c 22 | 23 | symbol.o: 24 | ${CC} ${CFLAGS} -c symbol.c 25 | 26 | env.o: 27 | ${CC} ${CFLAGS} -c env.c 28 | 29 | prim.o: 30 | ${CC} ${CFLAGS} -c prim.c 31 | 32 | clean: 33 | rm -f lisp ${OBJS} 34 | @echo "Nice and clean." 35 | -------------------------------------------------------------------------------- /obj.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* Both TSOCKET and TSTREAM are handled with the same set of 4 | * primitives STREAM-*, but the type needs to be preserved 5 | * separately. 6 | */ 7 | 8 | typedef enum { 9 | /* states */ 10 | /* STATE_FORWARDED, */ 11 | /* types */ 12 | TNIL, 13 | TTRUE, 14 | TINT, 15 | TFLOAT, 16 | TCONS, 17 | TSTRING, 18 | TSYMBOL, 19 | TPRIMITIVE, 20 | TFUNCTION, 21 | TSOCKET, /* INET Socket Stream */ 22 | TSTREAM /* FILE stream */ 23 | } obj_type_t; 24 | 25 | /* function type: (obj **env, obj *args) -> obj *return */ 26 | /* args have not been evaluated */ 27 | typedef struct obj * (*primitive_t)(); 28 | 29 | typedef struct obj { 30 | int type; 31 | union { 32 | /* when the object moves during GC, it gets a new location */ 33 | /* struct obj *new_location; */ 34 | 35 | /* TINT and TSOCKET */ 36 | int i; 37 | 38 | /* TFLOAT */ 39 | float f; 40 | 41 | /* TSTRING */ 42 | char *str; 43 | 44 | /* TSTREAM pointer */ 45 | FILE *stream; 46 | 47 | /* symbols */ 48 | struct { 49 | char *name; 50 | } sym; 51 | 52 | /* cons cells */ 53 | struct { 54 | struct obj *car; 55 | struct obj *cdr; 56 | } c; 57 | 58 | /* primitive (C-implemented) functions */ 59 | struct { 60 | primitive_t code; 61 | } prim; 62 | 63 | /* functions*/ 64 | struct { 65 | struct obj *params; 66 | struct obj *body; 67 | struct obj *env; 68 | } fun; 69 | } value; 70 | } obj_t; 71 | 72 | 73 | 74 | 75 | #define OBJ_SIZE (sizeof (obj_t)) 76 | 77 | #define CAR(x) ((x)->value.c.car) 78 | #define CDR(x) ((x)->value.c.cdr) 79 | #define FIRST(x) CAR(x) 80 | #define SECOND(x) CAR(CDR(x)) 81 | #define THIRD(x) CAR(CDR(CDR(x))) 82 | #define REST(x) CDR(x) 83 | -------------------------------------------------------------------------------- /parser.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include "util.h" 8 | #include "obj.h" 9 | #include "alloc.h" 10 | #include "machine.h" 11 | #include "lisp.h" 12 | #include "symbol.h" 13 | #include "env.h" 14 | #include "parser.h" 15 | 16 | char *symbol_chars = "~!@#$%^&*-_=+:/?<>"; 17 | 18 | int whitespace(c) 19 | int c; 20 | { 21 | return (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 22 | } 23 | 24 | int peek() { 25 | int c = getc(stream_i); 26 | ungetc(c, stream_i); 27 | return c; 28 | } 29 | 30 | int peek_skipping_whitespace() { 31 | int peeked; 32 | for (;;) { 33 | peeked = peek(); 34 | if (whitespace(peeked)) { 35 | assert(whitespace(getc(stream_i))); 36 | } else { 37 | return peeked; 38 | } 39 | } 40 | } 41 | 42 | int getchar_skipping_whitespace() { 43 | for (;;) { 44 | if (whitespace(peek())) { 45 | assert(whitespace(getc(stream_i))); 46 | } else { 47 | return getc(stream_i); 48 | } 49 | } 50 | } 51 | 52 | /* reverse a list */ 53 | obj_t *reverse(p) 54 | obj_t *p; 55 | { 56 | obj_t *ret = nil; 57 | obj_t *head; 58 | while (nil != p) { 59 | head = p; 60 | p = CDR(p); 61 | CDR(head) = ret; 62 | ret = head; 63 | } 64 | return ret; 65 | } 66 | 67 | /* skip the rest of a line */ 68 | void skip_line() { 69 | int c; 70 | for (;;) { 71 | c = getc(stream_i); 72 | if (c == EOF || c == '\n') 73 | return; 74 | } 75 | } 76 | 77 | /* read a list, starting after a '(' has been read */ 78 | obj_t *read_list() { 79 | int peeked; 80 | obj_t *obj, *head, *last, *ret; 81 | head = nil; 82 | for (;;) { 83 | peeked = peek_skipping_whitespace(); 84 | if (EOF == peeked) fuck("unclosed parenthesis"); 85 | if (')' == peeked) { 86 | /* skip the paren */ 87 | (void)getc(stream_i); 88 | return reverse(head); 89 | } 90 | if ('.' == peeked) { 91 | /* skip the dot */ 92 | (void)getc(stream_i); 93 | last = read_sexp(); 94 | if (')' != getchar_skipping_whitespace()) 95 | fuck("closed parenthesis expected after dot"); 96 | ret = reverse(head); 97 | CDR(head) = last; 98 | return ret; 99 | } 100 | 101 | obj = read_sexp(); 102 | 103 | head = alloc_cons(obj, head); 104 | } 105 | } 106 | 107 | obj_t *read_string() { 108 | int escaped = 0; 109 | int c, i; 110 | char *s = (char*)malloc(STRING_MAX_LEN*sizeof(char)); 111 | 112 | for (i=0 ;; i++) { 113 | c = getc(stream_i); 114 | 115 | if ('\\' == c && !escaped) { /* ESCAPE CHARACTER */ 116 | escaped = 1; 117 | i--; 118 | continue; 119 | } else if ('"' == c && !escaped) { /* END OF STRING */ 120 | s[i] = '\0'; 121 | break; 122 | } else if ('"' == c && escaped) { /* ESCAPED DOUBLE QUOTE */ 123 | s[i] = c; 124 | } else if ('t' == c && escaped) { /* ESCAPED TAB */ 125 | s[i] = '\t'; 126 | } else if ('\\' == c && escaped) { /* ESCAPED BACKWARDS SLASH */ 127 | s[i] = '\\'; 128 | } else if ('n' == c && escaped) { /* Line feed */ 129 | s[i] = '\n'; 130 | } else if ('r' == c && escaped) { /* carriage return */ 131 | s[i] = '\r'; 132 | } else { 133 | s[i] = c; 134 | } 135 | escaped = 0; 136 | if (STRING_MAX_LEN == i) fuck("your string is too fucking long"); 137 | } 138 | 139 | return alloc_string(s); 140 | 141 | } 142 | 143 | /* translate 'x into (QUOTE x) */ 144 | obj_t *read_quote() { 145 | obj_t *sym, *tmp; 146 | sym = intern("QUOTE"); 147 | tmp = read_sexp(); 148 | tmp = alloc_cons(tmp, nil); 149 | tmp = alloc_cons(sym, tmp); 150 | return tmp; 151 | } 152 | 153 | /* read in a number, whose first digit is val */ 154 | obj_t *read_number(val) 155 | int val; 156 | { 157 | /* these two vars are only used if float */ 158 | float valf = 0; 159 | float d = 10; 160 | 161 | while (isdigit(peek())) 162 | val = 10 * val + (getc(stream_i) - '0'); 163 | if ('.' == peek()) { 164 | getc(stream_i); 165 | valf = (float)val; 166 | while (isdigit(peek())) { 167 | valf = valf + ((getc(stream_i) - '0') / d); 168 | d = d * 10; 169 | } 170 | return alloc_float(valf); 171 | } 172 | return alloc_int(val); 173 | } 174 | 175 | /* read in a symbol, whose first char is c */ 176 | obj_t *read_symbol(c) 177 | char c; 178 | 179 | { 180 | char buf[SYMBOL_MAX_LEN + 1]; 181 | int len = 1; 182 | buf[0] = c; 183 | while (isalnum(peek()) || strchr(symbol_chars, peek())) { 184 | if (SYMBOL_MAX_LEN <= len) 185 | fuck("symbol name too damn long"); 186 | buf[len++] = getc(stream_i); 187 | } 188 | buf[len] = '\0'; 189 | if (0 == strcmp(buf, "NIL")) { 190 | return nil; 191 | } else if (0 == strcmp(buf, "T")) { 192 | return tru; 193 | } else { 194 | return intern(strdup(buf)); 195 | } 196 | } 197 | 198 | obj_t *read_sexp() 199 | { 200 | int c; 201 | obj_t *o; 202 | for (;;) { 203 | c = getchar_skipping_whitespace(); 204 | if (c == EOF) { 205 | return NULL; 206 | } else if (c == ';') { 207 | skip_line(); 208 | } else if (c == '(') { 209 | return read_list(); 210 | } else if (c == ')' || c == '.') { 211 | fuck("unexpected dot or close paren"); 212 | } else if (c == '\'') { 213 | return read_quote(); 214 | } else if (isdigit(c)) { 215 | return read_number(c - '0'); 216 | } else if (c == '-' && isdigit(peek())) { 217 | o = read_number(0); 218 | if (TINT == o->type) 219 | o->value.i = -o->value.i; 220 | else if (TFLOAT == o->type) 221 | o->value.f = -o->value.f; 222 | return o; 223 | } else if (c == '"') { 224 | o = read_string(); 225 | return o; 226 | } else if (isalpha(c) || strchr(symbol_chars, c)) { 227 | return read_symbol(c); 228 | } else { 229 | fuck("don't know how to handle character"); 230 | } 231 | } 232 | } 233 | -------------------------------------------------------------------------------- /parser.h: -------------------------------------------------------------------------------- 1 | #ifndef BNLISP_PARSER_H 2 | #define BNLISP_PARSER_H 3 | 4 | #define SYMBOL_MAX_LEN 32 5 | #define STRING_MAX_LEN 128 6 | 7 | int whitespace(); 8 | int peek(); 9 | int peek_skipping_whitespace(); 10 | int getchar_skipping_whitespace(); 11 | obj_t *reverse(); 12 | void skip_lines(); 13 | obj_t *read_sexp(); 14 | obj_t *read_list(); 15 | obj_t *read_string(); 16 | obj_t *read_quote(); 17 | obj_t *read_number(); 18 | obj_t *read_symbol(); 19 | obj_t *read_sex(); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /prim.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "util.h" 12 | #include "obj.h" 13 | #include "machine.h" 14 | #include "alloc.h" 15 | #include "lisp.h" 16 | #include "env.h" 17 | #include "parser.h" 18 | #include "prim.h" 19 | 20 | obj_t *primitive_progn(env, body) 21 | obj_t **env, *body; 22 | { 23 | obj_t *ret; 24 | 25 | for ( ; nil != body; body = CDR(body)) { 26 | ret = eval(CAR(body), env); 27 | } 28 | 29 | return ret; 30 | } 31 | 32 | obj_t *primitive_quote(env, args) 33 | obj_t **env, *args; 34 | { 35 | return FIRST(args); 36 | } 37 | 38 | obj_t *primitive_lambda(env, args) 39 | obj_t **env, *args; 40 | { 41 | obj_t *params, *body; 42 | params = FIRST(args); 43 | body = REST(args); 44 | return alloc_function(params, body, *env); 45 | } 46 | 47 | obj_t *primitive_setq(env, args) 48 | obj_t **env, *args; 49 | { 50 | obj_t *entry, *var, *val; 51 | var = FIRST(args); 52 | assert(TSYMBOL == var->type); 53 | entry = lookup_env(*env, var); 54 | /* we do this before EVAL so recursion works */ 55 | if (!entry) { 56 | *env = push_env(*env, var, nil); 57 | entry = lookup_env(*env, var); 58 | } 59 | val = eval(SECOND(args), env); 60 | CDR(entry) = val; 61 | return val; 62 | } 63 | 64 | obj_t *primitive_if(env, args) 65 | obj_t **env, *args; 66 | { 67 | obj_t *cond = eval(args->value.c.car, env); 68 | if (nil != cond) 69 | return eval(SECOND(args), env); 70 | else 71 | return eval(THIRD(args), env); 72 | } 73 | 74 | obj_t *primitive_while(env, args) 75 | obj_t **env, *args; 76 | { 77 | obj_t *forms, *cond = FIRST(args); 78 | 79 | while (nil != eval(cond, env)) { 80 | for (forms = REST(args); nil != forms; forms = CDR(forms)) { 81 | eval(CAR(forms), env); 82 | } 83 | } 84 | return nil; 85 | } 86 | 87 | obj_t *primitive_add(env, args) 88 | obj_t **env, *args; 89 | { 90 | int sum = 0; 91 | float sumf = 0; 92 | obj_t *node, *node_val; 93 | 94 | for (node = args; node != nil; node = CDR(node)) { 95 | node_val = eval(CAR(node), env); 96 | 97 | if (TINT == node_val->type) 98 | sum += node_val->value.i; 99 | else if (TFLOAT == node_val->type) 100 | sumf += node_val->value.f; 101 | else 102 | fuck("can only add ints or floats"); 103 | } 104 | 105 | if (0 == sumf) 106 | return alloc_int(sum); 107 | else 108 | return alloc_float(sumf + sum); 109 | } 110 | 111 | obj_t *primitive_subtract(env, args) 112 | obj_t **env, *args; 113 | { 114 | obj_t *node, *node_val; 115 | int sum = 0; 116 | float sumf = 0; 117 | 118 | node = args; 119 | if (nil == node) 120 | return alloc_int(0); 121 | 122 | node_val = eval(CAR(node), env); 123 | if (TINT == node_val->type) 124 | sum += node_val->value.i; 125 | else if (TFLOAT == node_val->type) 126 | sumf += node_val->value.f; 127 | 128 | for (node = CDR(node); node != nil; node = CDR(node)) { 129 | node_val = eval(CAR(node), env); 130 | 131 | if (TINT == node_val->type) 132 | sum -= node_val->value.i; 133 | else if (TFLOAT == node_val->type) 134 | sumf -= node_val->value.f; 135 | else 136 | fuck("can only subtract ints or floats"); 137 | } 138 | 139 | if (0 == sumf) 140 | return alloc_int(sum); 141 | else 142 | return alloc_float(sumf + sum); 143 | } 144 | 145 | obj_t *primitive_multiply(env, args) 146 | obj_t **env, *args; 147 | { 148 | int prod = 1; 149 | float prodf = 1; 150 | obj_t *node, *node_val; 151 | 152 | for (node = args; node != nil; node = CDR(node)) { 153 | node_val = eval(CAR(node), env); 154 | 155 | if (TINT == node_val->type) 156 | prod = prod * node_val->value.i; 157 | else if (TFLOAT == node_val->type) 158 | prodf = prodf * node_val->value.f; 159 | else 160 | fuck("can only subtract ints or floats"); 161 | } 162 | 163 | if (0 == prodf) 164 | return alloc_int(prod); 165 | else 166 | if (prodf == prod) 167 | return alloc_int((int)prodf * prod); 168 | return alloc_float(prodf * prod); 169 | } 170 | 171 | obj_t *primitive_eval(env, args) 172 | obj_t **env, *args; 173 | { 174 | obj_t *eargs = evlis(args, env); 175 | return eval(FIRST(eargs), env); 176 | } 177 | 178 | obj_t *primitive_cons(env, args) 179 | obj_t **env, *args; 180 | { 181 | obj_t *eargs = evlis(args, env); 182 | return alloc_cons(FIRST(eargs), SECOND(eargs)); 183 | } 184 | 185 | obj_t *primitive_car(env, args) 186 | obj_t **env, *args; 187 | { 188 | obj_t *eargs = evlis(args, env); 189 | return CAR(FIRST(eargs)); 190 | } 191 | 192 | obj_t *primitive_cdr(env, args) 193 | obj_t **env, *args; 194 | { 195 | obj_t *eargs = evlis(args, env); 196 | return CDR(FIRST(eargs)); 197 | } 198 | 199 | obj_t *primitive_rplaca(env, args) 200 | obj_t **env, *args; 201 | { 202 | obj_t *eargs = evlis(args, env); 203 | 204 | CAR(FIRST(eargs)) = SECOND(eargs); 205 | return FIRST(eargs); 206 | } 207 | 208 | obj_t *primitive_rplacd(env, args) 209 | obj_t **env, *args; 210 | { 211 | obj_t *eargs = evlis(args, env); 212 | CDR(FIRST(eargs)) = SECOND(eargs); 213 | return FIRST(eargs); 214 | } 215 | 216 | obj_t *primitive_print(env, args) 217 | obj_t **env, *args; 218 | { 219 | obj_t *arg = eval(FIRST(args), env); 220 | print(arg); 221 | putchar('\n'); 222 | return arg; 223 | } 224 | 225 | obj_t *primitive_princ(env, args) 226 | obj_t **env, *args; 227 | { 228 | /* being lazy for now... wasn't working for printing string.. hm */ 229 | obj_t *e = eval(FIRST(args), env); 230 | if (TSTRING == e->type) 231 | printf("%s", e->value.str); 232 | else if (TINT == e->type) 233 | printf("%d", e->value.i); 234 | else if (TFLOAT == e->type) 235 | printf("%f", e->value.f); 236 | return e; 237 | } 238 | 239 | obj_t *primitive_all_symbols(env, args) 240 | obj_t **env, *args; 241 | { 242 | return VM->symbols; 243 | } 244 | 245 | obj_t *primitive_eq(env, args) 246 | obj_t **env, *args; 247 | { 248 | obj_t *a, *b; 249 | obj_t *eargs = evlis(args, env); 250 | a = FIRST(eargs); 251 | b = SECOND(eargs); 252 | 253 | /* type mismatch */ 254 | if (a->type != b->type) return nil; 255 | 256 | /* constants */ 257 | if (nil == a || tru == a) return tru; 258 | 259 | /* numbers */ 260 | if (TINT == a->type) 261 | return (a->value.i == b->value.i) ? tru : nil; 262 | if (TFLOAT == a->type) 263 | return (a->value.f == b->value.f) ? tru : nil; 264 | 265 | /* everything else */ 266 | return (a == b) ? tru : nil; 267 | } 268 | 269 | obj_t *primitive_number_equals(env, args) 270 | obj_t **env, *args; 271 | { 272 | obj_t *a, *b; 273 | obj_t *eargs = evlis(args, env); 274 | a = FIRST(eargs); 275 | b = SECOND(eargs); 276 | 277 | if (TINT == a->type && TINT == b->type) 278 | return (a->value.i == b->value.i) ? tru : nil; 279 | if (TFLOAT == a->type && TFLOAT == b->type) 280 | return (a->value.f == b->value.f) ? tru : nil; 281 | if (TFLOAT == a->type && TINT == b->type) 282 | return (a->value.f == b->value.i) ? tru : nil; 283 | if (TINT == a->type && TFLOAT == b->type) 284 | return (a->value.i == b->value.f) ? tru : nil; 285 | 286 | fuck("can't do = on non-numbers"); 287 | } 288 | 289 | obj_t *primitive_number_gt(env, args) 290 | obj_t **env, *args; 291 | { 292 | obj_t *a, *b; 293 | obj_t *eargs = evlis(args, env); 294 | a = FIRST(eargs); 295 | b = SECOND(eargs); 296 | if (TINT != a->type || TINT != b->type) fuck("can't do = on non-numbers"); 297 | 298 | return (a->value.i > b->value.i) ? tru : nil; 299 | } 300 | 301 | obj_t *primitive_string_equals(env, args) 302 | obj_t **env, *args; 303 | { 304 | obj_t *a, *b; 305 | obj_t *eargs = evlis(args, env); 306 | 307 | a = FIRST(eargs); 308 | b = SECOND(eargs); 309 | 310 | if (TSTRING != a->type || TSTRING != b->type) 311 | fuck("can't do STRING= on non-strings"); 312 | 313 | return (0 == strcmp(a->value.str, b->value.str)) ? tru : nil; 314 | } 315 | 316 | obj_t *primitive_not(env, args) 317 | obj_t **env, *args; 318 | { 319 | obj_t *eargs = evlis(args, env); 320 | return (nil == FIRST(eargs)) ? tru : nil; 321 | } 322 | 323 | obj_t *primitive_readchar(env, args) 324 | obj_t **env, *args; 325 | { 326 | char c = getchar(); 327 | char s[2]; 328 | s[0] = c; 329 | s[1] = '\0'; 330 | return alloc_string(s); 331 | } 332 | 333 | obj_t *primitive_read(env, args) 334 | obj_t **env, *args; 335 | { 336 | return read_sexp(); 337 | } 338 | 339 | obj_t *primitive_load(env, args) 340 | obj_t **env, *args; 341 | { 342 | char *path = CAR(args)->value.str; 343 | char c; 344 | FILE *fid = fopen(path, "r"); 345 | obj_t *form; 346 | 347 | if (NULL == fid) 348 | return nil; 349 | 350 | stream_i = fid; 351 | while (EOF != (c = fgetc(fid))) { 352 | ungetc(c, fid); 353 | /* putchar(c); */ 354 | form = read_sexp(); 355 | if (NULL != form) 356 | eval_form(form, &VM->global_bindings); 357 | } 358 | stream_i = stdin; 359 | 360 | fclose(fid); 361 | 362 | return tru; 363 | } 364 | 365 | obj_t *primitive_concatenate(env, args) 366 | obj_t **env, *args; 367 | { 368 | obj_t *a, *b; 369 | char *s, *type; 370 | obj_t *eargs = evlis(args,env); 371 | 372 | if (CAR(CAR(args))->type != TSYMBOL || 373 | 0 != strcmp("QUOTE", CAR(CAR(args))->value.str)) 374 | fuck("concatenate must specify type"); 375 | 376 | a = SECOND(eargs); 377 | b = THIRD(eargs); 378 | 379 | type = CAR(eargs)->value.str; 380 | if (0 == strcmp(type, "STRING")) { /* CONCAT STRING */ 381 | s = (char*)malloc((strlen(a->value.str)+ 382 | strlen(b->value.str)+ 383 | 1)*sizeof(char)); 384 | strcat(s, a->value.str); 385 | strcat(s, b->value.str); 386 | return alloc_string(s); 387 | } else if (0 == strcmp(type, "LIST")) { /* CONCAT LIST */ 388 | fuck("not yet implemented"); 389 | } 390 | 391 | return tru; 392 | } 393 | 394 | 395 | /********************************************************************/ 396 | /* STREAMS and SOCKETS */ 397 | /********************************************************************/ 398 | 399 | /* (STREAM-OPEN 'FILE path) 400 | (STREAM-OPEN 'TCP host port) 401 | (STREAM-OPEN 'UDP host port) 402 | */ 403 | obj_t *primitive_stream_open(env, args) 404 | obj_t **env, *args; 405 | { 406 | char *type; 407 | obj_t *eargs; 408 | 409 | FILE *stream; 410 | int sock; 411 | struct sockaddr_in sock_addr; 412 | struct hostent *sock_server; 413 | 414 | eargs = evlis(args, env); 415 | 416 | if (CAR(CAR(args))->type != TSYMBOL || 417 | 0 != strcmp("QUOTE", CAR(CAR(args))->value.str)) { 418 | fuck("must specify file, tcp or udp"); 419 | } 420 | 421 | type = CAR(eargs)->value.str; 422 | if (0 == strcmp(type, "FILE")) { 423 | stream = fopen(SECOND(eargs)->value.str, "ab+"); 424 | if (NULL == stream) { 425 | return nil; 426 | } 427 | return alloc_stream(stream); 428 | } else if (0 == strcmp(type, "TCP")) { 429 | sock = socket(AF_INET, SOCK_STREAM, 0); 430 | sock_server = gethostbyname(SECOND(eargs)->value.str); 431 | if (NULL == sock_server) 432 | fuck("No such host"); 433 | 434 | bzero((char*)&sock_addr, sizeof(sock_addr)); 435 | sock_addr.sin_family = AF_INET; 436 | bcopy((char*)sock_server->h_addr, 437 | (char*)&sock_addr.sin_addr.s_addr, 438 | sock_server->h_length); 439 | sock_addr.sin_port = htons(THIRD(eargs)->value.i); 440 | 441 | if (connect(sock, (struct sockaddr *)&sock_addr, 442 | sizeof(struct sockaddr)) < 0) 443 | fuck("could not connect to host"); 444 | 445 | return alloc_socket(sock); 446 | 447 | } else if (0 == strcmp(type, "UDP")) { 448 | 449 | } else { 450 | fuck("Only supported streams are FILE, TCP, UDP"); 451 | } 452 | 453 | return nil; 454 | } 455 | 456 | /* (STREAM-CLOSE stream) */ 457 | obj_t *primitive_stream_close(env, args) 458 | obj_t **env, *args; 459 | { 460 | obj_t *s = evlis(args, env); 461 | if (TSTREAM == CAR(s)->type) { 462 | fclose(CAR(s)->value.stream); 463 | return tru; 464 | } else if (TSOCKET == CAR(s)->type) { 465 | close(CAR(s)->value.i); 466 | return tru; 467 | } else { 468 | fuck("That's not a stream or a socket!"); 469 | } 470 | } 471 | 472 | /* (STREAM-READ stream) */ 473 | obj_t *primitive_stream_read(env, args) 474 | obj_t **env, *args; 475 | { 476 | char c[2]; 477 | obj_t *s = evlis(args, env); 478 | 479 | if (TSTREAM == CAR(s)->type) { 480 | c[0] = fgetc(CAR(s)->value.stream); 481 | c[1] = 0; 482 | return alloc_string(c); 483 | } else if (TSOCKET == CAR(s)->type) { 484 | if (read(CAR(s)->value.i, c, 1) <= 0) { 485 | return nil; 486 | } 487 | c[1] = 0; 488 | 489 | return alloc_string(c); 490 | } else { 491 | fuck("That is not a stream or a socket!"); 492 | } 493 | } 494 | 495 | /* (STREAM-WRITE stream string) */ 496 | obj_t *primitive_stream_write(env, args) 497 | obj_t **env, *args; 498 | { 499 | obj_t *s = evlis(args, env); 500 | 501 | if (TSTREAM == CAR(s)->type) { 502 | fprintf(CAR(s)->value.stream, 503 | CAR(CDR(s))->value.str); 504 | return tru; 505 | } else if (TSOCKET == CAR(s)->type) { 506 | write(CAR(s)->value.i, 507 | CAR(CDR(s))->value.str, 508 | strlen(CAR(CDR(s))->value.str)); 509 | return tru; 510 | } else { 511 | fuck("That is not a stream or a socket!"); 512 | } 513 | } 514 | 515 | 516 | /* (STREAM-EOF? stream) */ 517 | obj_t *primitive_stream_iseof(env, args) 518 | obj_t **env, *args; 519 | { 520 | char c; 521 | obj_t *s = evlis(args, env); 522 | if (TSTREAM == CAR(s)->type) { 523 | c = getc(CAR(s)->value.stream); 524 | ungetc(c, CAR(s)->value.stream); 525 | return c == EOF ? tru : nil; 526 | } else if (TSOCKET == CAR(s)->type) { 527 | return tru; /* always true, no eof */ 528 | } else { 529 | fuck("That is not a stream or a socket!"); 530 | } 531 | } 532 | -------------------------------------------------------------------------------- /prim.h: -------------------------------------------------------------------------------- 1 | #ifndef BNLISP_PRIM_H 2 | #define BNLISP_PRIM_H 3 | 4 | obj_t *primitive_progn(); 5 | obj_t *primitive_quote(); 6 | obj_t *primitive_lambda(); 7 | obj_t *primitive_setq(); 8 | obj_t *primitive_if(); 9 | obj_t *primitive_while(); 10 | obj_t *primitive_add(); 11 | obj_t *primitive_subtract(); 12 | obj_t *primitive_multiply(); 13 | obj_t *primitive_eval(); 14 | obj_t *primitive_cons(); 15 | obj_t *primitive_car(); 16 | obj_t *primitive_cdr(); 17 | obj_t *primitive_rplaca(); 18 | obj_t *primitive_rplacd(); 19 | obj_t *primitive_print(); 20 | obj_t *primitive_princ(); 21 | obj_t *primitive_all_symbols(); 22 | obj_t *primitive_eq(); 23 | obj_t *primitive_number_equals(); 24 | obj_t *primitive_number_gt(); 25 | obj_t *primitive_string_equals(); 26 | obj_t *primitive_not(); 27 | obj_t *primitive_readchar(); 28 | obj_t *primitive_read(); 29 | obj_t *primitive_load(); 30 | obj_t *primitive_concatenate(); 31 | obj_t *primitive_stream_open(); 32 | obj_t *primitive_stream_close(); 33 | obj_t *primitive_stream_read(); 34 | obj_t *primitive_stream_write(); 35 | obj_t *primitive_stream_iseof(); 36 | #endif 37 | 38 | -------------------------------------------------------------------------------- /symbol.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include "obj.h" 6 | #include "alloc.h" 7 | #include "machine.h" 8 | #include "lisp.h" 9 | #include "symbol.h" 10 | 11 | obj_t *find_symbol(name) 12 | char *name; 13 | { 14 | obj_t *entry, *table, *val; 15 | for (table = VM->symbols; nil != table; table = CDR(table)) { 16 | entry = CAR(table); 17 | assert(TSYMBOL == entry->type); 18 | if (0 == strcmp(entry->value.sym.name, name)) { 19 | return entry; 20 | } 21 | } 22 | return NULL; 23 | } 24 | 25 | obj_t *alloc_symbol(name) 26 | char *name; 27 | { 28 | obj_t *x; 29 | x = alloc_obj(TSYMBOL); 30 | x->value.sym.name = name; 31 | return x; 32 | } 33 | 34 | obj_t *intern(name) 35 | char *name; 36 | { 37 | obj_t *x; 38 | x = find_symbol(name); 39 | if (!x) { 40 | x = alloc_symbol(name); 41 | VM->symbols = alloc_cons(x, VM->symbols); 42 | } 43 | return x; 44 | } 45 | 46 | int proper_list_p(o) 47 | obj_t * o; 48 | { 49 | if (nil == o) return 1; 50 | if (TCONS != o->type) return 0; 51 | return proper_list_p(CDR(o)); 52 | } 53 | 54 | int list_length(o) 55 | obj_t * o; 56 | { 57 | /* assumes that o is a proper list */ 58 | obj_t * node; 59 | int len = 0; 60 | for (node = o; node != nil; node = node->value.c.cdr) len++; 61 | return len; 62 | } 63 | -------------------------------------------------------------------------------- /symbol.h: -------------------------------------------------------------------------------- 1 | obj_t *find_symbol(); 2 | obj_t *alloc_symbol(); 3 | obj_t *intern(); 4 | 5 | /* These probably need to be moved somewhere. */ 6 | int proper_list_p(); 7 | int list_length(); 8 | -------------------------------------------------------------------------------- /util.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "util.h" 5 | 6 | void fuck(msg) 7 | char * msg; 8 | { 9 | printf("fuck: %s\n", msg); 10 | exit(1); 11 | } 12 | -------------------------------------------------------------------------------- /util.h: -------------------------------------------------------------------------------- 1 | 2 | void fuck(); 3 | --------------------------------------------------------------------------------