├── Documentation.md ├── Makefile ├── Overview.text ├── README ├── bless ├── boot-terp ├── Makefile ├── clump ├── driver.awk ├── lump.c └── t ├── examples └── datatype_idiom │ ├── Makefile │ ├── README │ ├── generate_code.scm │ └── list_of_trees.scm ├── ichbins.c ├── ichbins.scm ├── notes.text └── tests ├── 0.in ├── 0.l ├── 0.ref ├── 1.in ├── 1.l ├── 1.ref ├── 2.in ├── 2.l ├── 2.ref ├── 3.in ├── 3.l ├── 3.ref ├── 4.in ├── 4.l ├── 4.ref ├── 5.in ├── 5.l ├── 5.ref ├── 6.in ├── 6.l ├── 6.ref ├── 7.in ├── 7.l ├── 7.ref ├── complain ├── testall └── testone /Documentation.md: -------------------------------------------------------------------------------- 1 | # The language 2 | 3 | Ichbins implements (and is written in) a dialect of Lisp, looking most 4 | like Scheme on the surface, but drastically cut down. In this writeup 5 | I'll assume you're already familiar with Lisp or Scheme. 6 | 7 | 8 | ## Datatypes 9 | 10 | In Ichbins there are just two basic datatypes: characters and lists. As 11 | written in an s-expression, a character looks like `\x`, while a list has 12 | the usual Lisp syntax. For instance, `((\h \e \l \l \o) (\w \o \r \l \d))` is 13 | a list of two lists of characters. 14 | 15 | A list of characters can also be written more compactly as a 16 | double-quoted string: `("hello" "world")` is the same list of lists, 17 | just in different notation. 18 | 19 | Ichbins also has a notion of symbols, but unlike classical Lisp 20 | symbols they're not distinct from strings. `(hello world)` is *also* a 21 | list of two strings (and thus a list of two lists of 22 | characters). What's different is that those two strings are 23 | 'interned': they're registered in the system's table of symbols. The 24 | predicate `(symbol? x)` checks if *x* is in that table. So, `(car 25 | 'hello)` evaluates to `\h`, the first character of `"hello"`, because 26 | the symbol `hello` is also the string `"hello"`. 27 | 28 | Why such a silly design? Because the fewer the datatypes, the less 29 | code to implement them. For this project I'm favoring any tradeoff that would yield 30 | less code, unless it would give up readability. What was given up in 31 | this case, in choosing to minimize the datatypes, was more like 32 | writability: it became easier to screw up. (Of course this fragility 33 | hurts *adversarial* readability, but we're going to assume you trust 34 | the author.) 35 | 36 | Finally, for the same reason of parsimony, a boolean value is 37 | represented as a symbol: `f` for false, `t` for true. 38 | 39 | Symbols are case-sensitive. 40 | 41 | 42 | ## Read syntax 43 | 44 | Ichbins's reader doesn't support dotted pairs. It does expand `'foo` 45 | into `(quote foo)`. 46 | 47 | Strings can include escape sequences, but only `\\` and `\"` are 48 | useful. 49 | 50 | Even comments are not supported. (If desperate, you can fake them with 51 | literal strings.) 52 | 53 | 54 | ## Expressions 55 | 56 | Expressions are like any Lisp's: 57 | 58 | - `(quote foo)` --> `foo` 59 | - `variable` --> the value bound to `variable` 60 | - `(f x y)`: call function `f` with the values of `x` and `y` 61 | - `(cond (p1 e1) (p2 e2) ...)`: as usual, evaluate `p1`, and unless it's 62 | false return the value of `e1`; or if it is false then continue with 63 | `p2` and `e2`, etc. (You can have any number of `e`'s in each 64 | clause, actually; the result is the value of the last one.) 65 | 66 | The `(f x y)` expressions are distinguished by `f` being a symbol 67 | other than `quote` or `cond`. Ichbins is a first-order language: there 68 | are no lambda expressions. 69 | 70 | An expression of any other form -- for example, the string `"hey"` -- 71 | is treated as a constant. 72 | 73 | 74 | ## Programs 75 | 76 | A program is a sequence of top-level forms. A top-level form is a 77 | variable definition, a procedure definition, or an expression. Here's 78 | one program: 79 | 80 | ``` 81 | (define noun "Ich") 82 | (define verb "bins") 83 | (to (say chars) 84 | (cond ((pair? chars) 85 | (write-char (car chars)) 86 | (say (cdr chars))))) 87 | (say noun) 88 | (say " ") 89 | (say verb) 90 | ``` 91 | 92 | So variable definitions look like Scheme's; so do procedure 93 | definitions but with `to` in place of `define`. A procedure's body may 94 | be a sequence of expressions, not just one. (As with `cond` clauses, 95 | the return value of a sequence is the value of its last expression.) 96 | 97 | To run a program: 98 | 99 | - First collect all the procedure definitions, associating each 100 | procedure name with its parameters and body. 101 | - Collect all the global variable definitions, and evaluate them in 102 | order. (If one of them refers to one not yet defined, that's 103 | undefined behavior, which in practice may blow up the process.) 104 | - Evaluate each of the top-level expressions in order. 105 | 106 | 107 | ## Primitives 108 | 109 | These procedures are built in: 110 | 111 | - `eq?` 112 | - `null?`, `char?`, `pair?` 113 | - `cons`, `car`, `cdr`, `set-car!` 114 | - `write-char`, `read-char`, `peek-char` 115 | - `abort` (like C's `exit(1)`) 116 | 117 | There are no I/O port objects: `write-char` writes to stdout, 118 | `read-char` reads from stdin. 119 | 120 | The value of `(read-char)` is either a character or `f` (false) for 121 | end-of-file. 122 | 123 | Like Scheme's, `peek-char` acts like `read-char` but without consuming 124 | the next character. (Or like `getchar()` plus `ungetc()` in C.) 125 | 126 | 127 | # The bootstrap interpreter 128 | 129 | To start the cycle of life there was an interpreter in C, in 130 | `boot-terp/`. It's unmaintained now; I might someday go back to make 131 | sure it can still build the compiler. (XXX There's at least one update 132 | needed: end-of-file is signaled differently in boot-terp than in the 133 | compiler's language.) 134 | 135 | In `boot-terp/t` is a sequence of unit tests for the interpreter, 136 | which might be of use to clarify the above language spec. It can be 137 | run via `make test`. 138 | 139 | 140 | # Example programs 141 | 142 | TODO remark on examples/ and tests/ 143 | 144 | 145 | # An example of compilation 146 | 147 | Before we cover the compiler's source code, let's get an impression of 148 | the C code it will generate for an Ichbins program. This program 149 | writes `((\H \i) (\M \o \m))`, exercising all the form and expression 150 | types: 151 | 152 | ``` 153 | (to (write x) 154 | (cond ((char? x) (write-char \\) (write-char x)) 155 | ('t (write-char \() 156 | (cond ((pair? x) 157 | (write (car x)) 158 | (write-each (cdr x)))) 159 | (write-char \))))) 160 | 161 | (to (write-each xs) 162 | (cond ((null? xs) 'f) 163 | ('t (write-char \ ) 164 | (write (car xs)) 165 | (write-each (cdr xs))))) 166 | 167 | (define message '("Hi" "Mom")) 168 | (write message) 169 | ``` 170 | 171 | Here's its compiled C code, slightly out of order and reformatted, plus 172 | comments, for the sake of exposition: 173 | 174 | ``` 175 | int main() { run(NULL, 0); return 0; } 176 | ``` 177 | 178 | All of the above program becomes the `run` function in C, starting 179 | with initialization: 180 | 181 | ``` 182 | // Call a compiled function, given its arguments on the stack starting at 183 | // stack[bp]. (Or if function==NULL, then run the whole program.) 184 | // The `function` is represented by a label pointer (a feature of GNU 185 | // C, not standard C). 186 | void run(void **function, int bp) { 187 | if (function) goto *function; 188 | 189 | // First set up the stack, heap, and global variables: 190 | 191 | push(entag(a_char, 't')); 192 | push(nil); 193 | prim2_cons(); 194 | assert(var_Dt == sp); // Now stack[var_Dt] holds the symbol `t` 195 | 196 | push(entag(a_char, 'f')); 197 | push(nil); 198 | prim2_cons(); 199 | assert(var_Df == sp); // Now stack[var_Dt] holds the symbol `f` 200 | 201 | push(entag(a_char, 'H')); 202 | push(entag(a_char, 'i')); 203 | push(nil); 204 | prim2_cons(); 205 | prim2_cons(); 206 | push(entag(a_char, 'M')); 207 | push(entag(a_char, 'o')); 208 | push(entag(a_char, 'm')); 209 | push(nil); 210 | prim2_cons(); 211 | prim2_cons(); 212 | prim2_cons(); 213 | push(nil); 214 | prim2_cons(); 215 | prim2_cons(); 216 | assert(var_message == sp); // Now stack[var_message] holds `("Hi Mom")` 217 | 218 | // Then perform the top-level expressions: 219 | bp = sp + 1; goto proc_main; 220 | 221 | proc_main: { 222 | assert(0 == sp - bp + 1); 223 | // Perform `(write message)`: 224 | push(stack[var_message]); 225 | TAILCALL(proc_write, 1); 226 | } 227 | ``` 228 | 229 | 230 | 231 | 232 | # The compiler 233 | 234 | TODO flesh out from Overview.text 235 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS = -g2 -Wall -W 2 | 3 | all: ichbins ichbins2 4 | 5 | clean: 6 | rm -f ichbins ichbins2* ichbins3* *.o tests/?.c tests/? tests/?.out 7 | 8 | ichbins: ichbins.o 9 | 10 | ichbins2: ichbins2.o 11 | 12 | ichbins2.c: ichbins ichbins.scm 13 | ./ichbins ichbins2.c 14 | -------------------------------------------------------------------------------- /Overview.text: -------------------------------------------------------------------------------- 1 | Data types: 2 | Rationale: 3 | The more data types, the more code. 4 | Basic: 5 | character 6 | () 7 | pair (x . y) 8 | Derived: 9 | A string is a list of characters. 10 | A symbol is a string that happens to be on the intern list. 11 | Predicates return one of the symbols t and f. 12 | cond checks for f as false, anything else as true. 13 | 14 | Lexical syntax: 15 | No comments. This starts to show how minimal we're getting. 16 | List structure like a subset of Scheme, except: 17 | * Case-sensitive symbols 18 | * A character literal is written \x 19 | 20 | Syntax: 21 | program = form* 22 | form = (define name expr) 23 | | (to (name arg*) expr*) 24 | | expr 25 | expr = (quote s-expression) 26 | | (cond (expr expr*)*) 27 | | (symbol expr*) 28 | | symbol 29 | | other-s-expression 30 | 31 | Semantics: 32 | The usual Lisp eval, with tail call as jump with arguments. 33 | (to (f x) foo) is like Scheme's (define (f x) foo). 34 | Primitives: 35 | eq? 36 | null? char? pair? 37 | cons car cdr set-car! 38 | write-char read-char peek-char 39 | abort 40 | 41 | Implementation: 42 | Bootstrap interpreter in C. 43 | Test driver. 44 | (Does the system still run on it?) 45 | Compiler in Ichbins. 46 | Mechanics: 47 | "Standard library" 48 | Usual utilities 49 | Symbol table -- our one use of assignment. 50 | Explain why we need primitives initially in symbol table. 51 | Reader (no s-expression writer) 52 | Some conventions: 53 | e = expression 54 | k = the remainder of the compiled code, which we'll cons onto 55 | syms = symbol table (a mutable list of symbols) 56 | Collect constants, symbols, defs, top-level expressions. 57 | Re-express constants as calls to primitives. 58 | Re-express refs to them as refs to a new global variable. 59 | Turn top-level expressions into a (main) function. 60 | Compile functions. 61 | Lisp symbols to C identifiers. 62 | How do we manage without arithmetic? 63 | Punt to the C compiler. 64 | Also, bp points to base of stack frame. 65 | Runtime system in C incorporated literally as a string. 66 | Heap, stack, data representation. 67 | Stack-centric code because GC needs to know all the roots. 68 | Mark-and-lazy-sweep garbage collector. 69 | Calls and jumps. 70 | System needs t and f symbols at the bottom of the stack. 71 | Global variables get pushed after. 72 | N.B. it's possible to reference a global before it's defined, 73 | with dire consequences -- an unsound implementation in this 74 | one respect. 75 | Tracebacks are vaguely useful in gdb. 76 | Testing and bootstrapping changes. 77 | Performance. 78 | 79 | Usability, or shortage thereof. 80 | The overlapping datatypes make errors less immediate. 81 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ICHBINS 2 | 3 | This is a self-hosting compiler of a Lisp dialect to C in 6 pages of 4 | code. I've tried to make it as simple as possible, with almost no 5 | concessions to performance or extra functionality -- it's meant to be 6 | educational rather than useful. 7 | 8 | 9 | QUICK START 10 | 11 | $ git clone git@github.com:darius/ichbins.git 12 | (Or get a tarball from http://github.com/darius/ichbins) 13 | $ cd ichbins 14 | $ make 15 | 16 | To compile a program named foo.scm and then run it: 17 | $ ./ichbins foo.c 18 | $ cc foo.c -o foo 19 | $ ./foo 20 | 21 | There's a sketchy overview of the language and system in Overview.text. 22 | 23 | To make a change to the compiler and rebuild it, just typing 'make' 24 | isn't sufficient because of the circular dependency. 'make' will build 25 | an executable named ichbins2, compiling the current source with the 26 | previous executable. To replace that executable, type './bless', which 27 | does two tests: 28 | 29 | * That the tests in the tests/ directory pass. 30 | 31 | * That the old and new versions of the compiler executable produce 32 | the same C output from the compiler source. This test typically 33 | passes for routine changes to the source, but it's perfectly OK 34 | for it to fail; you should just be sure you can say why this case 35 | is expected. Then do 'mv ichbins2 ichbins' by hand and do ./bless 36 | again; this time it must pass, or something's buggered. 37 | 38 | The Lisp dialect implemented here is documented in Documentation.md. 39 | 40 | 41 | MOTIVATION 42 | 43 | I'm a nut who wants to grow a beautiful wholeness from tiny beginnings. 44 | This is a rewrite of 'icbins', which had the same larger goal in mind 45 | but a more immediate focus on playing with bootstrapping. 46 | 47 | Direct influences include: 48 | 49 | Steele & Sussman, "The Art of the Interpreter" 50 | http://library.readscheme.org/page1.html 51 | 52 | Marc Feeley, "Scheme in 90 Minutes" 53 | http://www.iro.umontreal.ca/~boucherd/mslug/meetings/20041020/minutes-en.html 54 | (which compiles a more powerful Scheme subset, but is longer and not 55 | self-hosting) 56 | 57 | The name 'ichbins' could stand for "I Can Hardly Believe It's Not Scheme!" 58 | 59 | See also https://github.com/darius/elv for a more featureful descendant. 60 | 61 | 62 | THANKS 63 | 64 | To Johnicholas Hines for example code. 65 | 66 | To Manuel Simoni and Kragen Sitaker for feedback. 67 | 68 | 69 | LICENSE & CONTACT 70 | 71 | Copyright 2007 Darius Bacon under the terms of the MIT X license 72 | found at http://www.opensource.org/licenses/mit-license.html 73 | 74 | Darius Bacon 75 | -------------------------------------------------------------------------------- /bless: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | make && 4 | 5 | (cd tests; ./testall ../ichbins2) && 6 | 7 | ./ichbins2 ichbins3.c && 8 | diff -u ichbins2.c ichbins3.c && 9 | 10 | mv ichbins2 ichbins 11 | -------------------------------------------------------------------------------- /boot-terp/Makefile: -------------------------------------------------------------------------------- 1 | # Some optional sanity checking: 2 | #CC = clang 3 | #SANITIZE = -fsanitize=address 4 | #SANITIZE = -fsanitize=undefined 5 | SANITIZE = 6 | 7 | CFLAGS = -g2 -Wall -W $(SANITIZE) 8 | LDFLAGS = $(SANITIZE) 9 | 10 | all: lump 11 | 12 | lump: lump.o 13 | 14 | test: all 15 | awk -f driver.awk t 16 | 17 | clean: 18 | rm -f tmp.c *.o lump input output 19 | -------------------------------------------------------------------------------- /boot-terp/clump: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Usage: clump outfile sourcefiles 3 | # Compile sourcefiles into an executable named outfile. 4 | 5 | outfile=${1} 6 | shift 7 | 8 | ./lump ../ichbins.scm "$@" | awk ' 9 | NR == 1 && /^=/ { $1 = ""; } 10 | /^f$/ { $1 = ""; } 11 | { print; } 12 | ' >tmp.c 13 | 14 | gcc -g2 -Wall tmp.c -o ${outfile} 15 | -------------------------------------------------------------------------------- /boot-terp/driver.awk: -------------------------------------------------------------------------------- 1 | /^;/ { next; } 2 | /^[ \t\r]*$/ { if ("" == action) next; } 3 | 4 | /^' / { # ' 5 | start("'"); input = $0; next; } 6 | /^- / { start("-"); input = substr($0, 3); next; } 7 | /^[*] / { expected = vert(expected, substr($0, 3)); next; } 8 | 9 | /^[=!] / { expect($0, run_on(input)); input = action = ""; next; } 10 | 11 | { input = input "\n" $0 } 12 | 13 | function start(c) 14 | { 15 | expected = ""; 16 | if ("" != input) { 17 | print "unused input"; 18 | exit(1); 19 | } 20 | action = c; 21 | } 22 | 23 | function run_on(input) 24 | { 25 | print input >"input"; 26 | close("input") 27 | system("./lump output"); 28 | return trim(snarf("output")); 29 | } 30 | 31 | function expect(expected_last, output, prefix) 32 | { 33 | prefix = substr(expected_last, 1, 2); 34 | expected_last = substr(expected_last, 3); 35 | expected = prefix vert(expected, expected_last); 36 | if (expected !~ /\n/) 37 | gsub(/\n/, "~", output); 38 | if (output != expected) { 39 | printf("%d: mismatch: %s\n", NR, output); 40 | printf("%d: expected: %s\n", NR, expected); 41 | } 42 | } 43 | 44 | function vert(line1, line2) 45 | { 46 | if (line1 == "") return line2; 47 | return line1 "\n" line2; 48 | } 49 | 50 | function trim(s) 51 | { 52 | if (0 < length(s) && substr(s, length(s), 1) == "\n") 53 | s = substr(s, 1, length(s) - 1); 54 | return s; 55 | } 56 | 57 | function snarf(file, result, line) 58 | { 59 | result = ""; 60 | while (getline line 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | static char input[64*1024]; 9 | static char *snarfing = input; 10 | static const char *in = input; 11 | 12 | static char output[1024*1024]; 13 | static char *out = output; 14 | 15 | typedef struct { 16 | unsigned row; 17 | unsigned column; 18 | } Position; 19 | 20 | static Position 21 | make_position (unsigned row, unsigned column) 22 | { 23 | Position p = { row, column }; 24 | return p; 25 | } 26 | 27 | static Position 28 | where (const char *at) 29 | { 30 | unsigned r = 1; 31 | unsigned c = 1; 32 | const char *s = input; 33 | for (; s < at; ++s) 34 | if ('\n' == *s) 35 | ++r, c = 1; 36 | else 37 | ++c; 38 | return make_position (r, c); 39 | } 40 | 41 | static void 42 | stdlib_error (const char *plaint) 43 | { 44 | fprintf (stderr, "%s: %s\n", plaint, strerror (errno)); 45 | exit (1); 46 | } 47 | 48 | static void 49 | panic (const char *complaint) 50 | { 51 | Position p = where (in); 52 | printf ("! %u:%u: %s\n", p.row, p.column, complaint); 53 | exit (1); 54 | } 55 | 56 | static void traceback (void); 57 | 58 | static void 59 | traceback_error (const char *plaint) 60 | { 61 | if (output != plaint) strcpy (output, plaint); 62 | out = output + strlen (plaint); 63 | *out++ = '\n'; 64 | traceback (); 65 | *out++ = '\0'; 66 | panic (output); 67 | } 68 | 69 | static void 70 | error (const char *plaint) 71 | { 72 | traceback_error (plaint); 73 | } 74 | 75 | static void 76 | insist (int ok, const char *violation) 77 | { 78 | if (!ok) 79 | traceback_error (violation); 80 | } 81 | 82 | static int 83 | get_input (FILE *infile) 84 | { 85 | if (NULL == fgets (snarfing, input + sizeof input - snarfing, infile)) 86 | return 0; 87 | snarfing += strlen (snarfing); 88 | return 1; 89 | } 90 | 91 | static void 92 | snarf (FILE *infile) 93 | { 94 | while (get_input (infile)) 95 | ; 96 | } 97 | 98 | typedef unsigned obj; 99 | 100 | enum { a_pair = 0, nil, a_char }; 101 | 102 | static unsigned 103 | get_tag (obj x) 104 | { 105 | return 3 & x; 106 | } 107 | 108 | static unsigned 109 | untag (unsigned tag, obj x) 110 | { 111 | #if 1 112 | /* assert (tag == get_tag (x)); */ 113 | insist (tag == get_tag (x), "Bad type"); 114 | #else 115 | if (tag != get_tag (x)) 116 | { 117 | *out = '\0'; 118 | fprintf (stderr, "output: %s\n", output); 119 | fprintf (stderr, "tag %d; expected %d\n", get_tag (x), tag); 120 | error ("Bad tag"); 121 | } 122 | #endif 123 | return x >> 2; 124 | } 125 | 126 | static obj 127 | entag (unsigned tag, unsigned value) 128 | { 129 | return tag | (value << 2); 130 | } 131 | 132 | static obj 133 | make_char (char c) 134 | { 135 | return entag (a_char, c); 136 | } 137 | 138 | static char 139 | char_value (obj x) 140 | { 141 | return untag (a_char, x); 142 | } 143 | 144 | enum { heap_size = 50*1024*1024 }; 145 | static obj heap[heap_size][2]; 146 | static unsigned heap_ptr = 0; 147 | 148 | static obj 149 | cons (obj car, obj cdr) 150 | { 151 | assert (heap_ptr < heap_size); 152 | heap[heap_ptr][0] = car; 153 | heap[heap_ptr][1] = cdr; 154 | return entag (a_pair, heap_ptr++); 155 | } 156 | 157 | static obj 158 | car (obj x) 159 | { 160 | unsigned p = untag (a_pair, x); 161 | assert (p < heap_ptr); /* XXX heap_size, once we have gc */ 162 | return heap[p][0]; 163 | } 164 | 165 | static obj 166 | cdr (obj x) 167 | { 168 | unsigned p = untag (a_pair, x); 169 | assert (p < heap_ptr); /* XXX heap_size, once we have gc */ 170 | return heap[p][1]; 171 | } 172 | 173 | static void 174 | set_car (obj x, obj y) 175 | { 176 | unsigned p = untag (a_pair, x); 177 | assert (p < heap_ptr); /* XXX heap_size, once we have gc */ 178 | heap[p][0] = y; 179 | } 180 | 181 | static int 182 | is_string (obj x) 183 | { 184 | /* XXX should we consider nil a string? */ 185 | for (; a_pair == get_tag (x); x = cdr (x)) 186 | if (a_char != get_tag (car (x))) 187 | return 0; 188 | return nil == x; 189 | } 190 | 191 | /* Pre: is_string (x) && is_string (y) */ 192 | static int 193 | string_equal (obj x, obj y) 194 | { 195 | for (; a_pair == get_tag (x) && a_pair == get_tag (y); x = cdr (x), y = cdr (y)) 196 | if (car (x) != car (y)) 197 | return 0; 198 | return x == y; 199 | } 200 | 201 | static obj symbols = nil; /* a list of nonempty strings */ 202 | 203 | static obj 204 | symbol_lookup (obj x) 205 | { 206 | if (nil != x && is_string (x)) 207 | { 208 | obj s = symbols; 209 | for (; a_pair == get_tag (s); s = cdr (s)) 210 | if (string_equal (car (s), x)) 211 | return car (s); 212 | } 213 | return nil; 214 | } 215 | 216 | static int 217 | is_symbol (obj x) 218 | { 219 | if (a_pair == get_tag (x)) 220 | { 221 | obj s = symbols; 222 | for (; a_pair == get_tag (s); s = cdr (s)) 223 | if (car (s) == x) 224 | return 1; 225 | } 226 | return 0; 227 | } 228 | 229 | static obj 230 | intern (obj x) 231 | { 232 | obj y = symbol_lookup (x); 233 | if (nil != y) 234 | return y; 235 | assert (nil != x && is_string (x)); 236 | symbols = cons (x, symbols); 237 | return x; 238 | } 239 | 240 | static void 241 | write_symbol (obj x) 242 | { 243 | for (; nil != get_tag (x); x = cdr (x)) 244 | *out++ = char_value (car (x)); 245 | } 246 | 247 | static void 248 | write_string (obj x) 249 | { 250 | *out++ = '"'; 251 | for (; nil != get_tag (x); x = cdr (x)) 252 | *out++ = char_value (car (x)); 253 | *out++ = '"'; 254 | } 255 | 256 | static void 257 | write (obj x) 258 | { 259 | switch (get_tag (x)) 260 | { 261 | case nil: 262 | *out++ = '('; 263 | *out++ = ')'; 264 | return; 265 | case a_char: 266 | *out++ = '\\'; 267 | *out++ = char_value (x); 268 | return; 269 | case a_pair: 270 | if (is_string (x)) 271 | { 272 | if (is_symbol (x)) 273 | write_symbol (x); 274 | else 275 | write_string (x); 276 | } 277 | else 278 | { 279 | *out++ = '('; 280 | write (car (x)); 281 | for (x = cdr (x); a_pair == get_tag (x); x = cdr (x)) 282 | { 283 | *out++ = ' '; 284 | write (car (x)); 285 | } 286 | if (nil == x) 287 | *out++ = ')'; 288 | else 289 | error ("Fucked-up list in write"); 290 | } 291 | return; 292 | default: 293 | error ("Unknown tag"); 294 | } 295 | } 296 | 297 | static void 298 | print (obj x) 299 | { 300 | write (x); 301 | *out++ = '\n'; 302 | } 303 | 304 | static void 305 | error_with_sexpr (obj x) 306 | { 307 | out = output; 308 | write (x); 309 | *out++ = '\0'; 310 | error (output); 311 | } 312 | 313 | static obj 314 | c_string (const char *s) 315 | { 316 | return '\0' == *s ? nil : cons (make_char (*s), c_string (s + 1)); 317 | } 318 | 319 | static obj eof; 320 | static obj sym_car; 321 | static obj sym_cdr; 322 | static obj sym_charP; 323 | static obj sym_cond; 324 | static obj sym_cons; 325 | static obj sym_define; 326 | static obj sym_eof_object; 327 | static obj sym_eqP; 328 | static obj sym_error; 329 | static obj sym_f; 330 | static obj sym_nullP; 331 | static obj sym_pairP; 332 | static obj sym_quote; 333 | static obj sym_peek_char; 334 | static obj sym_read_char; 335 | static obj sym_set_carB; 336 | static obj sym_t; 337 | static obj sym_to; 338 | static obj sym_write_char; 339 | 340 | static obj procedures = nil; 341 | static obj global_vars = nil; 342 | static obj global_vals = nil; 343 | 344 | static void 345 | set_up (void) 346 | { 347 | sym_car = intern (c_string ("car")); 348 | sym_cdr = intern (c_string ("cdr")); 349 | sym_charP = intern (c_string ("char?")); 350 | sym_cond = intern (c_string ("cond")); 351 | sym_cons = intern (c_string ("cons")); 352 | sym_define = intern (c_string ("define")); 353 | sym_eof_object = intern (c_string ("eof-object")); 354 | sym_eqP = intern (c_string ("eq?")); 355 | sym_error = intern (c_string ("error")); 356 | sym_f = intern (c_string ("f")); 357 | sym_nullP = intern (c_string ("null?")); 358 | sym_pairP = intern (c_string ("pair?")); 359 | sym_quote = intern (c_string ("quote")); 360 | sym_peek_char = intern (c_string ("peek-char")); 361 | sym_read_char = intern (c_string ("read-char")); 362 | sym_set_carB = intern (c_string ("set-car!")); 363 | sym_t = intern (c_string ("t")); 364 | sym_to = intern (c_string ("to")); 365 | sym_write_char = intern (c_string ("write-char")); 366 | 367 | eof = cons (c_string ("*eof*"), nil); 368 | global_vars = cons (sym_eof_object, global_vars); 369 | global_vals = cons (eof, global_vals); 370 | } 371 | 372 | static obj 373 | read_list (void); 374 | 375 | static obj 376 | read_string (void) 377 | { 378 | switch (*in) 379 | { 380 | case '"': 381 | ++in; 382 | return nil; 383 | case '\0': 384 | error ("Unfinished string"); 385 | return nil; 386 | default: 387 | { 388 | char c = *in++; 389 | return cons (make_char (c), read_string ()); 390 | } 391 | } 392 | } 393 | 394 | static int 395 | is_symbol_char (char c) 396 | { 397 | return isprint (c) && !isspace (c) && !strchr ("\"\\()';", c); 398 | } 399 | 400 | static obj 401 | read_symbol (void) 402 | { 403 | if (!is_symbol_char (*in)) 404 | return nil; 405 | { 406 | char c = *in++; 407 | return cons (make_char (c), read_symbol ()); 408 | } 409 | } 410 | 411 | static obj 412 | read (void) 413 | { 414 | while (isspace (*in)) 415 | ++in; 416 | switch (*in) 417 | { 418 | case '\\': 419 | ++in; 420 | return make_char (*in++); 421 | case '(': 422 | ++in; 423 | return read_list (); 424 | case '"': 425 | ++in; 426 | return read_string (); 427 | case '\'': 428 | ++in; 429 | return cons (sym_quote, cons (read (), nil)); 430 | default: 431 | if (isprint (*in)) 432 | return intern (read_symbol ()); 433 | /* fall through */ 434 | case ')': 435 | error ("rotten lexical syntax"); 436 | return nil; 437 | } 438 | } 439 | 440 | static obj 441 | read_top_level (void) 442 | { 443 | while (isspace (*in)) /* XXX skip comments too */ 444 | ++in; 445 | switch (*in) 446 | { 447 | case '\0': 448 | return eof; 449 | default: 450 | return read (); 451 | } 452 | } 453 | 454 | static obj 455 | read_list (void) 456 | { 457 | while (isspace (*in)) 458 | ++in; 459 | if (')' == *in) 460 | { 461 | ++in; 462 | return nil; 463 | } 464 | if (*in && (strchr ("(\\\"'", *in) || is_symbol_char (*in))) 465 | { 466 | obj h = read (); 467 | return cons (h, read_list ()); 468 | } 469 | error ("lexical error in list"); 470 | return nil; 471 | } 472 | 473 | static int 474 | is_true (obj x) 475 | { 476 | return x != sym_f; 477 | } 478 | 479 | static obj 480 | make_flag (int flag) 481 | { 482 | return flag ? sym_t : sym_f; 483 | } 484 | 485 | static obj 486 | eval (obj x, obj vars, obj vals); 487 | 488 | static obj 489 | evseq (obj exprs, obj vars, obj vals) 490 | { 491 | if (nil == exprs) 492 | return sym_f; 493 | if (nil == cdr (exprs)) 494 | return eval (car (exprs), vars, vals); 495 | eval (car (exprs), vars, vals); 496 | return evseq (cdr (exprs), vars, vals); 497 | } 498 | 499 | static obj 500 | evcond (obj clauses, obj vars, obj vals) 501 | { 502 | if (a_pair != get_tag (clauses)) 503 | { 504 | error ("No matching cond clause"); 505 | return sym_f; 506 | } 507 | { 508 | obj c = car (clauses); 509 | if (a_pair != get_tag (c)) 510 | { 511 | error ("Bad cond syntax"); 512 | return sym_f; 513 | } 514 | if (is_true (eval (car (c), vars, vals))) 515 | return evseq (cdr (c), vars, vals); 516 | return evcond (cdr (clauses), vars, vals); 517 | } 518 | } 519 | 520 | enum { stack_size = 1000 }; 521 | 522 | static int sp = -1; 523 | static obj stack_rator[stack_size]; 524 | static obj stack_args[stack_size]; 525 | 526 | static void 527 | traceback (void) 528 | { 529 | int i; 530 | for (i = sp; 0 <= i; --i) 531 | { 532 | write (stack_rator[i]); 533 | *out++ = ' '; 534 | print (stack_args[i]); 535 | } 536 | } 537 | 538 | static void 539 | entrace (obj rator, obj args) 540 | { 541 | if (stack_size <= sp + 1) 542 | traceback_error ("Stack overflow"); 543 | ++sp; 544 | stack_rator[sp] = rator; 545 | stack_args[sp] = args; 546 | } 547 | 548 | static void 549 | untrace (void) 550 | { 551 | assert (0 <= sp); 552 | --sp; 553 | } 554 | 555 | static obj 556 | apply (obj rator, obj args) 557 | { 558 | if (sym_car == rator) 559 | return car (car (args)); 560 | if (sym_cdr == rator) 561 | return cdr (car (args)); 562 | if (sym_charP == rator) 563 | return make_flag (a_char == get_tag (car (args))); 564 | if (sym_cons == rator) 565 | return cons (car (args), car (cdr (args))); 566 | if (sym_eqP == rator) 567 | return make_flag (car (args) == car (cdr (args))); 568 | if (sym_error == rator) 569 | { 570 | error_with_sexpr (car (args)); 571 | return sym_f; 572 | } 573 | if (sym_nullP == rator) 574 | return make_flag (nil == car (args)); 575 | if (sym_pairP == rator) 576 | return make_flag (a_pair == get_tag (car (args))); 577 | if (sym_peek_char == rator) 578 | return '\0' == *in ? sym_f : make_char (*in); 579 | if (sym_read_char == rator) 580 | return '\0' == *in ? sym_f : make_char (*in++); 581 | if (sym_set_carB == rator) 582 | { 583 | set_car (car (args), car (cdr (args))); 584 | return sym_f; 585 | } 586 | if (sym_write_char == rator) 587 | { 588 | *out++ = untag (a_char, car (args)); 589 | return sym_f; 590 | } 591 | { 592 | obj defs = procedures; 593 | for (; nil != defs; defs = cdr (defs)) 594 | { 595 | obj def = car (defs); 596 | if (car (car (def)) == rator) 597 | { 598 | obj result; 599 | entrace (rator, args); 600 | result = evseq (cdr (def), cdr (car (def)), args); 601 | untrace (); 602 | return result; 603 | } 604 | } 605 | } 606 | error ("Unknown procedure"); 607 | return nil; 608 | } 609 | 610 | static obj 611 | evlis (obj rands, obj vars, obj vals) 612 | { 613 | if (nil == rands) 614 | return nil; 615 | if (a_pair == get_tag (rands)) 616 | { 617 | obj arg = eval (car (rands), vars, vals); 618 | return cons (arg, evlis (cdr (rands), vars, vals)); 619 | } 620 | error ("Non-list operand list"); 621 | return nil; 622 | } 623 | 624 | static obj 625 | lookup (obj var, obj vars, obj vals) 626 | { 627 | for (; a_pair == get_tag (vars); vars = cdr (vars), vals = cdr (vals)) 628 | if (var == car (vars)) 629 | return car (vals); 630 | vars = global_vars, vals = global_vals; 631 | for (; a_pair == get_tag (vars); vars = cdr (vars), vals = cdr (vals)) 632 | if (var == car (vars)) 633 | return car (vals); 634 | error ("Unbound variable"); 635 | return nil; 636 | } 637 | 638 | static obj 639 | eval (obj x, obj vars, obj vals) 640 | { 641 | switch (get_tag (x)) 642 | { 643 | case nil: 644 | case a_char: 645 | return x; 646 | case a_pair: 647 | if (is_symbol (x)) 648 | return lookup (x, vars, vals); 649 | else 650 | { 651 | obj rator = car (x); 652 | obj rands = cdr (x); 653 | if (sym_quote == rator) 654 | return car (rands); 655 | if (sym_cond == rator) 656 | return evcond (cdr (x), vars, vals); 657 | return apply (rator, evlis (rands, vars, vals)); 658 | } 659 | default: 660 | error ("Bad tag"); 661 | return nil; 662 | } 663 | } 664 | 665 | static void 666 | define (obj definition) 667 | { 668 | /* TODO: more syntax checking */ 669 | obj var = car (definition); 670 | obj expr = car (cdr (definition)); 671 | obj val = eval (expr, nil, nil); 672 | global_vars = cons (var, global_vars); 673 | global_vals = cons (val, global_vals); 674 | } 675 | 676 | static void 677 | eval_form (obj x) 678 | { 679 | if (a_pair == get_tag (x)) 680 | { 681 | if (sym_define == car (x)) 682 | define (cdr (x)); 683 | else if (sym_to == car (x)) 684 | procedures = cons (cdr (x), procedures); 685 | else 686 | print (eval (x, nil, nil)); 687 | } 688 | else 689 | print (eval (x, nil, nil)); 690 | } 691 | 692 | static void 693 | run (void) 694 | { 695 | in = input; 696 | for (;;) 697 | { 698 | obj x = read_top_level (); 699 | if (eof == x) 700 | break; 701 | eval_form (x); 702 | } 703 | } 704 | 705 | int 706 | main (int argc, char **argv) 707 | { 708 | out = output; 709 | set_up (); 710 | if (argc < 2) 711 | snarf (stdin); 712 | else 713 | { 714 | int i; 715 | for (i = 1; i < argc; ++i) 716 | { 717 | FILE *f = fopen (argv[i], "r"); 718 | if (!f) 719 | stdlib_error (argv[i]); 720 | snarf (f); 721 | fclose (f); 722 | } 723 | } 724 | run (); 725 | *out++ = '\0'; 726 | printf ("= %s", output); 727 | return 0; 728 | } 729 | -------------------------------------------------------------------------------- /boot-terp/t: -------------------------------------------------------------------------------- 1 | ; Tests for lump 2 | 3 | ' () 4 | = () 5 | 6 | ' \a 7 | = \a 8 | 9 | ' \a 10 | = \a 11 | 12 | ' )( 13 | ! 1:3: rotten lexical syntax 14 | 15 | ' (()) 16 | = (()) 17 | 18 | ' (() ()) 19 | = (() ()) 20 | 21 | ' ( \x ((( ))) \z) 22 | = (\x ((())) \z) 23 | 24 | ' "" 25 | = () 26 | 27 | ' "a" 28 | = "a" 29 | 30 | ' "Hello, world!" 31 | = "Hello, world!" 32 | 33 | ' ("Lists") 34 | = ("Lists") 35 | 36 | ' ("Lists" ("and" "lists")) 37 | = ("Lists" ("and" "lists")) 38 | 39 | ' x 40 | = x 41 | 42 | ' (ok-fancier-symbols? (etc)) 43 | = (ok-fancier-symbols? (etc)) 44 | 45 | ' (x "x") 46 | = (x "x") 47 | 48 | ' (multi 49 | line 50 | input) 51 | = (multi line input) 52 | 53 | ' ('x) 54 | = ((quote x)) 55 | 56 | - \a 57 | = \a 58 | 59 | - '() 60 | = () 61 | 62 | - (goober) 63 | ! 1:9: Unknown procedure 64 | 65 | - (cond) 66 | ! 1:7: No matching cond clause 67 | 68 | - (cond ('t 'yes)) 69 | = yes 70 | 71 | - (cond ('f 'yes) ('foo 'no)) 72 | = no 73 | 74 | - (cond ((cond ('f 'one) ('f 'two) ('t 'three)) 75 | 'hurray) 76 | ('t 'booo)) 77 | = hurray 78 | 79 | - (cond ((cond ('f 'one) ('f 'two) ('t 'f)) 80 | 'hurray) 81 | ('t 'booo)) 82 | = booo 83 | 84 | - (null? '()) 85 | = t 86 | 87 | - (null? \a) 88 | = f 89 | 90 | - (char? '()) 91 | = f 92 | 93 | - (char? \a) 94 | = t 95 | 96 | - (pair? \a) 97 | = f 98 | 99 | - (pair? '"hello") 100 | = t 101 | 102 | - (eq? 'x 'x) 103 | = t 104 | 105 | - (eq? 'x 'y) 106 | = f 107 | 108 | - (eq? (pair? '()) 'f) 109 | = t 110 | 111 | - (cons 'x '()) 112 | = (x) 113 | 114 | - (car '"ab") 115 | = \a 116 | 117 | - (cdr '"ab") 118 | = "b" 119 | 120 | - (car (cons 'a '(b c))) 121 | = a 122 | 123 | - (car (error '"yo dude")) 124 | ! 1:25: "yo dude" 125 | 126 | ; XXX we should change this to get both results... 127 | - 'hello 'world 128 | = hello~world 129 | 130 | - (to (list x) (cons x '())) 131 | (list 'foo) 132 | = (foo) 133 | 134 | - (to (append x y) 135 | (cond ((null? x) y) 136 | ('t (cons (car x) (append (cdr x) y))))) 137 | (append '(a b c) '(x y z)) 138 | = (a b c x y z) 139 | 140 | - (define a '"Hello.") 141 | a 142 | = "Hello." 143 | 144 | - (define a '"yum") 145 | (set-car! a \b) 146 | a 147 | = f~"bum" 148 | 149 | - (read-char)z 150 | = \z 151 | 152 | - (define a (peek-char))(cons a '()) 153 | = "(" 154 | 155 | - eof-object 156 | = ("*eof*") 157 | 158 | ; XXX our test driver can't supply this test because 159 | ; it currently gives no way to give input without the newline. 160 | ;- (read-char) 161 | ;= ("*eof*") 162 | ; So, here's a more complicated pair of tests of eof-ness: 163 | 164 | - (to (f) (g (read-char))) 165 | (to (g c) (read-char)) 166 | (f) 167 | = f 168 | 169 | - (to (f) (g (read-char))) 170 | (to (g c) (peek-char)) 171 | (f) 172 | = f 173 | 174 | - (write-char \X) 175 | = Xf 176 | 177 | - (cond ('t (write-char \a) (write-char \b))) 178 | = abf 179 | 180 | - (to (f) (write-char \a) (write-char \b)) 181 | (f) 182 | = abf 183 | 184 | - (to (string? x) 185 | (cond ((null? x) 't) 186 | ((char? x) 'f) 187 | ((char? (car x)) (string? (cdr x))) 188 | ('t 'f))) 189 | (string? '()) 190 | (string? '"hell") 191 | (string? '(\h \e "ll")) 192 | = t~t~f 193 | 194 | 195 | 196 | ; Symbols 197 | ; N.B. generally for speed symbol? should first check stringness 198 | 199 | - (to (string=? s t) 200 | (cond ((null? s) (null? t)) 201 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 202 | ('t 'f))) 203 | 204 | (to (memq? x xs) 205 | (cond ((null? xs) 'f) 206 | ((eq? x (car xs)) 't) 207 | ('t (memq? x (cdr xs))))) 208 | 209 | (to (cons! x xs-cell) 210 | (set-car! xs-cell (cons x (car xs-cell)))) 211 | 212 | (define symbols '((f))) 213 | 214 | (to (symbol? x) 215 | (memq? x (car symbols))) 216 | 217 | (to (intern s) 218 | (intern-lookup s (car symbols))) 219 | 220 | (to (intern-lookup s syms) 221 | (cond ((null? syms) (cons! s symbols) s) 222 | ((string=? s (car syms)) (car syms)) 223 | ('t (intern-lookup s (cdr syms))))) 224 | 225 | (symbol? (intern '"x")) 226 | (intern '"ab") 227 | (eq? (intern '"x") (intern '"x")) 228 | (symbol? 'f) 229 | (symbol? '"f") 230 | 231 | = t~"ab"~t~t~f 232 | 233 | 234 | ; Writing 235 | 236 | - (to (string? x) 237 | (cond ((null? x) 't) 238 | ((char? x) 'f) 239 | ((char? (car x)) (string? (cdr x))) 240 | ('t 'f))) 241 | 242 | (to (string=? s t) 243 | (cond ((null? s) (null? t)) 244 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 245 | ('t 'f))) 246 | 247 | (to (memq? x xs) 248 | (cond ((null? xs) 'f) 249 | ((eq? x (car xs)) 't) 250 | ('t (memq? x (cdr xs))))) 251 | 252 | (to (cons! x xs-cell) 253 | (set-car! xs-cell (cons x (car xs-cell)))) 254 | 255 | (define symbols '((f))) 256 | 257 | (to (symbol? x) 258 | (memq? x (car symbols))) 259 | 260 | (to (intern s) 261 | (intern-lookup s (car symbols))) 262 | 263 | (to (intern-lookup s syms) 264 | (cond ((null? syms) (cons! s symbols) s) 265 | ((string=? s (car syms)) (car syms)) 266 | ('t (intern-lookup s (cdr syms))))) 267 | 268 | (to (write x) 269 | (cond ((null? x) (write-string '"()")) 270 | ((char? x) (write-char \\) (write-char x)) 271 | ((string? x) 272 | (cond ((symbol? x) (write-string x)) 273 | ('t (write-char \") (write-string x) (write-char \")))) 274 | ('t (write-char \() 275 | (write (car x)) 276 | (write-each (cdr x)) 277 | (write-char \))))) 278 | 279 | (to (write-each xs) 280 | (cond ((null? xs)) 281 | ('t (write-char \ ) 282 | (write (car xs)) 283 | (write-each (cdr xs))))) 284 | 285 | (to (write-string chars) 286 | (cond ((null? chars)) 287 | ('t (write-char (car chars)) 288 | (write-string (cdr chars))))) 289 | 290 | (write '()) 291 | (write '"abc") 292 | (write '(\a (\b))) 293 | (write (cons (intern '"hello") '(f "world"))) 294 | 295 | = ()f~"abc"f~(\a "b")f~(hello f "world")f 296 | 297 | 298 | ; Reading 299 | 300 | - (to (string=? s t) 301 | (cond ((null? s) (null? t)) 302 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 303 | ('t 'f))) 304 | 305 | (to (memq? x xs) 306 | (cond ((null? xs) 'f) 307 | ((eq? x (car xs)) 't) 308 | ('t (memq? x (cdr xs))))) 309 | 310 | (to (cons! x xs-cell) 311 | (set-car! xs-cell (cons x (car xs-cell)))) 312 | 313 | (define symbols '((f))) 314 | 315 | (to (symbol? x) 316 | (memq? x (car symbols))) 317 | 318 | (to (intern s) 319 | (intern-lookup s (car symbols))) 320 | 321 | (to (intern-lookup s syms) 322 | (cond ((null? syms) (cons! s symbols) s) 323 | ((string=? s (car syms)) (car syms)) 324 | ('t (intern-lookup s (cdr syms))))) 325 | 326 | (to (read) 327 | (skip-blanks (peek-char)) 328 | (read-dispatch (read-char))) 329 | 330 | (to (skip-blanks c) 331 | (cond ((char-whitespace? c) 332 | (read-char) 333 | (skip-blanks (peek-char))) 334 | ('t))) 335 | 336 | (to (char-whitespace? c) 337 | (memq? c '" 338 | ")) 339 | 340 | (define non-symbol-chars (cons \" '"\(')")) 341 | 342 | (define sym-quote (intern '"quote")) 343 | 344 | (to (read-dispatch c) 345 | (cond ((eq? c eof-object) eof-object) 346 | ((eq? c \\) (read-char-literal (read-char))) 347 | ((eq? c \") (read-string (read-char))) 348 | ((eq? c \() (read-list)) 349 | ((eq? c \') (cons sym-quote (cons (read) '()))) 350 | ((eq? c \)) (error "Unbalanced parentheses")) 351 | ('t (intern (cons c (read-symbol (peek-char))))))) 352 | 353 | (to (read-char-literal c) 354 | (cond ((eq? c eof-object) (error '"EOF in character literal")) 355 | ('t c))) 356 | 357 | (to (read-string c) 358 | (cond ((eq? c eof-object) (error '"Unterminated string literal")) 359 | ((eq? c \") '()) 360 | ('t (cons c (read-string (read-char)))))) 361 | 362 | (to (read-symbol c) 363 | (cond ((char-whitespace? c) '()) 364 | ((memq? c non-symbol-chars) '()) 365 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 366 | 367 | (to (read-list) 368 | (skip-blanks (peek-char)) 369 | (read-list-dispatch (read-char))) 370 | 371 | (to (read-list-dispatch c) 372 | (cond ((eq? c eof-object) (error '"Unterminated list")) 373 | ((eq? c \)) '()) 374 | ('t (cons (read-dispatch c) (read-list))))) 375 | 376 | (read) hello 377 | (read) ('42 \x "yay" (() sym ())) 378 | 379 | = "hello"~(("quote" "42") \x "yay" (() "sym" ())) 380 | 381 | 382 | ; Eval 383 | 384 | - (to (string? x) 385 | (cond ((null? x) 't) 386 | ((char? x) 'f) 387 | ((char? (car x)) (string? (cdr x))) 388 | ('t 'f))) 389 | 390 | (to (string=? s t) 391 | (cond ((null? s) (null? t)) 392 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 393 | ('t 'f))) 394 | 395 | (to (memq? x xs) 396 | (cond ((null? xs) 'f) 397 | ((eq? x (car xs)) 't) 398 | ('t (memq? x (cdr xs))))) 399 | 400 | (to (cons! x xs-cell) 401 | (set-car! xs-cell (cons x (car xs-cell)))) 402 | 403 | (to (list1 x) (cons x '())) 404 | 405 | (define symbols 406 | '((t f eof-object define to quote cond 407 | eq? null? pair? char? cons car cdr 408 | set-car! read-char peek-char write-char error 409 | yes no one two hurray booo x list foo pi y append z))) 410 | 411 | (to (symbol? x) 412 | (memq? x (car symbols))) 413 | 414 | (to (intern s) 415 | (intern-lookup s (car symbols))) 416 | 417 | (to (intern-lookup s syms) 418 | (cond ((null? syms) (cons! s symbols) s) 419 | ((string=? s (car syms)) (car syms)) 420 | ('t (intern-lookup s (cdr syms))))) 421 | 422 | (define definitions '(())) 423 | (define global-vars (list1 (list1 'eof-object))) 424 | (define global-vals (list1 (list1 eof-object))) 425 | 426 | (to (eval-form form) 427 | (cond ((pair? form) 428 | (cond ((eq? (car form) 'define) (eval-define (cdr form))) 429 | ((eq? (car form) 'to) (cons! (cdr form) definitions)) 430 | ('t (eval form '() '())))) 431 | ('t (eval form '() '())))) 432 | 433 | (to (eval-define defn) 434 | (define-global (car defn) 435 | (eval (car (cdr defn)) '() '()))) 436 | 437 | (to (define-global var val) 438 | (cons! var global-vars) 439 | (cons! val global-vals)) 440 | 441 | (to (call rator args defs) 442 | (cond ((null? defs) (error '"Unknown rator")) 443 | ((eq? rator (car (car (car defs)))) 444 | (evseq (cdr (car defs)) (cdr (car (car defs))) args)) 445 | ('t (call rator args (cdr defs))))) 446 | 447 | (to (evseq es vars vals) 448 | (cond ((null? es) 'f) 449 | ((null? (cdr es)) (eval (car es) vars vals)) 450 | ('t (eval (car es) vars vals) 451 | (evseq (cdr es) vars vals)))) 452 | 453 | (to (eval e vars vals) 454 | (cond ((pair? e) 455 | (cond ((symbol? e) (lookup e vars vals)) 456 | ('t (eval-pair (car e) (cdr e) vars vals)))) 457 | ('t e))) 458 | 459 | (to (eval-pair rator rands vars vals) 460 | (cond ((eq? rator 'quote) (car rands)) 461 | ((eq? rator 'cond) (evcond rands vars vals)) 462 | ('t (apply rator (evlis rands vars vals))))) 463 | 464 | (to (evlis es vars vals) 465 | (cond ((null? es) '()) 466 | ('t (cons (eval (car es) vars vals) 467 | (evlis (cdr es) vars vals))))) 468 | 469 | (to (evcond clauses vars vals) 470 | (cond ((null? clauses) '"No matching cond clause yo") 471 | ((eval (car (car clauses)) vars vals) 472 | (evseq (cdr (car clauses)) vars vals)) 473 | ('t (evcond (cdr clauses) vars vals)))) 474 | 475 | (to (lookup var vars vals) 476 | (cond ((null? vars) (lookup1 var (car global-vars) (car global-vals))) 477 | ((eq? var (car vars)) (car vals)) 478 | ('t (lookup var (cdr vars) (cdr vals))))) 479 | 480 | (to (lookup1 var vars vals) 481 | (cond ((null? vars) (error '"Unbound variable yo")) 482 | ((eq? var (car vars)) (car vals)) 483 | ('t (lookup1 var (cdr vars) (cdr vals))))) 484 | 485 | (to (apply rator args) 486 | (cond ((eq? rator 'eq?) (eq? (car args) (car (cdr args)))) 487 | ((eq? rator 'null?) (null? (car args))) 488 | ((eq? rator 'pair?) (pair? (car args))) 489 | ((eq? rator 'char?) (char? (car args))) 490 | ((eq? rator 'cons) (cons (car args) (car (cdr args)))) 491 | ((eq? rator 'car) (car (car args))) 492 | ((eq? rator 'cdr) (cdr (car args))) 493 | ((eq? rator 'set-car!) (set-car! (car args) (car (cdr args)))) 494 | ((eq? rator 'read-char) (read-char)) 495 | ((eq? rator 'peek-char) (peek-char)) 496 | ((eq? rator 'write-char) (write-char (car args))) 497 | ((eq? rator 'error) (error (car args))) 498 | ('t (call rator args (car definitions))))) 499 | 500 | (eval-form \a) 501 | (eval-form ''()) 502 | (eval-form '(cond ('t 'yes))) 503 | (eval-form '(cond ('f 'yes) ('foo 'no))) 504 | (eval-form '(cond ((cond ('f 'one) ('f 'two) ('t 'three)) 505 | 'hurray) 506 | ('t 'booo))) 507 | (eval-form '(cond ((cond ('f 'one) ('f 'two) ('t 'f)) 508 | 'hurray) 509 | ('t 'booo))) 510 | (eval-form '(null? '())) 511 | (eval-form '(eq? (pair? '()) 'f)) 512 | (intern 'x) 513 | (eval-form '(to (list x) (cons x '()))) 514 | (eval-form '(list 'foo)) 515 | (eval-form '(define pi '"3.14159")) 516 | (eval-form 'pi) 517 | (intern 'y) 518 | (eval-form '(to (append x y) 519 | (cond ((null? x) y) 520 | ('t (cons (car x) (append (cdr x) y)))))) 521 | (eval-form '(append '(a b c) '(x y z))) 522 | 523 | * \a 524 | * () 525 | * yes 526 | * no 527 | * hurray 528 | * booo 529 | * t 530 | * t 531 | * x 532 | * f 533 | * (foo) 534 | * f 535 | * "3.14159" 536 | * y 537 | * f 538 | = (a b c x y z) 539 | -------------------------------------------------------------------------------- /examples/datatype_idiom/Makefile: -------------------------------------------------------------------------------- 1 | 2 | run: list_of_trees.o 3 | 4 | list_of_trees.cpp: generate_code list_of_trees.scm 5 | ./generate_code list_of_trees.cpp 6 | 7 | %.c: %.scm 8 | if ../../ichbins <$^ >$@; then echo "ok!"; else ../../ichbins <$^; fi 9 | 10 | clean: 11 | rm -f generate_code generate_code.o list_of_trees.cpp list_of_trees.o 12 | -------------------------------------------------------------------------------- /examples/datatype_idiom/README: -------------------------------------------------------------------------------- 1 | Contributed by Johnicholas Hines, along with some disclaimers about 2 | the code quality. 3 | -------------------------------------------------------------------------------- /examples/datatype_idiom/generate_code.scm: -------------------------------------------------------------------------------- 1 | "datatype takes a name for the new datatype and a list of constructors." 2 | "Each constructor has a name as well, and a list of types." 3 | "(datatype Expression ((IntConst ((x int))) 4 | (Plus ((left Expression) (right Expression))) 5 | (Times ((left Expression) (right Expression)))))" 6 | "We want to process a list of datatypes." 7 | 8 | (define else 't) 9 | 10 | (define linefeed \ 11 | ) 12 | 13 | (to (write-string x) 14 | (cond ((null? x) 't) 15 | ((pair? x) (write-char (car x)) (write-string (cdr x))) 16 | (else (error "write-string is confused")))) 17 | 18 | (to (append x y) 19 | (cond ((null? x) y) 20 | ((pair? x) (cons (car x) (append (cdr x) y))) 21 | (else (error "append is confused")))) 22 | 23 | (to (assert x complaint) 24 | (cond (x 't) 25 | (else (error (append "assertion failure: " complaint))))) 26 | 27 | (to (endline) (write-char linefeed)) 28 | 29 | (to (write-line x) 30 | (write-string x) 31 | (endline)) 32 | 33 | (to (error complaint) 34 | (write-line complaint) 35 | (abort)) 36 | 37 | (assert (eq? (not 't) 'f) "not true is false") 38 | (assert (eq? (not 'f) 't) "not false is true") 39 | 40 | (to (not x) 41 | (cond (x 'f) 42 | (else 't))) 43 | 44 | (assert (not (singleton? '())) "null should not be a singleton list") 45 | (assert (singleton? '(x)) "a single x should be a singleton list") 46 | (assert (not (singleton? '(x y))) "a two-element list should not be a singleton list") 47 | 48 | (to (singleton? x) 49 | (cond ((pair? x) (null? (cdr x))) 50 | (else 'f))) 51 | 52 | (assert (string=? "" "") "empty string equals empty string") 53 | (assert (string=? "x" "x") "singleton string equals singleton string") 54 | (assert (not (string=? "x" "")) "singleton string does not equal empty string") 55 | (assert (not (string=? "" "x")) "empty string does not equal singleton string") 56 | (assert (not (string=? "x" "y")) "x does not equal y") 57 | (assert (string=? "xyz" "xyz") "xyz equals xyz") 58 | 59 | (to (string? x) 60 | (cond ((null? x) 't) 61 | ((pair? x) (cond ((char? (car x)) (string? (cdr x))) 62 | (else 'f))) 63 | (else 'f))) 64 | 65 | (to (check-string to-check function-name) 66 | (assert (string? to-check) (append "argument to " 67 | (append function-name 68 | " should be a string")))) 69 | 70 | (to (string=? x y) 71 | (check-string x "string=?") 72 | (check-string y "string=?") 73 | 74 | (cond ((null? x) (null? y)) 75 | ((null? y) 'f) 76 | ((eq? (car x) (car y)) (string=? (cdr x) (cdr y))) 77 | (else 'f))) 78 | 79 | (to (1st x) (car x)) 80 | (to (2nd x) (car (cdr x))) 81 | 82 | 83 | "Creates a single-element list" 84 | (to (list1 x) 85 | (cons x '())) 86 | 87 | "Creates a two-element list" 88 | (to (list2 x y) 89 | (cons x (list1 y))) 90 | 91 | 92 | 93 | 94 | 95 | (to (make-datatype name constructors) 96 | (cons 'datatypetag (cons name constructors))) 97 | 98 | (to (datatype? d) (eq? (car d) 'datatypetag)) 99 | 100 | (to (check-datatype to-check function-name) 101 | (assert (datatype? to-check) (append "argument to " 102 | (append function-name 103 | " should be a datatype")))) 104 | 105 | (assert (datatype? (make-datatype 'False '())) "False is a datatype") 106 | 107 | (to (datatype-name d) 108 | (check-datatype d "datatype-name") 109 | 110 | (2nd d)) 111 | 112 | (to (datatype-visitor-name d) 113 | (check-datatype d "datatype-visitor-name") 114 | 115 | (append (datatype-name d) "Visitor")) 116 | 117 | (assert (string=? (datatype-name (make-datatype 'False '())) "False") 118 | "The name of False should be False") 119 | 120 | (to (datatype-constructors d) 121 | (check-datatype d "datatype-constructors") 122 | 123 | (cdr (cdr d))) 124 | 125 | (to (write-interface-header classname) 126 | (check-string classname "write-interface-header") 127 | (write-string "class ") 128 | (write-string classname) 129 | (write-string " {") 130 | (endline) 131 | (write-string "public:") 132 | (endline)) 133 | 134 | (to (write-constructor-declaration classname args) 135 | (write-line " // Constructor.") 136 | (write-string " ") 137 | (write-string classname) 138 | (write-string "(") 139 | (write-arguments args) 140 | (write-string ")")) 141 | 142 | (to (write-destructor-declaration classname) 143 | (write-string " // Destructor.") 144 | (endline) 145 | (write-string " virtual ~") 146 | (write-string classname) 147 | (write-string "()")) 148 | 149 | 150 | (to (write-interface-footer classname) 151 | (check-string classname "write-interface-footer") 152 | 153 | (endline) 154 | (write-destructor-declaration classname) 155 | (write-string " {}") 156 | (endline) 157 | (write-string "protected:") 158 | (endline) 159 | 160 | (write-constructor-declaration classname '()) 161 | (write-string " {}") 162 | (endline) 163 | (write-line "};")) 164 | 165 | (to (length list) 166 | (cons (length-helper list "0123456789") '())) 167 | 168 | (to (length-helper list digits) 169 | (cond ((null? list) (car digits)) 170 | ((pair? list) 171 | (assert (not (null? digits)) "length of list is too big to compute with this brain-dead implementation") 172 | (length-helper (cdr list) (cdr digits))) 173 | ('t (assert 'f "length-helper is confused")))) 174 | 175 | (to (write-arguments as) 176 | (cond ((null? as) 't) 177 | ((pair? as) 178 | (write-argument (car as)) 179 | (cond ((pair? (cdr as)) (write-string ", "))) 180 | (write-arguments (cdr as))) 181 | (else (error "write-arguments is confused")))) 182 | 183 | (to (write-argument a) 184 | (assert (string=? (length a) "2") "write-argument takes a two-element list") 185 | 186 | (write-string (2nd a)) 187 | (write-string " ") 188 | (write-string (car a))) 189 | 190 | 191 | "TODO: introduce constructors and accessors for methods, not this car/car/cdr stuff." 192 | (to (write-visitor-class-method m) 193 | (assert (string=? (length m) "2") "length of the argument to write-visitor-class-method should be exactly two") 194 | 195 | (write-string " virtual void ") 196 | (write-string (1st m)) 197 | (write-string "(") 198 | (write-arguments (2nd m)) 199 | (write-string ") { Complain(\"") 200 | (write-string (1st m)) 201 | (write-string "\"); }") 202 | (endline)) 203 | 204 | (to (write-visitor-class-methods ms) 205 | (cond ((null? ms) 't) 206 | ((pair? ms) 207 | (write-visitor-class-method (car ms)) 208 | (write-visitor-class-methods (cdr ms))) 209 | (else (error "write-visitor-class-methods is confused")))) 210 | 211 | (to (write-visitor-class-helper name methods) 212 | (write-interface-header name) 213 | (write-visitor-class-methods methods) 214 | (write-string " virtual void Complain(const char* function_name) {}") 215 | (write-interface-footer name)) 216 | 217 | (to (write-visitor-class d) 218 | (check-datatype d "write-visitor-class") 219 | 220 | (write-visitor-class-helper (datatype-visitor-name d) (datatype-constructors d))) 221 | 222 | (to (write-datatype-class d) 223 | (check-datatype d "write-datatype-class") 224 | 225 | (write-interface-header (datatype-name d)) 226 | 227 | (write-string " virtual void Visit(") 228 | (write-string (datatype-visitor-name d)) 229 | (write-string "&) = 0;") 230 | (endline) 231 | 232 | (write-interface-footer (datatype-name d))) 233 | 234 | "Takes a list of datatypes, writes forward declarations for them." 235 | (to (write-forward-declarations ds) 236 | (cond ((null? ds) 't) 237 | ((pair? ds) 238 | (cond ((singleton? ds) 239 | (write-string "// forward declaration")) 240 | (else 241 | (write-string "// forward declarations"))) 242 | (endline) 243 | (write-forward-declarations-helper ds)) 244 | (else (error "write-forward-declarations is confused")))) 245 | 246 | (to (write-forward-declarations-helper ds) 247 | (cond ((null? ds) 't) 248 | ((pair? ds) 249 | (write-forward-declaration (car ds)) 250 | (write-forward-declarations-helper (cdr ds))) 251 | (else (error "write-forward-declarations-helper is confused")))) 252 | 253 | "Takes a datatype, writes a foward declaration for it." 254 | (to (write-forward-declaration d) 255 | (check-datatype d "write-forward-declaration") 256 | 257 | (write-string "class ") 258 | (write-string (datatype-name d)) 259 | (write-string ";") 260 | (endline)) 261 | 262 | "Takes a datatype, writes an interface class and subclasses for each." 263 | "Note: visitor classes must be declared (not forward declared) first." 264 | (to (write-datatype d) 265 | (check-datatype d "write-datatype") 266 | 267 | (write-visitor-class d) 268 | (endline) 269 | (write-datatype-class d) 270 | (endline) 271 | (write-constructor-classes d)) 272 | 273 | (to (write-constructor-classes d) 274 | (check-datatype d "write-constructor-classes") 275 | 276 | (write-constructor-classes-helper 277 | (datatype-name d) 278 | (datatype-constructors d))) 279 | 280 | (to (write-constructor-classes-helper name cs) 281 | (cond ((null? cs) 't) 282 | ((pair? cs) 283 | (write-constructor-class name (car cs)) 284 | (cond ((pair? (cdr cs)) (endline))) 285 | (write-constructor-classes-helper name (cdr cs))) 286 | (else (error "write-constructor-classes-helper is confused")))) 287 | 288 | "TODO: Get a real initializer list working." 289 | (to (write-constructor-class typename c) 290 | (assert (string=? (length c) "2") "length arg to write-constructor-class should be two") 291 | 292 | (write-string "class ") 293 | (write-string (1st c)) 294 | (write-string " : public ") 295 | (write-string typename) 296 | (write-string " {") 297 | (endline) 298 | 299 | (write-line "public:") 300 | 301 | (write-constructor-declaration (1st c) (2nd c)) 302 | 303 | (write-simple-initializer-list (2nd c)) 304 | 305 | (write-string " {}") 306 | (endline) 307 | 308 | (write-string " virtual void Visit(") 309 | (write-string typename) 310 | (write-string "Visitor& v) {") 311 | (endline) 312 | 313 | (write-string " v.") 314 | (write-string (1st c)) 315 | (write-string "(") 316 | (write-unpack-fields (2nd c)) 317 | (write-string ");") 318 | (endline) 319 | 320 | (write-line " }") 321 | 322 | 323 | (write-line "private:") 324 | 325 | (write-member-variables (2nd c)) 326 | 327 | (write-line "};")) 328 | 329 | (to (write-unpack-fields fields) 330 | (cond ((null? fields) 't) 331 | ((pair? fields) 332 | (write-string (1st (car fields))) 333 | (cond ((pair? (cdr fields)) (write-string ", "))) 334 | (write-unpack-fields (cdr fields))) 335 | (else (error "write-unpack-fields is confused")))) 336 | 337 | (to (write-simple-initializer-list fields) 338 | (cond ((null? fields) (endline)) 339 | ((pair? fields) 340 | (write-string " :") 341 | (endline) 342 | (write-simple-initializer-list-helper fields)) 343 | (else (error "write-simple-initializer-list is confused")))) 344 | 345 | (to (write-simple-initializer-list-helper fields) 346 | (cond ((null? fields) 't) 347 | ((pair? fields) 348 | (write-string " ") 349 | (write-simple-initializer (car fields)) 350 | (cond ((pair? (cdr fields)) (write-string ","))) 351 | (endline) 352 | (write-simple-initializer-list-helper (cdr fields))) 353 | (else (error "write-simple-initializer-list is confused")))) 354 | 355 | (to (write-simple-initializer field) 356 | (assert (string=? (length field) "2") "write-simple-initializer takes a two-element list") 357 | 358 | (write-string (1st field)) 359 | (write-string "(") 360 | (write-string (1st field)) 361 | (write-string ")")) 362 | 363 | (to (write-member-variables vars) 364 | (cond ((null? vars) 't) 365 | ((pair? vars) 366 | (write-string " ") 367 | (write-variable (car vars)) 368 | (endline) 369 | (write-member-variables (cdr vars))) 370 | (else (error "write-member-variables is confused")))) 371 | 372 | (to (write-variable v) 373 | (assert (string=? (length v) "2") "write-variable takes a two-element list") 374 | 375 | (write-string (2nd v)) 376 | (write-string " ") 377 | (write-string (1st v)) 378 | (write-string ";")) 379 | 380 | "Takes a list of datatypes" 381 | (to (write-datatypes ds) 382 | (write-forward-declarations ds) 383 | (endline) 384 | (write-datatypes-helper ds)) 385 | 386 | (to (write-datatypes-helper ds) 387 | (cond ((null? ds) 't) 388 | ((pair? ds) 389 | (write-datatype (car ds)) 390 | (cond ((pair? (cdr ds)) (endline))) 391 | (write-datatypes-helper (cdr ds))) 392 | (else (error "write-datatypes-helper is confused")))) 393 | 394 | 395 | (to (read) 396 | (read-dispatch (skip-blanks (read-char)))) 397 | 398 | (to (memq? x xs) 399 | (cond ((null? xs) 'f) 400 | ((eq? x (car xs)) 't) 401 | (else (memq? x (cdr xs))))) 402 | 403 | (to (skip-blanks c) 404 | (cond ((memq? c whitespace-chars) (skip-blanks (read-char))) 405 | (else 406 | '(write-string "skip-blanks returning: ") 407 | '(write-char c) 408 | '(endline) 409 | c))) 410 | 411 | (define whitespace-chars (cons linefeed " ")) 412 | 413 | (define eof-object '("eof")) 414 | 415 | (to (read-dispatch c) 416 | (cond ((eq? c 'f) eof-object) 417 | ((eq? c \") (read-string (read-char))) 418 | ((eq? c \() (read-list)) 419 | ((eq? c \)) (error "Unbalanced parentheses")) 420 | (else (cons c (read-symbol (peek-char)))))) 421 | 422 | (to (read-string c) 423 | (cond ((eq? c 'f) (error "Unterminated string literal")) 424 | ((eq? c \") '()) 425 | ((eq? c \\) (cons (read-char) (read-string (read-char)))) 426 | (else (cons c (read-string (read-char)))))) 427 | 428 | (define non-symbol-chars "\"\\(')") 429 | 430 | (to (read-symbol c) 431 | (cond ((memq? c whitespace-chars) '()) 432 | ((memq? c non-symbol-chars) '()) 433 | (else (read-char) (cons c (read-symbol (peek-char)))))) 434 | 435 | (to (read-list) 436 | (read-list-dispatch (skip-blanks (read-char)))) 437 | 438 | (to (read-list-dispatch c) 439 | (cond ((eq? c 'f) (error "Unterminated list")) 440 | ((eq? c \)) '()) 441 | (else (cons (read-dispatch c) (read-list))))) 442 | 443 | (to (make-list-of-datatypes lds) 444 | (cond ((null? lds) '()) 445 | ((pair? lds) 446 | (cons (make-datatype (1st (car lds)) (2nd (car lds))) 447 | (make-list-of-datatypes (cdr lds)))) 448 | (else (error "make-list-of-datatypes is confused")))) 449 | 450 | 451 | '(write-interface-header "Foo") 452 | '(write-interface-footer "Foo") 453 | 454 | '(define Expression (make-datatype "Expression" '((IntConst ((x int))) 455 | (Plus ((left Expression) (right Expression))) 456 | (Times ((left Expression) (right Expression)))))) 457 | '(write-visitor-class Expression) 458 | 459 | '(write-forward-declarations (list1 Expression)) 460 | 461 | '(write-visitor-classes (list1 Expression)) 462 | 463 | '(write-datatype Expression) 464 | '(write-datatype Tree) 465 | '(write-datatype ListOfTrees) 466 | '(write-constructor-classes Expression) 467 | 468 | '(define Tree (make-datatype "Tree" '((Leaf ((value int))) 469 | (TreeNode ((left Tree*) (right Tree*)))))) 470 | 471 | '(define ListOfTrees (make-datatype "ListOfTrees" '((Empty ()) 472 | (Nonempty ((first Tree*) (rest ListOfTrees*)))))) 473 | 474 | 475 | '(write-datatypes (list1 Expression)) 476 | 477 | '(write-datatypes (list2 Tree ListOfTrees)) 478 | 479 | 480 | 481 | "This is the expression that starts everything." 482 | (write-datatypes (make-list-of-datatypes (read))) 483 | 484 | -------------------------------------------------------------------------------- /examples/datatype_idiom/list_of_trees.scm: -------------------------------------------------------------------------------- 1 | ( 2 | (ListOfTrees ((Empty ()) 3 | (Nonempty ((first Tree*) (rest ListOfTrees*))))) 4 | (Tree ((Leaf ((value int))) 5 | (Branch ((left Tree*) (right Tree*))))) 6 | ) 7 | 8 | -------------------------------------------------------------------------------- /ichbins.scm: -------------------------------------------------------------------------------- 1 | (define linefeed \ 2 | ) 3 | 4 | (to (error complaint) 5 | (write-string complaint) 6 | (write-char linefeed) 7 | (abort)) 8 | 9 | (to (list1 z) (cons z '())) 10 | (to (list3 x y z) (cons x (cons y (cons z '())))) 11 | 12 | (to (append xs ys) 13 | (cond ((null? xs) ys) 14 | ('t (cons (car xs) (append (cdr xs) ys))))) 15 | 16 | (to (reverse xs) 17 | (append-reverse xs '())) 18 | 19 | (to (append-reverse xs ys) 20 | (cond ((null? xs) ys) 21 | ('t (append-reverse (cdr xs) (cons (car xs) ys))))) 22 | 23 | (to (memq? x xs) 24 | (cond ((null? xs) 'f) 25 | ((eq? x (car xs)) 't) 26 | ('t (memq? x (cdr xs))))) 27 | 28 | (to (length xs) 29 | (list1 (length-digit xs "0123456789"))) 30 | 31 | (to (length-digit xs digits) 32 | (cond ((null? xs) (car digits)) 33 | ('t (length-digit (cdr xs) (cdr digits))))) 34 | 35 | (to (string? x) 36 | (cond ((null? x) 't) 37 | ((char? x) 'f) 38 | ((char? (car x)) (string? (cdr x))) 39 | ('t 'f))) 40 | 41 | (to (string=? s t) 42 | (cond ((null? s) (null? t)) 43 | ((null? t) 'f) 44 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 45 | ('t 'f))) 46 | 47 | (to (write-string chars) 48 | (cond ((pair? chars) 49 | (write-char (car chars)) 50 | (write-string (cdr chars))))) 51 | 52 | (to (cons! x xs-box) 53 | (set-car! xs-box (cons x (car xs-box)))) 54 | 55 | (to (adjoin! x xs-box) 56 | (cond ((eq? 'f (memq? x (car xs-box))) 57 | (cons! x xs-box)))) 58 | 59 | 60 | (define primitives '(eq? null? pair? char? cons car cdr set-car! 61 | read-char peek-char write-char abort)) 62 | 63 | (define symbols-box (list1 (append '(t f define to quote cond) primitives))) 64 | (to (symbol? x) (memq? x (car symbols-box))) 65 | (to (intern s) (interning s (car symbols-box))) 66 | 67 | (to (interning s symbols) 68 | (cond ((null? symbols) (cons! s symbols-box) s) 69 | ((string=? s (car symbols)) (car symbols)) 70 | ('t (interning s (cdr symbols))))) 71 | 72 | 73 | (to (read) 74 | (read-dispatch (skip-blanks (read-char)))) 75 | 76 | (to (skip-blanks c) 77 | (cond ((memq? c whitespace-chars) (skip-blanks (read-char))) 78 | ('t c))) 79 | 80 | (define whitespace-chars (cons linefeed " ")) 81 | (define non-symbol-chars "\"\\(')") 82 | 83 | (define eof-object '("eof")) 84 | 85 | (to (read-dispatch c) 86 | (cond ((eq? c 'f) eof-object) 87 | ((eq? c \\) (read-char-literal (read-char))) 88 | ((eq? c \") (read-string (read-char))) 89 | ((eq? c \() (read-list)) 90 | ((eq? c \') (cons 'quote (list1 (read)))) 91 | ((eq? c \)) (error "Unbalanced parentheses")) 92 | ('t (intern (cons c (read-symbol (peek-char))))))) 93 | 94 | (to (read-char-literal c) 95 | (cond ((eq? c 'f) (error "EOF in character literal")) 96 | ('t c))) 97 | 98 | (to (read-string c) 99 | (cond ((eq? c 'f) (error "Unterminated string literal")) 100 | ((eq? c \") '()) 101 | ((eq? c \\) (cons (read-char) (read-string (read-char)))) 102 | ('t (cons c (read-string (read-char)))))) 103 | 104 | (to (read-symbol c) 105 | (cond ((memq? c whitespace-chars) '()) 106 | ((memq? c non-symbol-chars) '()) 107 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 108 | 109 | (to (read-list) 110 | (read-list-dispatch (skip-blanks (read-char)))) 111 | 112 | (to (read-list-dispatch c) 113 | (cond ((eq? c 'f) (error "Unterminated list")) 114 | ((eq? c \)) '()) 115 | ('t (cons (read-dispatch c) (read-list))))) 116 | 117 | 118 | (to (emit1 z k) (append z (cons linefeed k))) 119 | (to (emit3 x y z k) (append x (append y (emit1 z k)))) 120 | (to (emit5 v w x y z k) (append v (append w (emit3 x y z k)))) 121 | 122 | 123 | (to (compile) 124 | (write-string (read-compile-loop '((t f)) (read) '() '() postlude-lines))) 125 | 126 | (to (read-compile-loop syms form var-defs exprs k) 127 | (cond ((eq? eof-object form) 128 | (compile-startup syms (reverse var-defs) 129 | (compile-proc syms '(main) (reverse exprs) k))) 130 | ((pair? form) 131 | (cond ((eq? 'define (car form)) 132 | (read-compile-loop syms (read) (cons form var-defs) exprs k)) 133 | ((eq? 'to (car form)) 134 | (read-compile-loop syms (read) var-defs exprs 135 | (compile-proc syms (car (cdr form)) (cdr (cdr form)) k))) 136 | ('t (read-compile-loop syms (read) var-defs (cons form exprs) k)))) 137 | ('t (read-compile-loop syms (read) var-defs (cons form exprs) k)))) 138 | 139 | (to (compile-startup syms var-defs k) 140 | (compile-symbols syms var-defs 141 | (compile-defs syms var-defs 142 | (emit1 " bp = sp + 1; goto proc_main;" k)))) 143 | 144 | (to (compile-symbols syms var-defs k) 145 | (emit-enum "var_" (append (map-def.name (make-symbol-defs (car syms))) 146 | (map-def.name var-defs)) 147 | (emit1 prelude-lines 148 | (compile-defs syms (make-symbol-defs (car syms)) k)))) 149 | 150 | (to (compile-defs syms defs k) 151 | (cond ((null? defs) k) 152 | ('t (compile-def syms (def.name (car defs)) (def.expr (car defs)) 153 | (compile-defs syms (cdr defs) k))))) 154 | 155 | (to (express syms x) 156 | (cond ((symbol? x) (adjoin! x syms) (symbol->var x)) 157 | ((pair? x) (express-pair syms x)) 158 | ('t x))) 159 | 160 | (to (express-pair syms x) 161 | (list3 'cons (express syms (car x)) (express syms (cdr x)))) 162 | 163 | (to (make-symbol-defs symbols) 164 | (cond ((null? symbols) '()) 165 | ('t (cons (list3 'define (symbol->var (car symbols)) 166 | (express-pair '() (car symbols))) 167 | (make-symbol-defs (cdr symbols)))))) 168 | 169 | (to (symbol->var sym) 170 | (intern (cons \. sym))) 171 | 172 | (to (def.name def) (car (cdr def))) 173 | (to (def.expr def) (car (cdr (cdr def)))) 174 | 175 | (to (map-def.name defs) 176 | (cond ((null? defs) '()) 177 | ('t (cons (def.name (car defs)) 178 | (map-def.name (cdr defs)))))) 179 | 180 | (to (compile-def syms name e k) 181 | (compile-expr syms e '() 'f 182 | (emit3 " assert(var_" (c-id name) " == sp);" k))) 183 | 184 | (to (compile-proc syms header body k) 185 | (emit1 "" 186 | (emit3 "proc_" (c-id (car header)) ": {" 187 | (emit-enum "arg_" (cdr header) 188 | (emit3 " assert(" (length (cdr header)) " == sp - bp + 1);" 189 | (compile-seq syms body (cdr header) 't 190 | (emit1 "}" k))))))) 191 | 192 | (to (compile-seq syms es vars tail? k) 193 | (cond ((null? (cdr es)) (compile-expr syms (car es) vars tail? k)) 194 | ('t (compile-expr syms (car es) vars 'f 195 | (emit1 " --sp;" 196 | (compile-seq syms (cdr es) vars tail? k)))))) 197 | 198 | (to (compile-exprs syms es vars k) 199 | (cond ((null? es) k) 200 | ('t (compile-expr syms (car es) vars 'f 201 | (compile-exprs syms (cdr es) vars k))))) 202 | 203 | (to (compile-expr syms e vars tail? k) 204 | (cond ((char? e) 205 | (compile-value "entag(a_char, '" (c-char-literal e) "')" vars tail? 206 | k)) 207 | ((null? e) (compile-value "" "nil" "" vars tail? k)) 208 | ((symbol? e) 209 | (cond ((memq? e vars) 210 | (compile-value "stack[bp + arg_" (c-id e) "]" vars tail? k)) 211 | ('t (compile-value "stack[var_" (c-id e) "]" vars tail? k)))) 212 | ((string? e) (compile-expr syms (express syms e) vars tail? k)) 213 | ('t (compile-pair syms (car e) (cdr e) vars tail? k)))) 214 | 215 | (to (compile-value lit1 lit2 lit3 vars tail? k) 216 | (emit5 " push(" lit1 lit2 lit3 ");" 217 | (maybe-return vars tail? k))) 218 | 219 | (to (maybe-return vars tail? k) 220 | (cond (tail? (emit3 " sp -= " (length vars) ";" 221 | (emit3 " stack[sp] = stack[sp + " (length vars) "];" 222 | (emit1 " return;" k)))) 223 | ('t k))) 224 | 225 | (to (compile-pair syms rator rands vars tail? k) 226 | (cond ((eq? rator 'cond) (compile-cond syms rands vars tail? k)) 227 | ((eq? rator 'quote) 228 | (compile-expr syms (express syms (car rands)) vars tail? k)) 229 | ('t (compile-exprs syms rands vars 230 | (compile-call rator (length rands) vars tail? k))))) 231 | 232 | (to (compile-cond syms clauses vars tail? k) 233 | (cond ((null? clauses) (compile-value "" "sym_f" "" vars tail? k)) 234 | ('t (compile-expr syms (car (car clauses)) vars 'f 235 | (emit1 " if (sym_f != pop()) {" 236 | (compile-seq syms (cdr (car clauses)) vars tail? 237 | (emit1 " } else {" 238 | (compile-cond syms (cdr clauses) vars tail? 239 | (emit1 " }" k))))))))) 240 | 241 | (to (compile-call rator n-args vars tail? k) 242 | (cond ((memq? rator primitives) 243 | (emit5 " prim" n-args "_" (c-id rator) "();" 244 | (maybe-return vars tail? k))) 245 | (tail? 246 | (emit5 " TAILCALL(proc_" (c-id rator) ", " n-args ");" k)) 247 | ('t 248 | (emit5 " run(&&proc_" (c-id rator) ", sp - " n-args " + 1);" k)))) 249 | 250 | (define c-char-map-domain (list3 linefeed \' \\)) 251 | (define c-char-map-range (list3 "\\n" "\\'" "\\\\")) 252 | (to (c-char-literal c) 253 | (translit c (list1 c) c-char-map-domain c-char-map-range)) 254 | 255 | (to (c-id str) 256 | (cond ((null? str) '()) 257 | ('t (cons (translit (car str) (car str) c-id-map-domain c-id-map-range) 258 | (c-id (cdr str)))))) 259 | 260 | (define c-id-map-domain "-!:=.><%?*_") 261 | (define c-id-map-range "_BCEDGLMPSU") 262 | 263 | (to (translit x default domain range) 264 | (cond ((null? domain) default) 265 | ((eq? x (car domain)) (car range)) 266 | ('t (translit x default (cdr domain) (cdr range))))) 267 | 268 | (to (emit-enum prefix names k) 269 | (cond ((null? names) k) 270 | ('t (append " enum {" (comma prefix names (emit1 " };" k)))))) 271 | 272 | (to (comma prefix names k) 273 | (cond ((null? names) k) 274 | ('t (cons \ (append prefix (append (c-id (car names)) 275 | (maybe-comma prefix (cdr names) k))))))) 276 | 277 | (to (maybe-comma prefix names k) 278 | (cond ((null? names) k) 279 | ('t (cons \, (comma prefix names k))))) 280 | 281 | (define prelude-lines " 282 | #include 283 | #include 284 | #include 285 | #include 286 | 287 | typedef unsigned Obj; 288 | typedef enum { a_pair, nil, a_char } Tag; 289 | static Tag get_tag(Obj x) { return 3 & x; } 290 | static Obj entag(Tag tag, unsigned value) 291 | { return tag | (value << 2); } 292 | static unsigned untag(Tag tag, Obj x) 293 | { assert(tag == get_tag(x)); 294 | return x >> 2; } 295 | 296 | enum { stack_size = 256*1024 }; 297 | static Obj stack[stack_size]; 298 | static unsigned sp = -1; 299 | 300 | #define TOP ( stack[sp] ) 301 | static Obj pop(void) { return stack[sp--]; } 302 | static void push(Obj x) { assert(sp + 1 < stack_size); 303 | stack[++sp] = x; } 304 | 305 | enum { heap_size = 512*1024 }; 306 | static Obj heap[heap_size][2]; 307 | static char marks[heap_size]; 308 | static unsigned hp = 0; 309 | 310 | static unsigned heap_index(Obj x) { unsigned p = untag(a_pair, x); 311 | assert(p < heap_size); 312 | return p; } 313 | static Obj car (Obj x) { return heap[heap_index(x)][0]; } 314 | static Obj cdr (Obj x) { return heap[heap_index(x)][1]; } 315 | static void set_car(Obj x, Obj y) { heap[heap_index(x)][0] = y; } 316 | static void mark(Obj x) { while (get_tag(x) == a_pair 317 | && !marks[heap_index(x)]) { 318 | marks[heap_index(x)] = 1; 319 | mark(car(x)); 320 | x = cdr(x); } } 321 | static int sweep(void) { while (hp < heap_size && marks[hp]) 322 | marks[hp++] = 0; 323 | return hp < heap_size; } 324 | static void gc(Obj car, Obj cdr) { unsigned i; 325 | mark(car); mark(cdr); 326 | for (i = 0; i <= sp; ++i) 327 | mark(stack[i]); 328 | hp = 0; } 329 | static Obj cons(Obj car, Obj cdr) { if (!sweep()) { 330 | gc(car, cdr); 331 | if (!sweep()) { 332 | fprintf(stderr, \"Heap full\\n\"); 333 | exit(1); } } 334 | heap[hp][0] = car; 335 | heap[hp][1] = cdr; 336 | return entag(a_pair, hp++); } 337 | 338 | #define sym_f ( stack[var_Df] ) 339 | #define sym_t ( stack[var_Dt] ) 340 | static Obj make_flag(int flag) { return flag ? sym_t : sym_f; } 341 | 342 | static int read_char(void) { int c = getchar(); 343 | push(EOF == c ? sym_f : entag(a_char, c)); 344 | return c; } 345 | 346 | #define DEF(prim) static void prim(void) 347 | DEF(prim2_eqP) { Obj z = pop(); TOP = make_flag(TOP == z); } 348 | DEF(prim1_nullP) { TOP = make_flag(nil == TOP); } 349 | DEF(prim1_charP) { TOP = make_flag(a_char == get_tag(TOP)); } 350 | DEF(prim1_pairP) { TOP = make_flag(a_pair == get_tag(TOP)); } 351 | DEF(prim2_cons) { Obj z = pop(); TOP = cons(TOP, z); } 352 | DEF(prim1_car) { TOP = car(TOP); } 353 | DEF(prim1_cdr) { TOP = cdr(TOP); } 354 | DEF(prim2_set_carB) { Obj z = pop(); set_car(TOP, z); TOP = sym_f; } 355 | DEF(prim0_read_char) { (void) read_char(); } 356 | DEF(prim0_peek_char) { ungetc(read_char(), stdin); } 357 | DEF(prim1_write_char) { putchar(untag(a_char, TOP)); TOP = sym_f; } 358 | DEF(prim0_abort) { exit(1); } 359 | 360 | #define TAILCALL(label, nargs) do { \\ 361 | memmove(stack + bp, stack + sp - (nargs) + 1, (nargs) * sizeof stack[0]); \\ 362 | sp = bp + (nargs) - 1; \\ 363 | goto label; \\ 364 | } while (0) 365 | 366 | void run(void **function, int bp) { 367 | if (function) goto *function;") 368 | 369 | (define postlude-lines 370 | "} 371 | 372 | int main() { run(NULL, 0); return 0; } 373 | ") 374 | 375 | (compile) 376 | -------------------------------------------------------------------------------- /notes.text: -------------------------------------------------------------------------------- 1 | add an optional param to bless, naming the executable to bless. 2 | also, blessing doesn't update the C reference anymore... 3 | 4 | it looks like we don't use global vars enough to make them truly 5 | indispensable; try getting rid of them. generate the symbol table 6 | specially. this avoids any possible circular-initialization problems, 7 | too. 8 | 9 | make dotted pairs impossible 10 | 11 | how to do closures: 12 | * switch to stop-and-copy to handle variable-sized objects gracefully 13 | * make flat closures, leaving out globals? 14 | but linked environments are probably simpler. 15 | * only handle up to 10 (say) slots in a frame, to not need arithmetic 16 | * reserve a tag for procedures 17 | * (probably) use direct jumps for calls to known procedures, for speed 18 | 19 | how to do curses: 20 | * tty-write-char (adds to the display buffer for the next refresh-screen) 21 | * tty-plant-cursor (on the next refresh, cursor will be placed at current pos) 22 | * tty-refresh 23 | * tty-get-key 24 | * tty-set-up, tty-tear-down (could be implicit if we use them always) 25 | * tty-key-waiting? (a bit of a frill) 26 | - expect a fixed terminal size? 27 | - we need some persistence mechanism for the editor 28 | - for games and such we also need timeouts 29 | 30 | can we deal with circular-initialization problems without too much 31 | extra complexity? 32 | 33 | get rid of the tail? param by inspecting the top of code-stack? 34 | 35 | bring back booleans and symbols as disjoint types? 36 | booleans because it's awkward to initialize and use sym_f/sym_t. 37 | [silly idea: use () and \t instead for false and true.] 38 | symbols because it's error-prone when they're not disjoint. 39 | 40 | maybe define a struct with car and cdr fields and delete the car() and 41 | cdr() functions. rename heap_index() to something more concise like at(). 42 | 43 | see how far you can squeeze the bootstrap interpreter, just for fun. 44 | also, why's it like hundreds of times slower than the compiled compiler? 45 | 46 | maybe we could cut down on source lines by adding some kind 47 | of mapping/iterating form. maybe. 48 | 49 | and of course we could save a few lines by using C-style 50 | identifiers only. bleah. 51 | 52 | 53 | 54 | DONE: 55 | types: nil, pair, character 56 | 57 | simpler syntax for chars: \c 58 | 59 | don't bother with dotted pairs, i guess 60 | 61 | similarly, a string is just a list of chars, read and printed 62 | specially 63 | 64 | a symbol is a string that happens to be in the symbol table, also read 65 | and printed specially 66 | 67 | use t and nil, or some such, for booleans. 68 | actually maybe we should include booleans as a disjoint type. 69 | but see how we do with this for now. 70 | 71 | (cond ((eq? proc 'eq?) (eq? (car args) (cadr args))) 72 | ((eq? proc 'null?) (null? (car args))) 73 | ((eq? proc 'pair?) (pair? (car args))) 74 | ((eq? proc 'char?) (char? (car args))) 75 | ((eq? proc 'cons) (cons (car args) (cadr args))) 76 | ((eq? proc 'car) (car (car args))) 77 | ((eq? proc 'cdr) (cdr (car args))) 78 | ((eq? proc 'set-car!) (set-car! (car args) (cadr args))) 79 | ((eq? proc 'read-char) (read-char)) 80 | ((eq? proc 'peek-char) (peek-char)) 81 | ((eq? proc 'write-char) (write-char (car args))) 82 | ((eq? proc 'abort) (abort)) ; actually (error x) 83 | 84 | use a unique-tag list for the EOF object (not a disjoint type) 85 | and a global variable naming it 86 | 87 | language: like icbins but with global vars, no get-global, and the 88 | above simplifications 89 | 90 | simplify it by outputting lines in reverse order 91 | (so the declarations at the top naturally are emitted last; 92 | and we avoid a couple gotos too.) 93 | 94 | make read-char/peek-char return () on eof 95 | 96 | change evseq to require a nonnull list 97 | 98 | switch from (error) back to (abort) as a primitive 99 | 100 | give the test driver more smarts about the output: 101 | - nicer multiline expectations 102 | - be able to get both non-error output and the terminating error 103 | also, some emacs support for the test driver 104 | 105 | require the cdr of a list to be a list -- simplifies code elsewhere 106 | 107 | interpreter & devel strategy: like 'Later.text' plans for icbins 108 | 109 | primitives left: 110 | ((eq? proc 'set-cdr!) (set-cdr! (car args) (cadr args))) 111 | and null? is dispensable 112 | 113 | look for other language simplifications since we're abandoning Scheme 114 | compatibility: 115 | 116 | (let var expr) 117 | (define (fn var ...) expr ...) 118 | 119 | use functional i/o? sort of need multiple-value support of some kind... 120 | and lists of chars are less primitive than read/write-char 121 | so no, i don't think so 122 | 123 | make cond default to 'f when running out of clauses. this can save a 124 | line when writing for-eaches (like (cond ((null? xs) 'ok) ). So, that 125 | saves 5 lines net. But I don't really like it. Most of those lines were 126 | for predicates rather than for-eaches, etc. But still, many conds-for-effect 127 | read more nicely without the default clause, so this goes in. 128 | 129 | get rid of (snarf) and make the compiler do its own reading as it goes 130 | along? this makes the compiler harder to reuse, though. 131 | 132 | simplify the compiler by accumulating def-names and def-exprs in 133 | separate lists? I don't think so... 134 | 135 | (express e syms) has different arg order from other functions with syms 136 | 137 | write code-emission in this style: (emit "foo;" (emit "bar;" 'ignored)) ? 138 | (to allow back-to-front emission with front-to-back-looking code) 139 | (has an efficiency cost though. kind of ugly in its own way.) 140 | 141 | capitalize Obj? 142 | -------------------------------------------------------------------------------- /tests/0.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/0.in -------------------------------------------------------------------------------- /tests/0.l: -------------------------------------------------------------------------------- 1 | (cond ('t (write-char \a) (write-char \b))) 2 | -------------------------------------------------------------------------------- /tests/0.ref: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/1.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/1.in -------------------------------------------------------------------------------- /tests/1.l: -------------------------------------------------------------------------------- 1 | (cond ('f (write-char \a)) 2 | ('t (write-char \b))) 3 | -------------------------------------------------------------------------------- /tests/1.ref: -------------------------------------------------------------------------------- 1 | b -------------------------------------------------------------------------------- /tests/2.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/2.in -------------------------------------------------------------------------------- /tests/2.l: -------------------------------------------------------------------------------- 1 | (write-char (cond ('f \a) ('t \b))) 2 | -------------------------------------------------------------------------------- /tests/2.ref: -------------------------------------------------------------------------------- 1 | b -------------------------------------------------------------------------------- /tests/3.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/3.in -------------------------------------------------------------------------------- /tests/3.l: -------------------------------------------------------------------------------- 1 | (to (f) (write-char \a) (write-char \b)) 2 | (f) 3 | -------------------------------------------------------------------------------- /tests/3.ref: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/4.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/4.in -------------------------------------------------------------------------------- /tests/4.l: -------------------------------------------------------------------------------- 1 | (to (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (to (try x) 8 | (write-char (cond ((string? x) \t) ('t \f))) 9 | (write-char \ 10 | )) 11 | 12 | (try '()) 13 | (try '"hell") 14 | (try '(\h \e "ll")) 15 | -------------------------------------------------------------------------------- /tests/4.ref: -------------------------------------------------------------------------------- 1 | t 2 | t 3 | f 4 | -------------------------------------------------------------------------------- /tests/5.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/ichbins/7297bd2f16281df5a1042209c9b49d43ace654a2/tests/5.in -------------------------------------------------------------------------------- /tests/5.l: -------------------------------------------------------------------------------- 1 | (to (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (to (string=? s t) 8 | (cond ((null? s) (null? t)) 9 | ((null? t) 'f) 10 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 11 | ('t 'f))) 12 | 13 | (to (memq? x xs) 14 | (cond ((null? xs) 'f) 15 | ((eq? x (car xs)) 't) 16 | ('t (memq? x (cdr xs))))) 17 | 18 | (to (cons! x xs-cell) 19 | (set-car! xs-cell (cons x (car xs-cell)))) 20 | 21 | (define symbols '((f))) 22 | 23 | (to (symbol? x) 24 | (memq? x (car symbols))) 25 | 26 | (to (intern s) 27 | (intern-lookup s (car symbols))) 28 | 29 | (to (intern-lookup s syms) 30 | (cond ((null? syms) (cons! s symbols) s) 31 | ((string=? s (car syms)) (car syms)) 32 | ('t (intern-lookup s (cdr syms))))) 33 | 34 | (to (print x) 35 | (write x) 36 | (write-char \ 37 | )) 38 | 39 | (to (write x) 40 | (cond ((null? x) (write-string '"()")) 41 | ((char? x) (write-char \\) (write-char x)) 42 | ((string? x) 43 | (cond ((symbol? x) (write-string x)) 44 | ('t (write-char \") (write-string x) (write-char \")))) 45 | ('t (write-char \() 46 | (write (car x)) 47 | (write-each (cdr x)) 48 | (write-char \))))) 49 | 50 | (to (write-each xs) 51 | (cond ((null? xs) 'f) 52 | ('t (write-char \ ) 53 | (write (car xs)) 54 | (write-each (cdr xs))))) 55 | 56 | (to (write-string chars) 57 | (cond ((null? chars) 'f) 58 | ('t (write-char (car chars)) 59 | (write-string (cdr chars))))) 60 | 61 | (print '()) 62 | (print '"abc") 63 | (print '(\a (\b))) 64 | (print (cons (intern '"hello") '(f "world"))) 65 | -------------------------------------------------------------------------------- /tests/5.ref: -------------------------------------------------------------------------------- 1 | () 2 | "abc" 3 | (\a "b") 4 | (hello f "world") 5 | -------------------------------------------------------------------------------- /tests/6.in: -------------------------------------------------------------------------------- 1 | (define (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (define (string=? s t) 8 | (cond ((null? s) (null? t)) 9 | ((null? t) 'f) 10 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 11 | ('t 'f))) 12 | 13 | -------------------------------------------------------------------------------- /tests/6.l: -------------------------------------------------------------------------------- 1 | (to (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (to (string=? s t) 8 | (cond ((null? s) (null? t)) 9 | ((null? t) 'f) 10 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 11 | ('t 'f))) 12 | 13 | (to (memq? x xs) 14 | (cond ((null? xs) 'f) 15 | ((eq? x (car xs)) 't) 16 | ('t (memq? x (cdr xs))))) 17 | 18 | (to (cons! x xs-cell) 19 | (set-car! xs-cell (cons x (car xs-cell)))) 20 | 21 | (define symbols '((f quote))) 22 | 23 | (to (symbol? x) 24 | (memq? x (car symbols))) 25 | 26 | (to (intern s) 27 | (intern-lookup s (car symbols))) 28 | 29 | (to (intern-lookup s syms) 30 | (cond ((null? syms) (cons! s symbols) s) 31 | ((string=? s (car syms)) (car syms)) 32 | ('t (intern-lookup s (cdr syms))))) 33 | 34 | (to (print x) 35 | (write x) 36 | (newline)) 37 | 38 | (to (newline) 39 | (write-char \ 40 | )) 41 | 42 | (to (write x) 43 | (cond ((null? x) (write-string '"()")) 44 | ((char? x) (write-char \\) (write-char x)) 45 | ((string? x) 46 | (cond ((symbol? x) (write-string x)) 47 | ('t (write-char \") (write-string x) (write-char \")))) 48 | ('t (write-char \() 49 | (write (car x)) 50 | (write-each (cdr x)) 51 | (write-char \))))) 52 | 53 | (to (write-each xs) 54 | (cond ((null? xs) 'f) 55 | ('t (write-char \ ) 56 | (write (car xs)) 57 | (write-each (cdr xs))))) 58 | 59 | (to (write-string chars) 60 | (cond ((null? chars) 'f) 61 | ('t (write-char (car chars)) 62 | (write-string (cdr chars))))) 63 | 64 | 65 | (to (error plaint) 66 | (write-string plaint) 67 | (newline) 68 | (abort)) 69 | 70 | (to (read) 71 | (skip-blanks (peek-char)) 72 | (read-dispatch (read-char))) 73 | 74 | (to (skip-blanks c) 75 | (cond ((char-whitespace? c) 76 | (read-char) 77 | (skip-blanks (peek-char))) 78 | ('t 'ok))) 79 | 80 | (to (char-whitespace? c) 81 | (memq? c '" 82 | ")) 83 | 84 | (define non-symbol-chars (cons \" '"\(')")) 85 | 86 | (define eof-object '("eof")) 87 | 88 | (to (read-dispatch c) 89 | (cond ((eq? c 'f) eof-object) 90 | ((eq? c \\) (read-char-literal (read-char))) 91 | ((eq? c \") (read-string (read-char))) 92 | ((eq? c \() (read-list)) 93 | ((eq? c \') (cons 'quote (cons (read) '()))) 94 | ((eq? c \)) (error '"Unbalanced parentheses")) 95 | ('t (intern (cons c (read-symbol (peek-char))))))) 96 | 97 | (to (read-char-literal c) 98 | (cond ((eq? c 'f) (error '"EOF in character literal")) 99 | ('t c))) 100 | 101 | (to (read-string c) 102 | (cond ((eq? c 'f) (error '"Unterminated string literal")) 103 | ((eq? c \") '()) 104 | ('t (cons c (read-string (read-char)))))) 105 | 106 | (to (read-symbol c) 107 | (cond ((char-whitespace? c) '()) 108 | ((memq? c non-symbol-chars) '()) 109 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 110 | 111 | (to (read-list) 112 | (skip-blanks (peek-char)) 113 | (read-list-dispatch (read-char))) 114 | 115 | (to (read-list-dispatch c) 116 | (cond ((eq? c 'f) (error '"Unterminated list")) 117 | ((eq? c \)) '()) 118 | ('t (cons (read-dispatch c) (read-list))))) 119 | 120 | 121 | (print (read)) 122 | (print (read)) 123 | -------------------------------------------------------------------------------- /tests/6.ref: -------------------------------------------------------------------------------- 1 | (define (string? x) (cond ((null? x) (quote t)) ((char? x) (quote f)) ((char? (car x)) (string? (cdr x))) ((quote t) (quote f)))) 2 | (define (string=? s t) (cond ((null? s) (null? t)) ((null? t) (quote f)) ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) ((quote t) (quote f)))) 3 | -------------------------------------------------------------------------------- /tests/7.in: -------------------------------------------------------------------------------- 1 | (define (write-line cs) 2 | (cond ((null? cs) (write-char \ 3 | )) 4 | ('t (write-char (car cs)) 5 | (write-line (cdr cs))))) 6 | 7 | (write-line '"Hello, world!") 8 | -------------------------------------------------------------------------------- /tests/7.l: -------------------------------------------------------------------------------- 1 | (to (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (to (string=? s t) 8 | (cond ((null? s) (null? t)) 9 | ((null? t) 'f) 10 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 11 | ('t 'f))) 12 | 13 | (to (memq? x xs) 14 | (cond ((null? xs) 'f) 15 | ((eq? x (car xs)) 't) 16 | ('t (memq? x (cdr xs))))) 17 | 18 | (to (cons! x xs-cell) 19 | (set-car! xs-cell (cons x (car xs-cell)))) 20 | 21 | (define symbols 22 | '((t f eof-object define quote cond 23 | eq? null? pair? char? cons car cdr 24 | set-car! read-char peek-char write-char 25 | abort))) 26 | 27 | (to (symbol? x) 28 | (memq? x (car symbols))) 29 | 30 | (to (intern s) 31 | (intern-lookup s (car symbols))) 32 | 33 | (to (intern-lookup s syms) 34 | (cond ((null? syms) (cons! s symbols) s) 35 | ((string=? s (car syms)) (car syms)) 36 | ('t (intern-lookup s (cdr syms))))) 37 | 38 | (to (print x) 39 | (write x) 40 | (newline)) 41 | 42 | (to (newline) 43 | (write-char \ 44 | )) 45 | 46 | (to (write x) 47 | (cond ((null? x) (write-string '"()")) 48 | ((char? x) (write-char \\) (write-char x)) 49 | ((string? x) 50 | (cond ((symbol? x) (write-string x)) 51 | ('t (write-char \") (write-string x) (write-char \")))) 52 | ('t (write-char \() 53 | (write (car x)) 54 | (write-each (cdr x)) 55 | (write-char \))))) 56 | 57 | (to (write-each xs) 58 | (cond ((null? xs) 'f) 59 | ('t (write-char \ ) 60 | (write (car xs)) 61 | (write-each (cdr xs))))) 62 | 63 | (to (write-string chars) 64 | (cond ((null? chars) 'f) 65 | ('t (write-char (car chars)) 66 | (write-string (cdr chars))))) 67 | 68 | 69 | (to (error plaint) 70 | (write-string plaint) 71 | (newline) 72 | (abort)) 73 | 74 | (to (read) 75 | (skip-blanks (peek-char)) 76 | (read-dispatch (read-char))) 77 | 78 | (to (skip-blanks c) 79 | (cond ((char-whitespace? c) 80 | (read-char) 81 | (skip-blanks (peek-char))) 82 | ('t 'ok))) 83 | 84 | (to (char-whitespace? c) 85 | (memq? c '" 86 | ")) 87 | 88 | (define non-symbol-chars (cons \" '"\(')")) 89 | 90 | (define eof-object '("eof")) 91 | 92 | (to (read-dispatch c) 93 | (cond ((eq? c 'f) eof-object) 94 | ((eq? c \\) (read-char-literal (read-char))) 95 | ((eq? c \") (read-string (read-char))) 96 | ((eq? c \() (read-list)) 97 | ((eq? c \') (cons 'quote (cons (read) '()))) 98 | ((eq? c \)) (error '"Unbalanced parentheses")) 99 | ('t (intern (cons c (read-symbol (peek-char))))))) 100 | 101 | (to (read-char-literal c) 102 | (cond ((eq? c 'f) (error '"EOF in character literal")) 103 | ('t c))) 104 | 105 | (to (read-string c) 106 | (cond ((eq? c 'f) (error '"Unterminated string literal")) 107 | ((eq? c \") '()) 108 | ('t (cons c (read-string (read-char)))))) 109 | 110 | (to (read-symbol c) 111 | (cond ((char-whitespace? c) '()) 112 | ((memq? c non-symbol-chars) '()) 113 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 114 | 115 | (to (read-list) 116 | (skip-blanks (peek-char)) 117 | (read-list-dispatch (read-char))) 118 | 119 | (to (read-list-dispatch c) 120 | (cond ((eq? c 'f) (error '"Unterminated list")) 121 | ((eq? c \)) '()) 122 | ('t (cons (read-dispatch c) (read-list))))) 123 | 124 | 125 | (define definitions '(())) 126 | (define global-vars '(())) 127 | (define global-vals '(())) 128 | 129 | (to (repl form) 130 | (cond ((eq? eof-object form) 'f) 131 | ('t (eval-form form) 132 | (repl (read))))) 133 | 134 | (to (eval-form form) 135 | (cond ((cond ((pair? form) (eq? (car form) 'define)) 136 | ('t 'f)) 137 | (eval-define (cdr form))) 138 | ('t (print (eval form '() '()))))) 139 | 140 | (to (eval-define defn) 141 | (cond ((symbol? (car defn)) 142 | (define-global (car defn) 143 | (eval (car (cdr defn)) '() '()))) 144 | ('t (cons! defn definitions)))) 145 | 146 | (to (define-global var val) 147 | (cons! var global-vars) 148 | (cons! val global-vals)) 149 | 150 | (to (eval e vars vals) 151 | (cond ((pair? e) 152 | (cond ((symbol? e) (lookup e vars vals)) 153 | ('t (eval-pair (car e) (cdr e) vars vals)))) 154 | ('t e))) 155 | 156 | (to (eval-pair rator rands vars vals) 157 | (cond ((eq? rator 'quote) (car rands)) 158 | ((eq? rator 'cond) (evcond rands vars vals)) 159 | ('t (apply rator (evlis rands vars vals))))) 160 | 161 | (to (evlis es vars vals) 162 | (cond ((null? es) '()) 163 | ('t (cons (eval (car es) vars vals) 164 | (evlis (cdr es) vars vals))))) 165 | 166 | (to (evcond clauses vars vals) 167 | (cond ((null? clauses) '"No matching cond clause yo") 168 | ((eval (car (car clauses)) vars vals) 169 | (evseq (cdr (car clauses)) vars vals)) 170 | ('t (evcond (cdr clauses) vars vals)))) 171 | 172 | (to (evseq es vars vals) 173 | (cond ((null? (cdr es)) (eval (car es) vars vals)) 174 | ('t (eval (car es) vars vals) 175 | (evseq (cdr es) vars vals)))) 176 | 177 | (to (lookup var vars vals) 178 | (cond ((null? vars) (lookup1 var (car global-vars) (car global-vals))) 179 | ((eq? var (car vars)) (car vals)) 180 | ('t (lookup var (cdr vars) (cdr vals))))) 181 | 182 | (to (lookup1 var vars vals) 183 | (cond ((null? vars) (error '"Unbound variable yo")) 184 | ((eq? var (car vars)) (car vals)) 185 | ('t (lookup1 var (cdr vars) (cdr vals))))) 186 | 187 | (to (apply rator args) 188 | (cond ((eq? rator 'eq?) (eq? (car args) (car (cdr args)))) 189 | ((eq? rator 'null?) (null? (car args))) 190 | ((eq? rator 'pair?) (pair? (car args))) 191 | ((eq? rator 'char?) (char? (car args))) 192 | ((eq? rator 'cons) (cons (car args) (car (cdr args)))) 193 | ((eq? rator 'car) (car (car args))) 194 | ((eq? rator 'cdr) (cdr (car args))) 195 | ((eq? rator 'set-car!) (set-car! (car args) (car (cdr args)))) 196 | ((eq? rator 'read-char) (read-char)) 197 | ((eq? rator 'peek-char) (peek-char)) 198 | ((eq? rator 'write-char) (write-char (car args))) 199 | ((eq? rator 'error) (error (car args))) 200 | ('t (call rator args (car definitions))))) 201 | 202 | (to (call rator args defs) 203 | (cond ((null? defs) (error '"Unknown rator")) 204 | ((eq? rator (car (car (car defs)))) 205 | (evseq (cdr (car defs)) (cdr (car (car defs))) args)) 206 | ('t (call rator args (cdr defs))))) 207 | 208 | 209 | (repl (read)) 210 | -------------------------------------------------------------------------------- /tests/7.ref: -------------------------------------------------------------------------------- 1 | Hello, world! 2 | f 3 | -------------------------------------------------------------------------------- /tests/complain: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "$@" >/dev/stderr 4 | echo 1 5 | -------------------------------------------------------------------------------- /tests/testall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for f in 0 1 2 3 4 5 6 7 4 | do 5 | ./testone $1 $f 6 | done 7 | -------------------------------------------------------------------------------- /tests/testone: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | compile=$1; shift 4 | f=$1; shift 5 | 6 | $compile <$f.l >$f.c || exit `./complain $f did not compile` 7 | gcc -g2 -Wall -Wno-unused-function $f.c -o $f || exit `./complain $f.c did not compile` 8 | 9 | ./$f <$f.in >$f.out || exit `./complain Error in $f` 10 | diff $f.ref $f.out || exit `./complain Mismatch in $f` 11 | --------------------------------------------------------------------------------