├── .gitignore ├── LICENSE ├── README.md └── mini-sk.c /.gitignore: -------------------------------------------------------------------------------- 1 | # ZX Spectrum files 2 | *.tap 3 | *.bin 4 | 5 | # Prerequisites 6 | *.d 7 | 8 | # Object files 9 | *.o 10 | *.ko 11 | *.obj 12 | *.elf 13 | 14 | # Linker output 15 | *.ilk 16 | *.map 17 | *.exp 18 | 19 | # Precompiled Headers 20 | *.gch 21 | *.pch 22 | 23 | # Libraries 24 | *.lib 25 | *.a 26 | *.la 27 | *.lo 28 | 29 | # Shared objects (inc. Windows DLLs) 30 | *.dll 31 | *.so 32 | *.so.* 33 | *.dylib 34 | 35 | # Executables 36 | *.exe 37 | *.out 38 | *.app 39 | *.i*86 40 | *.x86_64 41 | *.hex 42 | 43 | # Debug files 44 | *.dSYM/ 45 | *.su 46 | *.idb 47 | *.pdb 48 | 49 | # Kernel Module Compile Results 50 | *.mod* 51 | *.cmd 52 | .tmp_versions/ 53 | modules.order 54 | Module.symvers 55 | Mkfile.old 56 | dkms.conf 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 imneme 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mini-SK 2 | 3 | Mini-SK is provides a functional programming environment in the form 4 | of an S/K/I/B/C combinator reduction machine. It specifically targets 5 | “small” machines of the past including the ZX Spectrum with most data 6 | sizes limited to 16 bits. The code is written in C89 (ANSI C) to 7 | allow it to be compiled with older compilers on ancient systems. It 8 | also runs happily on modern 32-bit and 64-bit computers, however. 9 | 10 | Dispite its simplicity, Mini-SK provides many of the features we'd 11 | normally expect from a functional language, including full laziness 12 | (expressions are only evaluated when needed, and only once even if 13 | they are shared). Efficient tail recursion is intrinsically 14 | supported. 15 | 16 | Mini-SK is copyright 2020, Melissa O'Neill and distributed under the 17 | MIT License. 18 | 19 | ## Overview 20 | 21 | Expressing computation using combinator expressions was originally 22 | suggested by [Moses Schönfinkel][1] in his 1924 paper [_On the 23 | Building Blocks of Mathematical Logic_][2]. In that paper, he 24 | suggested the following fundamental operators: 25 | ``` 26 | (((S f) g) x) -> ((f x) (g x)) -- Fusion [S] 27 | ((K x) y) -> x -- Constant [C] 28 | (I x) -> x -- Identity [I] 29 | (((B f) g) x) -> (f (g x)) -- Composition [Z] 30 | (((C f) x) y) -> ((f y) x) -- Interchange [T] 31 | ``` 32 | 33 | The letters in square brackets are the ones used by Schönfinkel. 34 | Schönfinkel noted that S and K are suffient because they can implement 35 | the others as follows: 36 | ``` 37 | ((S K) K) ≡ I 38 | (((S (K f)) g) x) ≡ (((B f) g) x) 39 | (((S f) (K x)) y) ≡ (((C f) x) y) 40 | ``` 41 | but in practice it is often preferable to use the full set as it avoids needless duplication of data, only to discard it with `K`. 42 | 43 | Elsewhere in the literature, the many of the parentheses shown above 44 | are omitted, writing `S K K S` instead of `(((S K) K) S)`. In the 45 | interests of keeping its parser as simple as possible, Mini-SK does 46 | not support the omitting implied parentheses. You can however, enter 47 | omit redundant spaces, and enter applications using the `@` sign, thus 48 | you may write the above as for example `@@@SKKS`. You can mix both 49 | notations, and in fact, `@` and `(` are synonyms, and close parentheses 50 | are optional and ignored! 51 | 52 | In addition, the implementation supports placeholders `a`..`z` that can be 53 | passed into expressions to understand what they do and perform 54 | computations, (thus `((K a) b)` reduces to `a`), and Church numerals, 55 | entered as # followed by the number, such as `#10`. A number of 56 | pre-written expressions are provided as macros that are expanded by 57 | the parser (except for the version for the 16K ZX Spectrum where they 58 | are omitted to save space). These macros are entered as enter as `$` 59 | immediately followed by a descriptive name, such as `$t` for true, or 60 | `$quicksort` for the QuickSort algorithm. 61 | 62 | ### Scope and Features 63 | 64 | Although the S/K/I/B/C combinators may seem primitive, they are 65 | sufficient to compute all computable functions. In version 1.0 of 66 | Mini-SK, these combinators are all that are supported, but a number of 67 | predefined examples are available as convenience macros, allowing you 68 | to experiment with lists, QuickSort, and even other languages such as 69 | Jot without needing to type in complex and cryptic expressions. 70 | 71 | Version 1.2 extends the minimal base by providing programmer-friendly 72 | features, such as built-in binary numbers, and I/O facilities. In 73 | this version, the lower-case letter placeholders become just an 74 | alternative way to express character constants, in other words `x` is 75 | just another way of saying `'x`. 76 | 77 | ## Demos 78 | 79 | This [video](https://vimeo.com/431042094) shows a demo of Mini-SK 80 | running on a 16K ZX Spectrum (with approximately 8KB of usable 81 | memory). 82 | 83 | ## Literals, Arithmetic and I/O 84 | 85 | The combinators `S`, `K`, `I`, etc. are literals, but there are 32768 86 | possible literals and all can be entered. In version 1.2 and beyond, 87 | characters are entered with a leading quote and then the next 88 | character read is the literal even if it is whitespace. Numbers can 89 | also be entered in their usual decimal form. 90 | 91 | Because the printer used by the REPL knows nothing of what a literal 92 | value is intended to mean, it adopts a heuristic approach for printing 93 | literals: if the value matches the code used for a combinator it is 94 | printed as that combinator, and if it is in the range of printable 95 | ASCII, it is printed as a character literal, otherwise it is shown as 96 | an integer. 97 | 98 | Generally, except for the combinators, you should not attempt to 99 | _apply_ a literal to another value and evaluate the result. That 100 | said, literal values in the range 0..255 are always safe to apply to 101 | values -- they don't reduce and reduction will stop at that point. 102 | However, to assist in understanding what functions do, in the REPL 103 | when output results are printed, it _will_ reduce the arguments to 104 | character/byte literals, causing `(Y 'x)` to expand to `(x (x (x 105 | (x...` until it runs out of space. Attempting to apply other numbers 106 | will have unspecified results if the number does not correspond to an 107 | actual combinator. 108 | 109 | ### Arithmetic 110 | 111 | Arithmetic and comparison operators are provided for literals via the 112 | combiators `+`, `-`, `*`, `/`, `=`, and `<`, however they are somewhat 113 | unusual in that they take _three_ arguments, because the first 114 | argument is a _continuation function_ that the result will be passed 115 | to. 116 | 117 | Thus, if you just want to add two and three, you can use the identity 118 | function as a trivial continuation, this `(((+ I) 2) 3)`. You don't 119 | write `((+ 2) 3)`! 120 | 121 | The reason for this continuation-based design is that in the simpler 122 | design, `(K ((+ 2) 3))` would not reduce to `K 5` because of laziness, 123 | but `(((+ K) 2) 3)` _does_ reduce to `(K 5)`. In other words, the 124 | continuation-passing style allows you to control the extent to which 125 | Mini-SK is lazy. 126 | 127 | ### I/O 128 | 129 | The `G` (getchar) and `P` (putchar) combinators provide I/O. 130 | 131 | * `(G c)` gets a character and passes it to continuation `c`. 132 | * `(P c x)` puts a character `x` and continues with `c`. 133 | 134 | ### Examples of I/O and Arithmetic 135 | 136 | The code below adds two numbers to produce the number `4254`: 137 | ``` 138 | (((+ I) 4200) 54) 139 | ``` 140 | 141 | This code converts a Church numeral for 729 (3^6) into its literal 142 | form by using an increment function applied to zero 143 | ``` 144 | (((#6 #3) ((+ I) 1)) 0) 145 | ``` 146 | however, the above code uses space proportional to the size of the 147 | number because laziness means that none of the additions are done 148 | until the end and thus they are saved up. 149 | 150 | In contrast, the code below uses the continuation-passing feature of 151 | the addition operator to perform the addition as we go. 152 | ``` 153 | ((((#6 #3) ((C +) 1)) I 0)) 154 | ``` 155 | 156 | The code below gets a character from input and prints it out, and then 157 | returns the identity function. 158 | ``` 159 | (G (P I)) 160 | ``` 161 | and this version adds a newline afterwards 162 | ``` 163 | (G (P ((P I) 10))) 164 | ``` 165 | 166 | The code below runs forever, copying standard input to standard output: 167 | ``` 168 | (Y ((B G) P)) 169 | ``` 170 | and this code (which can be entered as `@Y@@BG@C$cons`) turns input 171 | into in infinite list of characters that can be read using `$hd`, 172 | `$tail`, etc. 173 | ``` 174 | (Y ((B G) (C ((B C) J)))) 175 | ``` 176 | 177 | In subsequent examples, we'll use the `@` shorthand for most applications. 178 | 179 | 180 | The code below prints 243 (3^5) 'x's, followed by a newline (ASCII 10), and 181 | returns the identity function as its result. 182 | ``` 183 | @@(#5 #3) @@CP'x @@PI10 184 | ``` 185 | whereas this version reads the character to be printed multiple times 186 | from the user 187 | ``` 188 | @@G@@B(#5 #3) @CP @@PI10 189 | ``` 190 | 191 | Finally, this code outputs a number of 'x's counted not using Church 192 | numerals but built in numbers. 193 | ``` 194 | @@@@@BY@@B@B@S@@C@@C@=I0I@@C@@BC@@B@BC@@B@B-@C@@BC@BP1'x243@@PI10 195 | ``` 196 | Note that this version has to go to more effort than the Church 197 | numeral version, with explicit recursion, decrementing, and tests 198 | against zero for completion. It does, however, run in constant space 199 | regardless of the size of the number. 200 | 201 | ### Additional Combinators 202 | 203 | For convenience the system provides two additional combinators: 204 | 205 | * `F` (false) is equivalent to `(K I)`, such that `((F x) y)` → `y`. 206 | * `J` (jump) is equivalent to `(C I)`, such that `((J x) y)` → `(y x)`. 207 | 208 | ## Installing 209 | 210 | Prebuilt binaries are provided with releases for ZX Spectrum variants and 211 | for macOS and x86 Linux. 212 | 213 | ## Building 214 | 215 | Optional defines 216 | 217 | * `-DTINY_VERSION` 218 | 219 | Eliminate built-in values and other extraneous features to make a 220 | smaller executable for machines with limited memory. 221 | 222 | * `-DUSE_MINILIB` 223 | 224 | Under z88dk (Z80), [MiniLib](https://github.com/imneme/spectrum-minilib) 225 | provides an alternative crt and stdio library to minimize space usage. 226 | 227 | * `-DDEBUG` 228 | 229 | Produce voluminous debugging output. 230 | 231 | * `-DNDEBUG` 232 | 233 | Disable sanity checking and assert statements. 234 | 235 | ## Supported compilers and suggested command lines 236 | 237 | ### Linux/macOS -- GCC & Clang 238 | ``` 239 | clang -O3 -DNDEBUG -DMAX_APPS=32767 -DMAX_STACK=32767 -Wall -o mini-sk mini-sk.c 240 | ``` 241 | ### CP/M -- Z88DK 242 | ``` 243 | zcc +cpm -DNDEBUG -SO3 --max-allocs-per-node200000 -startup=0 -clib=sdcc_iy mini-sk.c -o mini-sk -create-app 244 | ``` 245 | 246 | ### CP/M -- Hi Tech C v3.09 247 | ``` 248 | c -DNDEBUG -O mini-sk.c 249 | ``` 250 | 251 | ### ZX Spectrum (16k) -- Z88DK & MINILIB 252 | ``` 253 | zcc +zx -DUSE_MINILIB -DNDEBUG -DTINY_VERSION -SO3 --max-allocs-per-node200000 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZX_INIT=1 mini-sk.oc -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:27136 -create-app 254 | ``` 255 | 256 | ### ZX Spectrum (48k) -- Z88DK & MINILIB 257 | ``` 258 | zcc +zx -DUSE_MINILIB -DNDEBUG -SO3 --max-allocs-per-node200000 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZX_INIT=1 mini-sk.c -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:31232 -create-app 259 | ``` 260 | 261 | ### ZX Spectrum (48k) -- Z88DK 262 | ``` 263 | zcc +zx -DNDEBUG -SO3 --max-allocs-per-node200000 -startup=8 -clib=sdcc_iy mini-sk.c -o mini-sk -zorg:24064 -pragma-define:CRT_ITERM_INKEY_REPEAT_START=8000 -pragma-define:CRT_ITERM_INKEY_REPEAT_RATE=250 -pragma-redirect:CRT_OTERM_FONT_FZX=_ff_dkud1_Sinclair -create-app 264 | ``` 265 | 266 | ### ZX Spectrum Next -- Z88DK & MINILIB 267 | ``` 268 | zcc +zxn -no-cleanup -DUSE_MINILIB -DNDEBUG -SO3 --max-allocs-per-node200000 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZXN_INIT=1 mini-sk.c -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:30720 -create-app 269 | ``` 270 | 271 | ### ZX Spectrum Next -- Z88DK 272 | ``` 273 | zcc +zxn -DNDEBUG --max-allocs-per-node200000 -SO3 -startup=8 -clib=sdcc_iy mini-sk.c -o mini-sk -zorg:24064 -pragma-define:CRT_ITERM_INKEY_REPEAT_START=8000 -pragma-define:CRT_ITERM_INKEY_REPEAT_RATE=250 -pragma-redirect:CRT_OTERM_FONT_FZX=_ff_dkud1_Sinclair -create-app 274 | ``` 275 | 276 | [1]: https://en.wikipedia.org/wiki/Moses_Schönfinkel "Wikipedia" 277 | [2]: https://courses.engr.illinois.edu/cs522/sp2016/OnTheBuildingBlocksOfMathematicalLogic.pdf "English translation, PDF" -------------------------------------------------------------------------------- /mini-sk.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mini-SK, a S/K/I/B/C combinator reduction machine. 3 | * 4 | * Copyright 2020, Melissa O'Neill. Distributed under the MIT License. 5 | * 6 | * This program implements an evaluator to evaluate combinator expressions, as 7 | * originally suggested by Moses Shoenfinkel in his 1924 paper _On the 8 | * Building Blocks of Mathematical Logic_, where: 9 | * 10 | * (((S f) g) x) -> ((f x) (g x)) -- Fusion [S] 11 | * ((K x) y) -> x -- Constant [C] 12 | * (I x) -> x -- Identity [I] 13 | * (((B f) g) x) -> (f (g x)) -- Composition [Z] 14 | * (((C f) x) y) -> ((f y) x) -- Interchange [T] 15 | * 16 | * The letters in square brackets are the ones used by Schoenfinkel. 17 | * 18 | * Mini-SK does not support the omitting implied parentheses, thus to evaluate 19 | * for example, S K K S, it must be entered as 20 | * 21 | * (((S K) K) S) 22 | * or 23 | * @@@SKKS 24 | * 25 | * In addition, the implementation supports placeholders a..z that can be 26 | * passed into expressions, and church numerals, entered as # followed by the 27 | * number, such as #10. A number of pre-written expressions are provided, 28 | * enter as $name, such as $true. 29 | * 30 | * Mini-SK is designed to be simple and minimal, specifically targetting 31 | * “small” machines of the past. The code is written in C89 (ANSI C) to allow 32 | * it to be compiled with older compilers on ancient systems. 33 | * 34 | * Optional defines 35 | * 36 | * -DTINY_VERSION 37 | * Eliminate built-in values and other extraneous features to make a 38 | * smaller executable for machines with limited memory. 39 | * -DUSE_MINILIB 40 | * Under z88dk (Z80), Minilib provides an alternative crt and stdio 41 | * library to minimize space usage. 42 | * -DDEBUG 43 | * Produce voluminous debugging output. 44 | * -DNDEBUG 45 | * Disable sanity checking and assert statements. 46 | * 47 | * Supported compilers and suggested command lines: 48 | * 49 | * Linux/macOS -- GCC & Clang 50 | * clang -O3 -DNDEBUG -DMAX_APPS=32767 -DMAX_STACK=32767 -Wall -o mini-sk mini-sk.c 51 | * 52 | * CP/M -- Z88DK 53 | * zcc +cpm -DNDEBUG -SO3 --max-allocs-per-node500000 -startup=0 -clib=sdcc_iy mini-sk.c -o mini-sk -create-app 54 | * 55 | * CP/M -- Hi Tech C v3.09 56 | * c -DNDEBUG -O mini-sk.c 57 | * 58 | * ZX Spectrum (16k) -- Z88DK & MINILIB 59 | * zcc +zx -DUSE_MINILIB -DNDEBUG -DTINY_VERSION -SO3 --max-allocs-per-node500000 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZX_INIT=1 mini-sk.oc -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:27136 -create-app 60 | * 61 | * ZX Spectrum (48k) -- Z88DK & MINILIB 62 | * zcc +zx -DUSE_MINILIB -DNDEBUG -SO3 --max-allocs-per-node500000 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZX_INIT=1 mini-sk.c -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:31232 -create-app 63 | * 64 | * ZX Spectrum (48k) -- Z88DK 65 | * zcc +zx -DNDEBUG --max-allocs-per-node500000 -SO3 -startup=8 -clib=sdcc_iy mini-sk.c -o mini-sk -zorg:24064 -pragma-define:CRT_ITERM_INKEY_REPEAT_START=8000 -pragma-define:CRT_ITERM_INKEY_REPEAT_RATE=250 -pragma-redirect:CRT_OTERM_FONT_FZX=_ff_dkud1_Sinclair -create-app 66 | * 67 | * ZX Spectrum Next -- Z88DK & MINILIB 68 | * zcc +zxn -no-cleanup -DUSE_MINILIB -DNDEBUG -SO3 -clib=sdcc_ix --reserve-regs-iy -pragma-define:CRT_ZXN_INIT=1 mini-sk.c -o mini-sk -Ispectrum-minilib -Lspectrum-minilib -lmini -startup=" -1" -zorg:30720 -create-app 69 | * 70 | * ZX Spectrum Next -- Z88DK 71 | * zcc +zxn -DNDEBUG --max-allocs-per-node500000 -SO3 -startup=8 -clib=sdcc_iy mini-sk.c -o mini-sk -zorg:24064 -pragma-define:CRT_ITERM_INKEY_REPEAT_START=8000 -pragma-define:CRT_ITERM_INKEY_REPEAT_RATE=250 -pragma-redirect:CRT_OTERM_FONT_FZX=_ff_dkud1_Sinclair -create-app 72 | * 73 | */ 74 | 75 | #ifdef USE_MINILIB 76 | #include 77 | #else 78 | #include 79 | #endif 80 | #include 81 | #include 82 | #include 83 | 84 | #ifdef HI_TECH_C 85 | #define const 86 | #define signed 87 | typedef unsigned short uint16_t; 88 | typedef unsigned char uint8_t; 89 | #else 90 | #include 91 | #endif 92 | 93 | #ifdef __Z88DK 94 | #ifdef __SPECTRUM 95 | #include 96 | #endif 97 | #else 98 | #define __z88dk_fastcall 99 | #endif 100 | 101 | #define ARRAY_SIZE(array) sizeof(array)/sizeof(*(array)) 102 | 103 | /* Note, we can't use varargs macros in this vanilla C89-style code */ 104 | #ifdef DEBUG 105 | #define debug_printf(args) printf args 106 | #else 107 | #define debug_printf(args) 108 | #endif 109 | 110 | #ifdef TINY_VERSION 111 | /* 112 | * No switchable I/O. 113 | */ 114 | 115 | #define getch() getchar() 116 | #define ungetch(c) ungetchar(c) 117 | 118 | #else 119 | /* 120 | * Switchable I/O. 121 | * 122 | * We can read either from stdin or from memory. 123 | */ 124 | 125 | void* input_context; 126 | 127 | short fgetchar(void) 128 | { 129 | return (short)getc(input_context); 130 | } 131 | 132 | short fungetchar(char c) 133 | { 134 | return (short)ungetc(c, (FILE*) input_context); 135 | } 136 | 137 | short sgetchar(void) 138 | { 139 | char c = *(*((char**)input_context))++; 140 | if (c == '\0') 141 | return -1; 142 | else 143 | return c; 144 | } 145 | 146 | short sungetchar(char c) 147 | { 148 | char* cp = --(*((char**)input_context)); 149 | assert(*cp == c); 150 | return 1; 151 | } 152 | 153 | short(*getch)(void) = fgetchar; 154 | short(*ungetch)(char c) = fungetchar; 155 | #endif 156 | 157 | typedef unsigned short literal; 158 | 159 | /* An atom is a 16-bit value that is either a 15-bit integer (i.e., it holds a 160 | * literal), typically representing a combinator, or it is a reference to an 161 | * app node (an app). We use different representations for different systems. 162 | */ 163 | #ifdef CPM 164 | /* 165 | * On CP/M, we assume that the apps array will line in the low 32 KB of RAM. 166 | * If it overflows a little, it will limit the size of integers we can 167 | * represent. 168 | */ 169 | struct app_node; 170 | typedef struct app_node* atom; 171 | #define IS_LIT(x) (((unsigned short) x) >= ((unsigned short) &apps[MAX_APPS])) 172 | #define NODE_FUNC(n) ((n)->func) 173 | #define NODE_ARG(n) ((n)->arg) 174 | #define NODE_REFCOUNT(n) ((n)->refcount) 175 | #define INDEX_TO_ATOM(i) &apps[i] 176 | #define LIT_TO_ATOM(l) ((atom) (((unsigned short) l)+(unsigned short) &apps[MAX_APPS])) 177 | #define ATOM_TO_LIT(a) ((unsigned short) (a) - (unsigned short) &apps[MAX_APPS]) 178 | #define LIT_REQARGS(l) ((unsigned char) ((l) >> 8)) 179 | #define LIT_SUBTYPE(l) ((unsigned char) (l)) 180 | 181 | #else 182 | 183 | #ifdef USE_MINILIB 184 | /* This version intended for the ZX Spectrum. For the normal version, it is 185 | * required that apps lies in the high 32K of memory, as we use the high bit 186 | * set to detect app nodes. (This rule is relaxed for the TINY_VERSION 187 | * version, since it is intended for the 16K Spectrum which does not have a 188 | * high 32K of memory, but at the cost of only allowing 14-bit literals.) 189 | */ 190 | struct app_node; 191 | typedef struct app_node* atom; 192 | #define NODE_FUNC(n) ((n)->func) 193 | #define NODE_ARG(n) ((n)->arg) 194 | #define NODE_REFCOUNT(n) ((n)->refcount) 195 | #define INDEX_TO_ATOM(i) &apps[i] 196 | #ifndef TINY_VERSION 197 | #define IS_LIT(x) (!(((unsigned short) x) & 0x8000)) 198 | #else 199 | #define IS_LIT(x) (((unsigned short) x) < 0x4000) 200 | #endif 201 | #define LIT_TO_ATOM(l) ((atom) (l)) 202 | #define ATOM_TO_LIT(a) ((unsigned short) (a)) 203 | #define LIT_REQARGS(l) ((unsigned char) ((l) >> 8)) 204 | #define LIT_SUBTYPE(l) ((unsigned char) (l)) 205 | 206 | #else 207 | /* This version should run on anything. It uses array indexing rather than 208 | * pointers. As such, the address calculations are more complex (but 209 | * can utilize fancy addressing modes on the x86). It also has the advantage 210 | * that it can handle 32768 app nodes, whereas the pointers approach can 211 | * handle at most 5461 (i.e., 2^15/sizeof(struct app_node)). 212 | */ 213 | typedef uint16_t atom; 214 | #define IS_LIT(x) ((x & 0x8000) == 0) 215 | #define NODE_FUNC(n) apps[(n) & 0x7fff].func 216 | #define NODE_ARG(n) apps[(n) & 0x7fff].arg 217 | #define NODE_REFCOUNT(n) apps[(n) & 0x7fff].refcount 218 | #define INDEX_TO_ATOM(i) ((i) | 0x8000) 219 | #define LIT_TO_ATOM(l) (l) 220 | #define ATOM_TO_LIT(a) (a) 221 | #define LIT_REQARGS(l) ((unsigned char) ((l) >> 8)) 222 | #define LIT_SUBTYPE(l) ((unsigned char) (l)) 223 | #endif 224 | #endif 225 | 226 | /* 227 | * Literals representing the provided combinators are represented using 228 | * a coding where the high byte represents the required number of arguments 229 | * and the low byte represents the operation number and corresponds to an 230 | * entry in the reducers array declared later in the file. 231 | */ 232 | 233 | #define LIT_I 0x0100 234 | #define LIT_K 0x0201 235 | #define LIT_S 0x0302 236 | #define LIT_B 0x0303 237 | #define LIT_C 0x0304 238 | #define LIT_Y 0x0105 239 | #define LIT_P 0x0206 240 | #define LIT_pl 0x0307 241 | #define LIT_mi 0x0308 242 | #define LIT_tm 0x0309 243 | #define LIT_dv 0x030a 244 | #define LIT_F 0x020b /* (K I) */ 245 | #define LIT_J 0x020c /* (C I) */ 246 | #define LIT_eq 0x030d 247 | #define LIT_lt 0x030e 248 | #define LIT_G 0x010f 249 | #define LIT_END 0x0400 250 | 251 | struct repr { 252 | char key; 253 | literal value; 254 | }; 255 | 256 | struct repr reps[] = { 257 | {'I', LIT_I}, 258 | {'K', LIT_K}, 259 | {'S', LIT_S}, 260 | {'B', LIT_B}, 261 | {'C', LIT_C}, 262 | {'Y', LIT_Y}, 263 | {'P', LIT_P}, 264 | {'+', LIT_pl}, 265 | {'-', LIT_mi}, 266 | {'*', LIT_tm}, 267 | {'/', LIT_dv}, 268 | {'F', LIT_F}, 269 | {'J', LIT_J}, 270 | {'=', LIT_eq}, 271 | {'<', LIT_lt}, 272 | {'G', LIT_G} 273 | }; 274 | 275 | struct app_node { 276 | atom func; 277 | atom arg; 278 | #ifdef TINY_VERSION 279 | uint8_t refcount; 280 | #else 281 | uint16_t refcount; 282 | #endif 283 | }; 284 | 285 | #ifndef MAX_APPS 286 | #ifndef TINY_VERSION 287 | #define MAX_APPS 3072 288 | #else 289 | #define MAX_APPS 525 290 | #endif 291 | #endif 292 | 293 | #define NOT_REDUCED ((atom) 0xFFFF) 294 | 295 | #ifdef NDEBUG 296 | 297 | #define SANITY_CHECK 298 | #define SANITY_CHECKING(x) 299 | 300 | #else 301 | 302 | #define SANITY_CHECK assert(NODE_REFCOUNT(INDEX_TO_ATOM(MAX_APPS)) == 0x9e37);\ 303 | assert(!IS_LIT(app_freelist)); 304 | #define SANITY_CHECKING(x) x 305 | 306 | #endif 307 | 308 | 309 | #ifdef USE_MINILIB 310 | /* Must ensure this is the last variable in memory */ 311 | extern char beyond_end; 312 | #define apps ((struct app_node*) (&beyond_end)) 313 | #else 314 | static struct app_node apps[MAX_APPS+1]; 315 | #endif 316 | atom app_freelist; 317 | 318 | static unsigned int reductions = 0; 319 | 320 | atom alloc_app(atom func, atom arg); 321 | char free_app_all(atom a) __z88dk_fastcall; 322 | atom copy_atom(atom a) __z88dk_fastcall; 323 | 324 | void init_apps(void) 325 | { 326 | uint16_t i; 327 | app_freelist = INDEX_TO_ATOM(0); 328 | for (i = 0; i < MAX_APPS; ++i) { 329 | atom i_atom = INDEX_TO_ATOM(i); 330 | NODE_FUNC(i_atom) = INDEX_TO_ATOM(i+1); 331 | SANITY_CHECKING(NODE_REFCOUNT(i_atom) = 0x8888;) 332 | } 333 | SANITY_CHECKING(NODE_REFCOUNT(INDEX_TO_ATOM(MAX_APPS)) = 0x9e37;) 334 | SANITY_CHECK 335 | } 336 | 337 | atom reduce(atom curr) __z88dk_fastcall; 338 | 339 | uint8_t print_reduced = 0; 340 | 341 | void print_lit(literal lit) __z88dk_fastcall 342 | { 343 | unsigned char i; 344 | i = LIT_SUBTYPE(lit); 345 | if (i < ((unsigned char) ARRAY_SIZE(reps)) 346 | && LIT_REQARGS(reps[i].value) == LIT_REQARGS(lit)) { 347 | putchar(reps[i].key); 348 | } else { 349 | if (lit >= 32 && lit < 127) { 350 | putchar('\''); 351 | putchar(i); 352 | } else { 353 | printf("%u", lit); 354 | } 355 | } 356 | } 357 | 358 | void print_atom(atom a) __z88dk_fastcall 359 | { 360 | if (IS_LIT(a)) { 361 | print_lit(ATOM_TO_LIT(a)); 362 | } else { 363 | assert(NODE_REFCOUNT(a) != 0x8888); 364 | assert(NODE_REFCOUNT(a) != 0x9e37); 365 | assert(NODE_REFCOUNT(a) > 0); 366 | 367 | putchar('('); 368 | print_atom(NODE_FUNC(a)); 369 | putchar(' '); 370 | if (print_reduced && IS_LIT(NODE_FUNC(a)) 371 | && LIT_REQARGS(ATOM_TO_LIT(NODE_FUNC(a))) == 0) { 372 | NODE_ARG(a) = reduce(NODE_ARG(a)); 373 | } 374 | print_atom(NODE_ARG(a)); 375 | putchar(')'); 376 | } 377 | } 378 | 379 | void print_atom_reduced(atom a) __z88dk_fastcall 380 | { 381 | print_reduced = 1; 382 | print_atom(a); 383 | print_reduced = 0; 384 | } 385 | 386 | uint16_t current_apps = 0; 387 | uint16_t max_apps = 0; 388 | 389 | #define App alloc_app 390 | 391 | atom read_atom(); 392 | 393 | #ifndef TINY_VERSION 394 | atom string_to_atom(const char *cp) __z88dk_fastcall 395 | { 396 | atom a; 397 | void* saved_context = input_context; 398 | short(*saved_getch)(void) = getch; 399 | short(*saved_ungetch)(char c) = ungetch; 400 | /* printf("input_context := %p, (was %p)\n", input_context, &cp); */ 401 | input_context = (void*) &cp; 402 | getch = sgetchar; 403 | ungetch = sungetchar; 404 | a = read_atom(); 405 | input_context = saved_context; 406 | getch = saved_getch; 407 | ungetch = saved_ungetch; 408 | return a; 409 | } 410 | 411 | const char* builtins[][2] = { 412 | { "t", "K" }, 413 | { "f", "F" }, 414 | { "and", "@@CCF" }, 415 | { "or", "@JK" }, 416 | { "not", "@@C@JFK" }, 417 | { "pair", "@@BCJ" }, 418 | { "fst", "@JK" }, 419 | { "snd", "@JF" }, 420 | { "succ", "@SB" }, 421 | { "pred", "@@C@@BC@@B@BC@@C@@BC@@B@BB@@CB@@B@BJJKI" }, 422 | { "iszero", "@@C@J@KFK" }, 423 | { "plus", "@@BS@BB" }, 424 | { "sub", "@@C@@BB@@C@J@J@@BJ@SB@JF@@B@S@@C@J@@B@C@@BBS@@B@S@@BBB@@B@BCC@KF@@C@@BB@J@@C@JKI@@C@J@@BKJK" }, 425 | { "times", "B" }, 426 | { "div2", "@@BC@@C@@BC@@C@@BB@J@@B@SBC@@BKKI" }, 427 | { "cdiv", "@@C@@BB@@C@J@J@@BJ@SB@JF@@B@S@@C@J@J@@BJ@@BKJ@JK@@C@@BC@@BJ@@B@B@C@@BBS@@B@B@S@@BBB@@B@B@BC@@B@BC@@B@CB@@C@@BB@J@@C@JKI@@BKJ@KF" }, 428 | { "fdiv", "@@B@B$pred@@B$ceiling$div$succ" }, 429 | { "divrem2", "@@C@J@J@@C@@BS@@B@B$pair@@S@@BC@@BJ$succ I$not@@$pair#0$f" }, 430 | { "tobinle", "@Y@@B@C$divrem2@@B@B@C$cons@S@@C$iszero$nil" }, 431 | { "tobinbe", "@@B$rev$tobinle" }, 432 | { "eq", "@@C@@BC@@C@@BC@@C@@BB@J@@C@J@@@SII@@BK@@BJ@@SIII@@C@J@@BKJKK@KF" }, 433 | { "lesseq", "@@B@B$iszero$sub" }, 434 | { "less", "@@B@B$not@@B@B$iszero@C$sub" }, 435 | { "greatereq", "@C$lesseq" }, 436 | { "greater", "@C$less" }, 437 | { "cons", "$pair" }, 438 | { "nil", "@KK" }, 439 | { "hd", "$fst" }, 440 | { "tl", "$snd" }, 441 | /* { "case", "@@S@@BC@@B@BB@J@K@KFI" }, */ 442 | { "case", "@@C@@BC@@B@BC@@BC@@CB@@B@B@BK@B@BKI" }, 443 | { "take", "@@C@@BC@@C@@BC@@C@@BB@J@@SI@@C@@BC@@B@BC@C@@BC@@BJ@@B@B@BK@@B@B@BK@@B@BC@@B@BJ@@C@@BBB@@BCJI@C@JIK@KK" }, 444 | { "drop", "@J$tl" }, 445 | { "nth", "@@B@B$hd$drop" }, 446 | { "zipwith", "@Y@@B@B@C@@BB@@C$case$nil@@B@B@C@@BB@@BB@@C$case$nil@S@@BC@@B@BB@@B@BC@@B@B@BB@B@B$cons" }, 447 | { "zipapp", "@Y@@B@C@@BB@@C$case$nil@@B@C@@BB@@BB@@C$case$nil@C@@BB@@BC@@B@BB@B$cons" }, 448 | { "zip", "@$zipwith$pair" }, 449 | { "last", "@$foldr1F" }, 450 | { "isempty", "@J@K@KF" }, 451 | { "length", "@@$foldr@K$succ#0" }, 452 | { "foldl", "@@BY@@B@B@S@@BC@C$case@C@@BBB" }, 453 | { "foldl1", "@@C@@BS@@C@@BB$foldl$hd$tl" }, 454 | { "foldr", "@@B@BY@@B@C@@BB@@BC@C$case@@BC@BB" }, 455 | { "foldr1", "@@BY@@B@BJ@@B@B@S@@BS@C$isempty@@BC@BB" }, 456 | { "map", "@@BY@@B@B@C@@C$case$nil@@BC@@B@BB@B$cons" }, 457 | { "filter", "@@BY@@B@B@C@@C$case$nil@@BC@@B@BB@@C@@BC@@CS$cons I" }, 458 | { "append", "@Y@@B@C@@BS$case@@B@B@C@@BB$cons C" }, 459 | { "partition", "@Y@@B@B@S@@C@J@K@KF@@C@J@KK@KK@@B@BJ@@C@@BS@@B@BB@BC@@C@@BS@@B@BS@@B@B@BS@@C@@BS@@B@BB@BB@@B@BC@@B@BJ@@BCJ@@B@C@@BB@@BCJ@@BCJ" }, 460 | { "quicksort", "@@BY@@B@B@C@@C$case@KK@@C@@BB@@BS@@B@BC@B$partition@@S@@BB@@BB@@BC@B$append@C@@BB$cons" }, 461 | { "rev", "@@$foldl@C$cons$nil" }, 462 | { "natsfrom", "@Y@@B@S$cons@@CB$succ" }, 463 | { "sum", "@@$foldr$plus#0" }, 464 | { "neval", "@@C@@C@J@@CB@SBIF" }, 465 | { "leval", "@@B$rev$rev" }, 466 | { "exlist1", "@@$cons#0@@$cons#1@@$cons#2$nil" }, 467 | { "exlist2", "@@$cons#2@@$cons#0@@$cons#7@@$cons#5@@$cons#1@@$cons#3@@$cons#6$nil" }, 468 | { "fib", "@@C@@C@J@@S@@BC@@BJ@JF@@S@@BS@@B@BB@JK@JF@@C@JFIK" }, 469 | { "fact", "@@C@@C@J@@B@SB@@CB@SBFI" }, 470 | { "tnpo", "@@B@Y@@BJ@@C@@BC@@B@BC@@B@C@@BB@J@@CB@SB@@B@S@@BS@C@@C@@C@@C@J@@BKJK#0@@C@JK@K#0@@C@@BBB@@B@C@@BC@@BJ@@S@@S@@C@J@@C@J#0KK@@BC@@C@@BC@@C@@BB@J@@B@SBC@@BKKI@@B@SB@@S@@BS@BB@@S@@BS@BBI@SB#0@@C@@BCJ#0" }, 471 | { "blc", "@Y@@B@BJ@@B@B@B@SI@@S@@BS@@B@BC@@B@B@BB@@B@B@BS@@B@B@CB@@S@@BBB@@B@S@@BC@@B@BS@@B@CB@@CB@@C@@BBB@C$pair@@C@@BBB@@C@@BBBS@@B@S@@BB@@BS@@B@SI@@CBJ@@B@B@B@BK@@B@BC@@C@@BBB@@C@@BBB@@B@CBJ" }, 472 | { "runblc", "@$blc K" }, 473 | { "rjot", "@Y@@B@C@@C$case I@@S@@BC@@B@BS@@B@CB@@B@BS@BK@@C@@BC@@CCSK" }, 474 | { "jot", "@@B$rjot$rev" }, 475 | { "diag", "@@C@@BC@@B@BY@@C@@BC@@B@BB@@B@BS@@B@B@B$append@@C@@BS@@B@BB$zipwith@@B@B$rev@C$take@@CB$succ I" }, 476 | { "diagapp", "@@C@@BY@@C@@BB@@BS@@B@B$append@@S@@BB$zipapp@@B@B$rev@C$take@@CB$succ I" }, 477 | { "allsk", "@Y@@B@$cons K@@B@$cons S$diagapp" }, 478 | { "allski", "@Y@@B@$cons I@@B@$cons K@@B@$cons S$diagapp" }, 479 | { "allskibc", "@Y@@B@$cons I@@B@$cons K@@B@$cons B@@B@$cons C@@B@$cons S$diagapp" } 480 | }; 481 | #endif 482 | 483 | atom read_atom() 484 | { 485 | signed char c; 486 | again: 487 | SANITY_CHECK 488 | c = getch(); 489 | if (c == -1) 490 | return LIT_TO_ATOM(LIT_I); 491 | switch (c) { 492 | case ' ': 493 | case ')': 494 | case '\n': 495 | goto again; 496 | case '(': 497 | case '@': { 498 | atom lhs = read_atom(); 499 | atom rhs = read_atom(); 500 | return alloc_app(lhs,rhs); 501 | } 502 | case '\'': 503 | return LIT_TO_ATOM((unsigned char) getch()); 504 | case '#': { 505 | short n = 0; 506 | for (;;) { 507 | c = getch(); 508 | if (c < '0' || c > '9') 509 | break; 510 | n = n*10+(c - '0'); 511 | } 512 | if (c != -1) 513 | ungetch(c); 514 | /* printf("inserted church numeral %d: ",n); */ 515 | { 516 | atom single_succ = alloc_app(LIT_TO_ATOM(LIT_S), 517 | LIT_TO_ATOM(LIT_B)); 518 | atom val = alloc_app(LIT_TO_ATOM(LIT_K),LIT_TO_ATOM(LIT_I)); 519 | short i; 520 | for (i = 0; i < n; ++i) { 521 | val = alloc_app(copy_atom(single_succ),val); 522 | } 523 | free_app_all(single_succ); 524 | /* print_atom(val); putchar('\n'); */ 525 | return val; 526 | } 527 | } 528 | #ifndef TINY_VERSION 529 | case '$': { 530 | char ident[20]; 531 | char* cp = ident; 532 | short i; 533 | for (;;) { 534 | c = getch(); 535 | if (c < '0' || c > 'z' || (c < 'A' && c > '9')) 536 | break; 537 | *cp++ = c; 538 | } 539 | if (c != -1) 540 | ungetch(c); 541 | *cp = '\0'; 542 | for (i = 0; i < sizeof(builtins)/sizeof(*builtins); ++i) { 543 | if (!strcmp(ident,builtins[i][0])) 544 | return string_to_atom(builtins[i][1]); 545 | } 546 | printf("Unkown macro: %s\n", ident); 547 | goto again; 548 | } 549 | #endif 550 | default: 551 | if (c >= '0' && c <= '9') { 552 | unsigned short num = 0; 553 | for (;;) { 554 | num += c - '0'; 555 | c = getch(); 556 | if (c < '0' || c > '9') 557 | break; 558 | num *= 10; 559 | } 560 | if (c != -1) 561 | ungetch(c); 562 | return LIT_TO_ATOM(num & 0x7fff); 563 | } 564 | if (c >= 'a' && c <= 'z') 565 | return LIT_TO_ATOM(c); 566 | { 567 | unsigned char i; 568 | for (i = 0; i < (unsigned char) ARRAY_SIZE(reps); ++i) 569 | if (reps[i].key == (char) c) 570 | return LIT_TO_ATOM(reps[i].value); 571 | } 572 | printf("Unrecognized char '%c'\n", c); 573 | goto again; 574 | } 575 | } 576 | 577 | int main() 578 | { 579 | #ifdef __Z88DK 580 | #ifdef __ZXNEXT 581 | putchar(14); 582 | #else 583 | #ifdef __SPECTRUM 584 | zx_cls(PAPER_WHITE); 585 | #endif 586 | #endif 587 | #endif 588 | init_apps(); 589 | #ifndef TINY_VERSION 590 | input_context = (void*) stdin; 591 | #endif 592 | SANITY_CHECK 593 | printf("Mini-SK, combinators & more...\n"); 594 | #ifndef TINY_VERSION 595 | printf("\nPredefined macros"); 596 | { 597 | int i; 598 | char comma = ':'; 599 | for (i = 0; i < sizeof(builtins)/sizeof(*builtins); ++i) { 600 | printf("%c $%s", comma, builtins[i][0]); 601 | comma = ','; 602 | } 603 | } 604 | putchar('\n'); 605 | #endif 606 | for(;;) { 607 | atom a; 608 | if (feof(stdin)) 609 | break; 610 | SANITY_CHECK 611 | reductions = 0; 612 | max_apps = current_apps; 613 | #if defined(USE_MINILIB) && defined(__SPECTRUM) 614 | input_prompt = "Term> "; 615 | #else 616 | printf("\nTerm> "); 617 | #endif 618 | a = read_atom(); 619 | putchar('\n'); 620 | { 621 | char c; 622 | do { 623 | c = getch(); 624 | } while (c == ' ' || c == ')'); 625 | if (c != '\n') 626 | ungetch(c); 627 | } 628 | print_atom(a); printf("\n--->\n"); 629 | SANITY_CHECK 630 | #if defined(USE_MINILIB) && defined(__SPECTRUM) 631 | input_prompt += 4; 632 | #endif 633 | a = reduce(a); 634 | SANITY_CHECK 635 | print_atom_reduced(a); putchar('\n'); 636 | SANITY_CHECK 637 | printf("\n%u reductions, %d max appnodes\n", reductions, max_apps); 638 | free_app_all(a); 639 | } 640 | return 0; 641 | } 642 | 643 | 644 | atom alloc_app(atom func, atom arg) 645 | { 646 | atom next_app = app_freelist; 647 | SANITY_CHECK 648 | if (next_app == INDEX_TO_ATOM(MAX_APPS)) { 649 | fprintf(stderr, "out of app space\n"); 650 | exit(2); 651 | } 652 | assert(NODE_REFCOUNT(next_app) == 0x8888); 653 | app_freelist = NODE_FUNC(next_app); 654 | NODE_FUNC(next_app) = func; 655 | NODE_ARG(next_app) = arg; 656 | NODE_REFCOUNT(next_app) = 1; 657 | debug_printf(("# ALLOC: node= %04x, lhs= %04x, rhs= %04x\n", next_app, func, arg)); 658 | SANITY_CHECK 659 | ++current_apps; 660 | if (current_apps > max_apps) 661 | max_apps = current_apps; 662 | return next_app; 663 | } 664 | 665 | void free_app(atom app) __z88dk_fastcall 666 | { 667 | SANITY_CHECK 668 | assert(NODE_REFCOUNT(app) != 0x8888); 669 | NODE_FUNC(app) = app_freelist; 670 | app_freelist = app; 671 | --current_apps; 672 | SANITY_CHECKING(NODE_REFCOUNT(app) = 0x8888;) 673 | debug_printf(("# FREE: node= %04x, lhs= %04x, rhs= %04x\n", app, NODE_FUNC(app), NODE_ARG(app))); 674 | } 675 | 676 | char free_app_all(atom app) __z88dk_fastcall 677 | { 678 | SANITY_CHECK 679 | if (IS_LIT(app)) 680 | return 0; 681 | debug_printf(("# DEC: node= %04x, lhs= %04x, rhs= %04x\n", app, NODE_FUNC(app), NODE_ARG(app))); 682 | if (--NODE_REFCOUNT(app)) 683 | return 0; 684 | free_app_all(NODE_ARG(app)); 685 | free_app_all(NODE_FUNC(app)); 686 | free_app(app); 687 | return 1; 688 | } 689 | 690 | atom copy_atom(atom a) __z88dk_fastcall 691 | { 692 | SANITY_CHECK 693 | if (IS_LIT(a)) 694 | return a; 695 | debug_printf(("# INC: node= %04x, lhs= %04x, rhs= %04x\n", a, NODE_FUNC(a), NODE_ARG(a))); 696 | assert(NODE_REFCOUNT(a) != 0x8888); 697 | assert(NODE_REFCOUNT(a) != 0x9e37); 698 | ++NODE_REFCOUNT(a); 699 | return a; 700 | } 701 | 702 | atom replace(atom orig, atom reduced) 703 | { 704 | if (!free_app_all(orig)) { 705 | copy_atom(reduced); 706 | free_app_all(NODE_FUNC(orig)); 707 | free_app_all(NODE_ARG(orig)); 708 | NODE_FUNC(orig) = LIT_TO_ATOM(LIT_I); 709 | NODE_ARG(orig) = reduced; 710 | } 711 | return reduced; 712 | } 713 | 714 | #ifndef MAX_STACK 715 | #define MAX_STACK 512 716 | #endif 717 | 718 | #ifdef USE_MINILIB 719 | #ifdef TINY_VERSION 720 | atom* rs_top_ptr = (atom*) 0x8000; 721 | const atom* red_stack = ((atom*) 0x7000); 722 | #else 723 | atom* rs_top_ptr = (atom*) 0xff20; 724 | const atom* red_stack = ((atom*) 0xef20); 725 | #endif 726 | #else 727 | atom red_stack[MAX_STACK+1]; 728 | atom* rs_top_ptr = &red_stack[MAX_STACK]; 729 | #endif 730 | 731 | typedef atom (*reducer_fn)(atom curr) __z88dk_fastcall; 732 | 733 | atom red_ident(atom curr) __z88dk_fastcall 734 | { 735 | return replace(curr, copy_atom(NODE_ARG(curr))); 736 | } 737 | 738 | atom red_const(atom curr) __z88dk_fastcall 739 | { 740 | return replace(curr, copy_atom(NODE_ARG(rs_top_ptr[0]))); 741 | } 742 | 743 | atom red_false(atom curr) __z88dk_fastcall 744 | { 745 | return replace(curr, copy_atom(NODE_ARG(curr))); 746 | } 747 | 748 | atom red_jump(atom curr) __z88dk_fastcall 749 | { 750 | atom yx = alloc_app(copy_atom(NODE_ARG(curr)), 751 | copy_atom(NODE_ARG(rs_top_ptr[0]))); 752 | return replace(curr, yx); 753 | } 754 | 755 | atom red_fusion(atom curr) __z88dk_fastcall 756 | { 757 | atom fx = alloc_app(copy_atom(NODE_ARG(rs_top_ptr[0])), 758 | copy_atom(NODE_ARG(curr))); 759 | atom gx = alloc_app(copy_atom(NODE_ARG(rs_top_ptr[1])), 760 | copy_atom(NODE_ARG(curr))); 761 | return replace(curr,alloc_app(fx,gx)); 762 | } 763 | 764 | atom red_compose(atom curr) __z88dk_fastcall 765 | { 766 | atom f = copy_atom(NODE_ARG(rs_top_ptr[0])); 767 | atom gx = alloc_app(copy_atom(NODE_ARG(rs_top_ptr[1])), 768 | copy_atom(NODE_ARG(curr))); 769 | return replace(curr,alloc_app(f,gx)); 770 | } 771 | 772 | atom red_flip(atom curr) __z88dk_fastcall 773 | { 774 | atom fy = alloc_app(copy_atom(NODE_ARG(rs_top_ptr[0])), 775 | copy_atom(NODE_ARG(curr))); 776 | atom x = copy_atom(NODE_ARG(rs_top_ptr[1])); 777 | return replace(curr,alloc_app(fy,x)); 778 | } 779 | 780 | atom red_y(atom curr) __z88dk_fastcall 781 | { 782 | /* 783 | * Note: It migtht be tempting to write 784 | * return replace(curr,alloc_app(copy_atom(NODE_ARG(curr)), 785 | * copy_atom(curr))); 786 | * but that would make a cycle, and that's not cool given that we use 787 | * reference countining. Thus this is one of the few rules where we 788 | * don't use replace. 789 | */ 790 | return alloc_app(copy_atom(NODE_ARG(curr)), curr); 791 | } 792 | 793 | atom red_putchar(atom curr) __z88dk_fastcall 794 | { 795 | atom reduced = reduce(NODE_ARG(curr)); 796 | NODE_ARG(curr) = reduced; 797 | putchar(IS_LIT(reduced) ? LIT_SUBTYPE(ATOM_TO_LIT(reduced)) : '*'); 798 | return replace(curr,copy_atom(NODE_ARG(rs_top_ptr[0]))); 799 | } 800 | 801 | atom red_getchar(atom curr) __z88dk_fastcall 802 | { 803 | atom arg0 = NODE_ARG(curr); 804 | atom result = LIT_TO_ATOM(getchar()); 805 | return replace(curr, alloc_app(copy_atom(arg0), result)); 806 | } 807 | 808 | literal other_lit; 809 | 810 | literal eval_two_lits(atom curr) __z88dk_fastcall 811 | { 812 | atom reduced_lhs = reduce(NODE_ARG(rs_top_ptr[1])); 813 | NODE_ARG(rs_top_ptr[1]) = reduced_lhs; 814 | other_lit = IS_LIT(reduced_lhs) ? ATOM_TO_LIT(reduced_lhs) : 0; 815 | { 816 | atom reduced_rhs = reduce(NODE_ARG(curr)); 817 | NODE_ARG(curr) = reduced_lhs; 818 | return IS_LIT(reduced_rhs) ? ATOM_TO_LIT(reduced_rhs) : 0; 819 | } 820 | /* return (((uint32_t) lhs_lit) << 16) | rhs_lit; */ 821 | } 822 | 823 | atom builtin_2c_result(atom result) __z88dk_fastcall 824 | { 825 | atom arg0 = NODE_ARG(rs_top_ptr[0]); 826 | if (arg0 == LIT_TO_ATOM(LIT_I)) { 827 | return replace(rs_top_ptr[2], result); 828 | } else { 829 | return replace(rs_top_ptr[2], alloc_app(copy_atom(arg0), result)); 830 | } 831 | } 832 | 833 | atom red_plus(atom curr) __z88dk_fastcall 834 | { 835 | literal rhs_lit = eval_two_lits(curr); 836 | return builtin_2c_result(LIT_TO_ATOM((other_lit+rhs_lit) & 0x7fff)); 837 | } 838 | 839 | atom red_minus(atom curr) __z88dk_fastcall 840 | { 841 | literal rhs_lit = eval_two_lits(curr); 842 | return builtin_2c_result(LIT_TO_ATOM((other_lit-rhs_lit) & 0x7fff)); 843 | } 844 | 845 | atom red_times(atom curr) __z88dk_fastcall 846 | { 847 | literal rhs_lit = eval_two_lits(curr); 848 | return builtin_2c_result(LIT_TO_ATOM((other_lit*rhs_lit) & 0x7fff)); 849 | } 850 | 851 | atom red_div(atom curr) __z88dk_fastcall 852 | { 853 | literal rhs_lit = eval_two_lits(curr); 854 | return builtin_2c_result(LIT_TO_ATOM((other_lit/rhs_lit) & 0x7fff)); 855 | } 856 | 857 | atom red_eq(atom curr) __z88dk_fastcall 858 | { 859 | literal rhs_lit = eval_two_lits(curr); 860 | return builtin_2c_result(LIT_TO_ATOM(other_lit==rhs_lit ? LIT_K : LIT_F)); 861 | } 862 | 863 | atom red_lt(atom curr) __z88dk_fastcall 864 | { 865 | literal rhs_lit = eval_two_lits(curr); 866 | return builtin_2c_result(LIT_TO_ATOM(other_lit < rhs_lit ? LIT_K : LIT_F)); 867 | } 868 | 869 | reducer_fn reducers[] = { 870 | red_ident, 871 | red_const, 872 | red_fusion, 873 | red_compose, 874 | red_flip, 875 | red_y, 876 | red_putchar, 877 | red_plus, 878 | red_minus, 879 | red_times, 880 | red_div, 881 | red_false, 882 | red_jump, 883 | red_eq, 884 | red_lt, 885 | red_getchar 886 | }; 887 | 888 | atom reduce(atom curr) __z88dk_fastcall 889 | { 890 | uint16_t stack_len; 891 | assert(rs_top_ptr >= red_stack); 892 | stack_len = 0; 893 | debug_printf(("# START: stack_len= %d, curr= %04x, rs_top_ptr= %p, red_stack= %p\n", stack_len, curr, rs_top_ptr, red_stack)); 894 | again: 895 | while(!IS_LIT(curr)) { 896 | atom next; 897 | assert(NODE_REFCOUNT(curr) != 0x8888); 898 | next = NODE_FUNC(curr); 899 | debug_printf(("# DOWN: stack_len= %d, curr= %04x, lhs= %04x, rhs= %04x, rs_top_ptr= %p\n", stack_len, curr, next, NODE_ARG(curr), rs_top_ptr)); 900 | if (next == LIT_TO_ATOM(LIT_I)) { 901 | next = curr; 902 | do { 903 | debug_printf(("# INDIRECT1: next= %04x, lhs= %04x, rhs= %04x\n", next, NODE_FUNC(next), NODE_ARG(next))); 904 | next = NODE_ARG(next); 905 | } while (!IS_LIT(next) 906 | && NODE_FUNC(next) == LIT_TO_ATOM(LIT_I)); 907 | debug_printf(("# INDIRECT3: next= %04x\n", next)); 908 | do { 909 | ++reductions; 910 | copy_atom(next); 911 | if (free_app_all(curr)) { 912 | curr = next; 913 | break; 914 | } 915 | { 916 | atom temp = NODE_ARG(curr); 917 | NODE_ARG(curr) = next; 918 | curr = temp; 919 | } 920 | } while (!IS_LIT(curr) 921 | && NODE_FUNC(curr) == LIT_TO_ATOM(LIT_I)); 922 | assert(curr == next); 923 | if (stack_len > 0) { 924 | NODE_FUNC(*rs_top_ptr) = curr; 925 | } 926 | continue; 927 | } 928 | --rs_top_ptr; 929 | *rs_top_ptr = curr; 930 | ++stack_len; 931 | debug_printf(("# DOWN2: stack_len= %d, curr= %04x, lhs= %04x, rhs= %04x, rs_top_ptr= %p, red_stack= %p\n", stack_len, curr, next, NODE_ARG(curr), rs_top_ptr, red_stack)); 932 | assert(rs_top_ptr >= red_stack); 933 | curr = next; 934 | } 935 | debug_printf(("# SELECT: stack_len = %d, curr = %04x, rs_top_ptr = %p\n", stack_len, curr, rs_top_ptr)); 936 | { 937 | uint8_t reqargs; 938 | reqargs = LIT_REQARGS(ATOM_TO_LIT(curr)); 939 | if (reqargs == 0) 940 | goto not_reduced; 941 | if (reqargs <= stack_len) { 942 | uint8_t subtype; 943 | debug_printf(("# ARGMATCH: stack_len= %u, reqargs= %u\n", stack_len, (short) reqargs)); 944 | ++reductions; 945 | subtype = LIT_SUBTYPE(ATOM_TO_LIT(curr)); 946 | curr = rs_top_ptr[reqargs-1]; 947 | curr = (reducers[subtype])(curr); 948 | rs_top_ptr += reqargs; 949 | stack_len -= reqargs; 950 | debug_printf(("# COMPLETE: stack_len = %d, curr = %04x, rs_top_ptr = %p\n", stack_len, curr, rs_top_ptr)); 951 | if (stack_len > 0) { 952 | NODE_FUNC(*rs_top_ptr) = curr; 953 | } 954 | goto again; 955 | } 956 | } 957 | not_reduced: 958 | if (stack_len == 0) 959 | return curr; 960 | rs_top_ptr += stack_len; 961 | return *(rs_top_ptr - 1); 962 | } 963 | 964 | 965 | --------------------------------------------------------------------------------