├── .gitignore ├── tools ├── lua └── LICENSE ├── test ├── build.sh ├── inline.f ├── memtest.f ├── megademo.f ├── dump.f ├── test.f ├── comptime.f ├── starfield.f └── mcode.f ├── todo.txt ├── LICENSE ├── notes.txt ├── dump_tap.lua ├── z80_opcodes.lua ├── README.md ├── compile.lua └── mcode.lua /.gitignore: -------------------------------------------------------------------------------- 1 | *.tap 2 | *.lst 3 | private 4 | .DS_Store 5 | -------------------------------------------------------------------------------- /tools/lua: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/petrihakkinen/ace-forth/HEAD/tools/lua -------------------------------------------------------------------------------- /test/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cd .. 4 | #./compile.lua -o test/starfield.tap -l test/starfield.lst --filename stars --main stars --mcode --optimize test/starfield.f 5 | 6 | ./compile.lua -o test/mcode.tap -l test/mcode.lst --filename main --main main --mcode --optimize test/mcode.f -------------------------------------------------------------------------------- /test/inline.f: -------------------------------------------------------------------------------- 1 | : inl 2 | begin 1 again 3 | ( Forth calls must be skipped over when relocating mcode ) 4 | cls 5 | ( Embedded strings must be skipped over when inlining & relocating mcode ) 6 | ( Ascii code of '8' is 0x38, which is the opcode for JR C,o ) 7 | ." 8HELLO" 8 | ; inline 9 | 10 | : main inl ; -------------------------------------------------------------------------------- /test/memtest.f: -------------------------------------------------------------------------------- 1 | ( Memory tester ) 2 | 3 | : main 4 | fast cls 16 base c! 5 | ( Loop through address in test range ) 6 | [ hex ] 4000 3f00 [ decimal ] do 7 | ." TESTING " i . space 8 | 9 | ( Test all values ) 10 | 256 0 do 11 | i j c! ( Write test value ) 12 | j c@ ( Read back value ) 13 | i = 0= if 14 | ." ERROR!" 15 | abort 16 | then 17 | loop 18 | ." OK" cr 19 | loop ; -------------------------------------------------------------------------------- /test/megademo.f: -------------------------------------------------------------------------------- 1 | 32 variable x 2 | 24 variable y 3 | 1 variable dx 4 | -1 variable dy 5 | 1 variable len 6 | 7 | : pl ( -- ) x @ y @ abs 47 mod 3 plot ; 8 | 9 | : !+ over @ + swap ! ; 10 | 11 | : step ( -- ) x dx @ !+ y dy @ !+ ; 12 | 13 | : turn ( -- ) dx @ negate dy @ dx ! dy ! ; 14 | 15 | : main 16 | fast di 17 | begin 18 | len @ 0 19 | do 20 | pl step 21 | loop 22 | turn len 1 !+ 23 | again ; 24 | -------------------------------------------------------------------------------- /test/dump.f: -------------------------------------------------------------------------------- 1 | ( Program for printing the contents of memory ) 2 | ( For example, the following dumps the first 32 bytes of the word HELLO: FIND HELLO 32 DUMP ) 3 | 4 | : dump ( address count -- ) 5 | hex 6 | 0 do 7 | i 7 and 0= if cr then ( Line break every 8 bytes ) 8 | dup i + c@ ( Fetch byte ) 9 | dup 16 < if ascii 0 emit then ( Prefix with "0" if byte is less than 10 in hex ) 10 | . 11 | loop ; 12 | 13 | ( Test code to dump ) 14 | : hello ." world" ; 15 | -------------------------------------------------------------------------------- /test/test.f: -------------------------------------------------------------------------------- 1 | ( This is a comment ) 2 | 3 | 123 variable foo 4 | -12345 variable bar 5 | 54 const k 6 | 7 | : hello ." world" cr ; 8 | 9 | : hello2 hello ; 10 | 11 | : lit -12345 . ; 12 | 13 | : lit0 0 . ; 14 | 15 | : test cls 32 24 1 plot cr ; 16 | 17 | : test-if 0 if ." a" else ." b" then ; 18 | 19 | : test-until begin ." *" 0 until ; 20 | 21 | : test-until2 5 begin ." *" 1- dup 0= until ; 22 | 23 | : test-loop 3 0 do i . loop ; 24 | 25 | : test+loop -1 5 do i . -1 +loop ; 26 | 27 | : test-ascii ascii * emit ; 28 | 29 | create temp 10 allot ( allocate bytes ) 30 | 31 | create table 1 c, 2 c, 4 c, 8 c, 16 c, 32 c, 64 c, 128 c, 32 | 33 | : dump-temp 10 0 do temp i + c@ . loop cr ; 34 | 35 | : dump-table 8 0 do table i + c@ . loop cr ; 36 | -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | - peephole optimize: 2 | rst 24 ; stk_pop_de 3 | rst 16 ; stk_push_de 4 | ld de,nnnn 5 | 6 | -> 7 | 8 | ld de,nnnn 9 | 10 | - forward gotos could be optimized to branches 11 | 12 | - dead code and inlining optimizations can't distinguish words that have same name 13 | - therefore the compiler does not really support defining multiple words with same name 14 | -> raise an error when a word is redefined and document the behavior in README 15 | 16 | - document remaining words in README 17 | 18 | - can we make machine code version of . any faster (it's really slow)? 19 | - yes, write specializations for base 10 and base 16? 20 | - https://wikiti.brandonw.net/index.php?title=Z80_Routines:Other:DispHL 21 | 22 | - BUG: errors and warnings have incorrect line number for words at the end of the line 23 | - store last_word_line in next_symbol 24 | 25 | - formatting of negative literals in listing files is broken, from demons.lst: 26 | 4ae1 01 ec fa ld bc,$fffffffffffffaec 27 | -------------------------------------------------------------------------------- /tools/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 1994–2021 Lua.org, PUC-Rio. 2 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 3 | 4 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 5 | 6 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Petri Häkkinen 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 | -------------------------------------------------------------------------------- /notes.txt: -------------------------------------------------------------------------------- 1 | Calling mcode words 2 | =================== 3 | 4 | We need to be able to call mcode words from Forth and other mcode words. 5 | 6 | Each mcode word starts with a short wrapper: 7 | 8 | CALL mc 9 | jp (iy) ; returns to Forth interpreter 10 | mc: ... machine code routine here ... 11 | ret 12 | 13 | Forth code calls the mcode word using its compilation address, which points to the mcode wrapper. 14 | 15 | Machine code can bypass the wrapper and call the 'mc' routine directly. The machine code address of a word can be found by adding 7 to the compilation address of the word. 16 | 17 | 18 | Short forward jumps 19 | =================== 20 | 21 | Currently mcode versions of IF, ELSE and GOTO emit long forward jumps using the JP or JP Z instructions. These could be optimized to short branches, but this is fairly compilated, so it has not been done to keep the compiler simple. 22 | 23 | This would either require multiple passes or rewinding the parser. 24 | 25 | Multiple passes: 1st pass records which jumps can be shortened, 2nd pass generates the code. 26 | 27 | Rewinding the parser: assume either long or short jump. If we guessed wrong, rewind the parser and undo generated code since the beginning of jump. 28 | -------------------------------------------------------------------------------- /test/comptime.f: -------------------------------------------------------------------------------- 1 | ( Compiler interpreter mode tests ) 2 | 3 | ." 3 + 2 -> " 3 2 + . cr 4 | ." 3 - 2 -> " 3 2 - . cr 5 | ." 3 * 2 -> " 3 2 * . cr 6 | ." 6 / 2 -> " 6 2 / . cr 7 | ." 3 dup + . -> " 3 dup + . cr 8 | ." 3 4 drop . -> " 3 4 drop . cr 9 | ." 1 2 swap . . -> " 1 2 swap . . cr 10 | ." 1 2 3 rot . . . -> " 1 2 3 rot . . . cr 11 | ." 1 2 3 3 pick . . . . -> " 1 2 3 3 pick . . . . cr 12 | ." 1 2 3 3 roll . . . -> " 1 2 3 3 roll . . . cr 13 | ." *" space space ." *" cr 14 | ." *" 5 spaces ." *" cr 15 | ascii * emit cr 16 | 17 | ." here is " hex here . decimal cr 18 | 19 | ." 128 in hex is " 128 hex . decimal cr 20 | ." 128 in binary is " 128 2 base ! . decimal cr 21 | 22 | ." hex ff in decimal is " hex ff decimal . cr 23 | ." binary 1100 in decimal is " 2 base ! 1100 decimal . cr 24 | 25 | : test[] 26 | [ ." Compiling Test " cr 123 ] 27 | cr 28 | [ ." Popping value " . cr ] ; 29 | 30 | ( Test [if] ) 31 | 32 | 1 [if] 33 | ." This should be printed" cr 34 | [then] 35 | 36 | 1 [if] 37 | ." This should be printed" cr 38 | [else] 39 | ." This should NOT be printed" cr 40 | [then] 41 | 42 | 0 [if] 43 | ." This should NOT be printed" cr 44 | [else] 45 | ." This should be printed" cr 46 | [then] 47 | 48 | [defined] cr [if] ." cr is defined" cr [then] 49 | [defined] abc not [if] ." ABC is not defined" cr [then] -------------------------------------------------------------------------------- /dump_tap.lua: -------------------------------------------------------------------------------- 1 | #!tools/lua 2 | 3 | -- dumps contents of a tap file 4 | 5 | local args = {...} 6 | local filename = args[1] 7 | 8 | if filename == nil then 9 | print("Usage: dump_tap.lua ") 10 | return 11 | end 12 | 13 | local file = assert(io.open(filename, "rb")) 14 | 15 | function printf(...) 16 | print(string.format(...)) 17 | end 18 | 19 | function fread_byte() 20 | return string.byte(file:read(1)) 21 | end 22 | 23 | function fread_short() 24 | local lo = fread_byte() 25 | local hi = fread_byte() 26 | return lo | (hi << 8) 27 | end 28 | 29 | function compute_checksum(data) 30 | local sum = 0 31 | for i = 1, #data do 32 | sum = sum ~ data:byte(i) 33 | end 34 | return sum 35 | end 36 | 37 | function read_header() 38 | local header = {} 39 | header.header_length = fread_short() 40 | header.file_type = fread_byte() 41 | header.filename = file:read(10) 42 | header.file_length = fread_short() 43 | header.start_address = fread_short() 44 | header.link = fread_short() 45 | header.current = fread_short() 46 | header.context = fread_short() 47 | header.voc_link = fread_short() 48 | header.dict_data_end = fread_short() 49 | header.header_checksum = fread_byte() 50 | 51 | printf("Header:") 52 | printf(" Header length %d", header.header_length) 53 | printf(" File type %d", header.file_type) 54 | printf(" Filename %s", header.filename) 55 | printf(" File length %d", header.file_length) 56 | printf(" Start address %04x", header.start_address) 57 | printf(" Link %04x", header.link) 58 | printf(" Current %04x", header.current) 59 | printf(" Context %04x", header.context) 60 | printf(" Voc link %04x", header.voc_link) 61 | printf(" Data end %04x", header.dict_data_end) 62 | printf(" Checksum %02x", header.header_checksum) 63 | print() 64 | 65 | return header 66 | end 67 | 68 | function dump_word(header, data, link) 69 | local function read_byte(addr) 70 | return data:byte(addr - header.start_address + 1) 71 | end 72 | 73 | local function read_short(addr) 74 | local lo = read_byte(addr) 75 | local hi = read_byte(addr + 1) 76 | return lo | (hi << 8) 77 | end 78 | 79 | local function read_name(addr, count) 80 | local str = "" 81 | for i = addr, addr + count - 1 do 82 | str = str .. string.char(read_byte(i) & 127) 83 | end 84 | return str 85 | end 86 | 87 | -- link points to the name length field 88 | local word_length = read_short(link - 4) 89 | local prev_word_link = read_short(link - 2) 90 | local name_length = read_byte(link) 91 | local name = read_name(link - 4 - name_length, name_length) 92 | local code_field = read_short(link + 1) 93 | 94 | local what = "???" 95 | if code_field == 0x0ec3 then what = "do colon" end 96 | if code_field == 0x0ff0 then what = "do param" end 97 | if code_field == 0x0ff5 then what = "do constant" end 98 | 99 | printf("Word %s", name) 100 | printf("Word length %d", word_length) 101 | printf("Code field %04x (%s)", code_field, what) 102 | printf("Prev link %04x", prev_word_link) 103 | print() 104 | 105 | if prev_word_link >= 0x3c51 then 106 | dump_word(header, data, prev_word_link) 107 | end 108 | end 109 | 110 | local header = read_header() 111 | 112 | local data_size = fread_short() 113 | printf("Data size %d", data_size) 114 | 115 | local data = file:read(data_size - 1) 116 | 117 | local checksum = fread_byte() 118 | printf("Data checksum %02x (computed checksum %02x)\n", checksum, compute_checksum(data)) 119 | 120 | dump_word(header, data, header.link) 121 | 122 | file:close() 123 | -------------------------------------------------------------------------------- /test/starfield.f: -------------------------------------------------------------------------------- 1 | ( 2D starfield effect ) 2 | 3 | [hex] 2400 const SCREEN 4 | [hex] 2C00 const CHARS 5 | [hex] 3C3B const SPARE ( The address of the first byte past the top of the stack ) 6 | 7 | 32 const SCREEN_WIDTH 8 | 24 const SCREEN_HEIGHT 9 | 10 | 50 const STAR_COUNT ( Max 127! ) 11 | 127 const CHAR_COUNT 12 | 13 | ( Star data arrays ) 14 | ( These are aligned to start at page boundaries so that computing address within the array is faster. ) 15 | [hex] 5000 const StarX ( Star X coordinates within a char 0-7 ) 16 | [hex] 5100 const StarY ( Star Y coordinates within a char 0-7 ) 17 | [hex] 5200 const StarSpeed ( Star speeds as pixels per tick ) 18 | [hex] 5300 const StarChar ( Char index used by each star ) 19 | [hex] 5400 const StarScreenAddr ( Stars' screen addresses ) 20 | [hex] 5500 const StarCharAddr ( Stars' character addresses ) 21 | [hex] 5600 const NumStars ( How many stars per char ) 22 | [hex] 5700 const FreeList ( Stack of free character indices ) 23 | [hex] 5800 const StarBitMask ( Copy of StarBitMask_slow for fast access ) 24 | 25 | 0 byte NumFree ( Number of items in the free list ) 26 | 27 | 0 variable seed ( Random number seed ) 28 | 29 | 2 base c! 30 | bytes StarBitMask_slow 31 | 00000001 32 | 00000010 33 | 00000100 34 | 00001000 35 | 00010000 36 | 00100000 37 | 01000000 38 | 10000000 39 | ; 40 | decimal 41 | 42 | : rnd 43 | seed @ 44 | 259 * 3 + 45 | 32767 and 46 | dup 47 | seed ! ; 48 | 49 | : star-x? ( star -- x ) StarX + c@ ; inline 50 | : star-y? ( star -- y ) StarY + c@ ; inline 51 | : star-speed? ( star -- speed ) StarSpeed + c@ ; inline 52 | : star-char? ( star -- char ) StarChar + c@ ; inline 53 | : star-screen-addr? ( star - addr ) 2* StarScreenAddr + @ ; inline 54 | : star-char-addr? ( star - addr ) 2* StarCharAddr + @ ; inline 55 | 56 | : star-x! ( x star -- ) StarX + c! ; inline 57 | : star-y! ( y star -- ) StarY + c! ; inline 58 | : star-speed! ( speed star -- ) StarSpeed + c! ; inline 59 | : star-char! ( char star -- ) StarChar + c! ; inline 60 | : star-screen-addr! ( addr star -- ) 2* StarScreenAddr + ! ; inline 61 | : star-char-addr! ( addr star -- ) 2* StarCharAddr + ! ; inline 62 | 63 | : num-stars? ( char -- n ) NumStars + c@ ; inline ( How many stars are using a char? ) 64 | : num-stars! ( n char -- ) NumStars + c! ; inline 65 | 66 | : alloc-char ( -- char ) 67 | NumFree dec ( NumFree-- ) 68 | NumFree c@ ( s: NumFree ) 69 | FreeList + c@ ( push FreeList[NumFree] ) 70 | ; inline 71 | 72 | : free-char ( char -- ) 73 | NumFree c@ ( s: char num-free ) 74 | FreeList + c! ( FreeList[NumFree] = char ) 75 | NumFree inc ( NumFree++ ) 76 | ; inline 77 | 78 | 0 variable stack-guard ( Debug only ) 79 | 80 | : stk! ( store stack address for stk? ) 81 | SPARE @ stack-guard ! ; 82 | 83 | : stk? ( check stack guard ) 84 | SPARE @ stack-guard @ = 0= if 85 | abort 86 | then ; 87 | 88 | : stars 89 | fast di cls 90 | 91 | ( Clear all characters ) 92 | [ CHARS 128 8 * + ] lit CHARS do 93 | 0 i c! 94 | loop 95 | 96 | ( Clear screen with empty char ) 97 | [ SCREEN SCREEN_WIDTH SCREEN_HEIGHT * + ] lit SCREEN do 98 | 127 i c! 99 | loop 100 | 101 | ( Clear num stars ) 102 | [ NumStars CHAR_COUNT + ] lit NumStars do 103 | 0 i c! 104 | loop 105 | 106 | ( Initialize star bit masks ) 107 | 8 0 do 108 | i StarBitMask_slow + c@ ( Read ) 109 | i StarBitMask + c! ( Write ) 110 | loop 111 | 112 | ( Initialize stars, one star per char initially ) 113 | STAR_COUNT 0 do 114 | i 7 and i star-x! ( Init X ) 115 | rnd 2 / 7 and i star-y! ( Init Y ) 116 | i 3 and 1+ i star-speed! ( Init speed ) 117 | i i star-char! ( Init char ) 118 | i 8 * i star-y? + CHARS + i star-char-addr! ( Init char addr ) 119 | 1 i num-stars! ( Init NumStars ) 120 | 121 | ( Initialize star screen address ) 122 | label again 123 | rnd 16 / [ SCREEN_WIDTH SCREEN_HEIGHT * ] lit mod SCREEN + ( s: screen-addr ) 124 | ( Make sure screen location is empty ) 125 | dup c@ 127 c= if 126 | i star-screen-addr! 127 | else 128 | drop goto again 129 | then 130 | loop 131 | 132 | ( Insert the remaining chars to free list ) 133 | 127 STAR_COUNT do 134 | i free-char 135 | loop 136 | 137 | ( Plot chars ) 138 | STAR_COUNT 0 do 139 | i i star-screen-addr? c! 140 | loop 141 | 142 | ( Main loop ) 143 | begin 144 | stk! 145 | 146 | ( Update stars ) 147 | STAR_COUNT 0 do 148 | i star-x? ( Get star x-coord ) 149 | i star-speed? + ( Move star ) 150 | 151 | ( Did StarX overflow? ) 152 | dup 7 c> if 153 | ( Wrap around to 0-7 ) 154 | 7 and 155 | 156 | ( TODO: fast path -- num stars = 1 and left side does not have a char -> move char left ) 157 | 158 | ( Decrement num stars ) 159 | i star-char? ( char ) 160 | NumStars + dec 161 | 162 | ( Erase star from char ) 163 | 0 i star-char-addr? c! 164 | 165 | ( Get star's screen address ) 166 | i star-screen-addr? ( s: screen-addr ) 167 | 168 | ( How many stars left in this char? ) 169 | i star-char? num-stars? 0= if 170 | ( Zero -> Erase char from screen ) 171 | 127 over c! 172 | ( Add char to free list ) 173 | i star-char? free-char 174 | then 175 | 176 | 1- ( Move left on the screen ) 177 | 178 | ( Wrap around to end of screen ) 179 | dup [ SCREEN 1- ] lit = if 180 | drop [ SCREEN SCREEN_WIDTH SCREEN_HEIGHT * + 1- ] lit 181 | then 182 | 183 | ( Update star's screen address ) 184 | dup i star-screen-addr! 185 | 186 | ( Is there a char already in the new location? ) 187 | dup c@ 127 c= if 188 | ( Nope, allocate a new char ) 189 | alloc-char ( s: screen-addr char ) 190 | ( Assign the char to the star ) 191 | dup i star-char! ( -- ) 192 | ( Plot it to screen ) 193 | over c! 194 | else 195 | dup c@ ( char ) 196 | ( Assign the char to the star ) 197 | i star-char! ( -- ) 198 | then 199 | 200 | drop ( Drop screen-addr ) 201 | 202 | ( Recompute char address ) 203 | i star-char? ( char ) 204 | dup 8 * i star-y? + CHARS + i star-char-addr! 205 | 206 | ( Increase num stars ) 207 | NumStars + inc 208 | then 209 | 210 | ( Store star X ) 211 | dup i star-x! 212 | 213 | ( Draw star to char ) 214 | StarBitMask + c@ ( bitmask ) 215 | i star-char-addr? c! 216 | loop 217 | 218 | stk? 219 | again ; -------------------------------------------------------------------------------- /test/mcode.f: -------------------------------------------------------------------------------- 1 | ( Test Machine Code Compilation ) 2 | ( This program should be compiled with --mcode and --optimize options. ) 3 | 4 | [hex] 2400 const SCREEN 5 | [hex] 3C37 const STKBOT 6 | [hex] 3C3B const SPARE 7 | 8 | 100 variable v 9 | 500 variable temp 10 | 11 | ( Define some words which return numbers which won't be optimized as literals. ) 12 | : one 0 1+ ; 13 | : two 0 2+ ; 14 | : three 0 2+ 1+ ; 15 | : minus-one 0 1- ; 16 | : minus-two 0 2- ; 17 | : minus-three 0 2- 1- ; 18 | 19 | : fail ." FAILED!" abort ; 20 | 21 | : chk ( result expected -- ) 22 | = if ." OK" else fail then ; 23 | 24 | : chk2 ( result1 result2 expected1 expected2 -- ) 25 | rot = >r ( s: result1 expected1 ; r: eq2 ) 26 | = r> ( s: eq1 eq2 ) 27 | and if ." OK" else fail then ; 28 | 29 | : chk3 ( result1 result2 result3 expected1 expected2 expected3 -- ) 30 | 4 roll = >r ( s: result1 result2 expected1 expected2 ; r: eq3 ) 31 | 3 roll = >r ( s: result1 expected1 ; r: eq3 eq2 ) 32 | = r> r> ( s: eq1 eq2 eq3 ) 33 | and and if ." OK" else fail then ; 34 | 35 | : stack 36 | ." DUP " 123 dup 123 123 chk2 cr 37 | ." DROP " 123 456 drop 123 chk cr 38 | ." NIP " 1 2 3 nip 1 3 chk2 cr 39 | ." OVER " 123 456 over 123 456 123 chk3 cr 40 | ." ?DUP " 123 ?dup 123 123 chk2 space 41 | 123 0 ?dup 456 123 0 456 chk3 cr 42 | ." SWAP " 123 456 swap 456 123 chk2 cr 43 | ." 2DUP " 123 456 2dup 123 456 chk2 space 123 456 chk2 cr 44 | ." 2DROP " 1 2 3 2drop 1 chk cr 45 | ." 2OVER " 1 2 3 4 2over 1 2 chk2 3 4 space chk2 space 1 2 chk2 cr 46 | ." PICK " 3 4 2 pick 3 4 3 chk3 cr 47 | ." ROLL " 1 2 2 roll 2 1 chk2 space 48 | 1 2 3 3 roll 2 3 1 chk3 cr 49 | ." ROT " 1 2 3 rot 2 3 1 chk3 cr 50 | ." >R R> " 3 7 >r 3 chk space r> 7 chk cr 51 | ." R@ " 1 2 >r r@ 1 2 chk2 cr ( Clean up: ) r> drop 52 | ; 53 | 54 | : arith 55 | ." + " 3 4 + 7 chk space ( n + literal ) 56 | -1000 -2000 + -3000 chk space 57 | 500 v @ + 600 chk space ( n + n ) 58 | [ hex ] 134 5000 + 5134 chk cr [ decimal ] 59 | 60 | ." - " 3 4 - -1 chk space ( n - literal ) 61 | -1000 -2000 - 1000 chk space 62 | 500 v @ - 400 chk space ( n - n ) 63 | [ hex ] 5134 5000 - 134 chk cr [ decimal ] 64 | 65 | ." * " 1000 5 * 5000 chk space ( n * literal ) 66 | -123 5 * -615 chk space 67 | -123 0 * 0 chk space ( 0* ) 68 | -123 1 * -123 chk space ( 1* ) 69 | -123 2 * -246 chk space ( 2* ) 70 | -123 4 * -492 chk space ( 4* ) 71 | -123 256 * -31488 chk space ( 256* ) 72 | -12 512 * -6144 chk space ( 512* ) 73 | -12 2048 * -24576 chk space ( 512* ) 74 | -1 32768 * -32768 chk space ( 32768* ) 75 | 100 v @ * 10000 chk cr ( n * n ) 76 | 77 | ." C* " 5 50 c* 250 chk space ( n * literal ) 78 | 2 v @ c* 200 chk space ( n * value ) 79 | 3 1 c* 3 chk space ( 1 specialization ) 80 | 3 2 c* 6 chk space ( 2 specialization ) 81 | 3 4 c* 12 chk space ( 4 specialization ) 82 | 240 120 c* 28800 chk space 83 | 120 240 c* 28800 chk space 84 | 3 256 c* 0 chk cr ( out of range specialization ) 85 | 86 | ." / " 1000 3 / 333 chk space ( Generic algorithm ) 87 | 1000 1 / 1000 chk space ( 1/ ) 88 | 1000 2 / 500 chk space ( 2/ ) 89 | 1000 4 / 250 chk space ( 4/ ) 90 | -1000 8 / -125 chk space ( 8/ ) 91 | 1000 256 / 3 chk space ( 256/ ) 92 | 10000 1024 / 9 chk cr 93 | 94 | ." 1+ " 5 1+ 6 chk cr 95 | 96 | ." 1- " 5 1- 4 chk cr 97 | 98 | ." 2+ " 1000 2+ 1002 chk cr 99 | 100 | ." 2- " 1000 2- 998 chk cr 101 | 102 | ." 2* " 1000 2* 2000 chk space 103 | -1000 2* -2000 chk cr 104 | 105 | ." 2/ " 1000 2/ 500 chk space 106 | -1000 2/ -500 chk cr 107 | 108 | ." NEGATE " 1234 negate -1234 chk space 109 | -1234 negate 1234 chk cr 110 | 111 | ." ABS " 4892 abs 4892 chk space 112 | -4892 abs 4892 chk cr 113 | 114 | ." MIN " 7000 123 min 123 chk space 115 | -7000 123 min -7000 chk cr 116 | 117 | ." MAX " 7000 123 max 7000 chk space 118 | -7000 123 max 123 chk cr 119 | 120 | [ hex ] 121 | ." XOR " 1234 1111 xor 0325 chk space ( n xor literal ) 122 | 1fff v @ xor 1f9b chk space ( n xor n ) 123 | 1234 0 xor 1234 chk space ( 0 specialization ) 124 | 1234 11 xor 1225 chk space ( lo byte only ) 125 | 1234 1100 xor 0334 chk cr ( hi byte only ) 126 | 127 | ." AND " 7777 1f1f and 1717 chk space ( n and literal ) 128 | 0ff0 v @ and 60 chk space ( n and n ) 129 | ffff 11 and 11 chk space ( lo byte only ) 130 | ffff fa00 and fa00 chk space ( hi byte only ) 131 | 1234 ff and 34 chk space ( select lo byte ) 132 | 1234 ff00 and 1200 chk cr ( select hi byte ) 133 | 134 | ." OR " 1234 f0f0 or f2f4 chk space ( n or literal ) 135 | f0 v @ or f4 chk space ( n or n ) 136 | 1234 ff or 12ff chk space ( set lo byte ) 137 | 1234 ff00 or ff34 chk cr ( set hi byte ) 138 | [ decimal ] 139 | ; 140 | 141 | : rel-ops 142 | ." 0= " 0 0= 1 chk space 143 | 256 0= 0 chk cr 144 | 145 | ." 0< " -5000 0< 1 chk space 146 | 0 0< 0 chk space 147 | 5000 0< 0 chk cr 148 | 149 | ." 0> " 5000 0> 1 chk space 150 | 0 0> 0 chk space 151 | -5000 0> 0 chk cr 152 | 153 | ." = " 3 5 = 0 chk space 154 | 12345 12345 = 1 chk space 155 | -12345 12345 = 0 chk space 156 | 100 v @ = 1 chk space ( Non-literal ) 157 | 101 v @ = 0 chk cr ( Non-literal ) 158 | 159 | ." C= " 3 5 c= 0 chk space 160 | 50 50 c= 1 chk space 161 | 1024 0 c= 1 chk space ( Only hi bytes differ ) 162 | -50 50 c= 0 chk space 163 | 100 v c@ c= 1 chk space ( Non-literal ) 164 | 101 v c@ c= 0 chk cr ( Non-literal ) 165 | 166 | ." C> " 3 5 c> 0 chk space 167 | 5 5 c> 0 chk space 168 | 6 5 c> 1 chk space 169 | 255 50 c> 1 chk space 170 | 255 255 c> 0 chk space 171 | 0 -1 c> 0 chk space 172 | 1 three c> 0 chk space 173 | 4 three c> 1 chk space 174 | 3 three c> 0 chk space 175 | -1 three c> 1 chk cr ( Comparison is unsigned, so -1 equals 255 ) 176 | 177 | ." C< " 3 5 c< 1 chk space 178 | 5 5 c< 0 chk space 179 | 6 5 c< 0 chk space 180 | 30 0 c< 0 chk space 181 | 254 -1 c< 1 chk space 182 | 1 three c< 1 chk space 183 | 4 three c< 0 chk space 184 | 3 three c< 0 chk cr 185 | 186 | ." > " 3000 5000 > 0 chk space 187 | 5000 -3000 > 1 chk space 188 | -3000 5000 > 0 chk space 189 | -1000 -2000 > 1 chk space 190 | -2000 -1000 > 0 chk space 191 | 1000 1000 > 0 chk space 192 | -1000 -1000 > 0 chk space 193 | 0 0 > 0 chk cr 194 | 195 | ." < " 3000 5000 < 1 chk space 196 | 5000 -3000 < 0 chk space 197 | -3000 5000 < 1 chk space 198 | -1000 -2000 < 0 chk space 199 | -2000 -1000 < 1 chk space 200 | 1000 1000 < 0 chk space 201 | -1000 -1000 < 0 chk space 202 | 0 0 < 0 chk cr 203 | ; 204 | 205 | : mem 206 | ." ! @ " 12345 v ! v @ 12345 chk space ( Literal address ) 207 | v 12345 over ! @ 12345 chk cr ( Non-literal address ) 208 | 209 | ." C! C@ " 123 v c! v c@ 123 chk space ( Literal address ) 210 | v 123 over c! c@ 123 chk cr ( Non-literal address ) 211 | 212 | ." INC " temp inc temp @ 501 chk cr 213 | 214 | ." DEC " temp dec temp @ 500 chk cr 215 | ; 216 | 217 | : test-again 218 | 1 219 | begin 220 | dup + 221 | dup 1000 > if exit then 222 | again ; 223 | 224 | : test-loop 225 | 0 226 | 2 0 do 227 | 5 0 do 228 | i j + + 229 | loop 230 | loop ; 231 | 232 | : test-leave 233 | 0 234 | 100 0 do 235 | 1+ 236 | i 10 = if leave then 237 | loop ; 238 | 239 | : test-goto 240 | 123 >r 241 | 3 242 | label back 243 | r> 1- >r 244 | 1- 245 | ?dup if goto back then 246 | r> ; 247 | 248 | : control-flow 249 | ." IF " 1 2 if 3 then 1 3 chk2 space 250 | 1 0 if 2 else 3 then 1 3 chk2 cr 251 | 252 | ." UNTIL " 6 1 0 0 begin 5 >r until r> r> r> 5 5 5 chk3 space 6 chk cr 253 | 254 | ." AGAIN " test-again 1024 chk cr 255 | 256 | ." LOOP " 0 1000 -100 do i + loop -29838 chk space ( 16-bit ) 257 | 0 100 0 do i + loop 4950 chk space ( 8-bit ) 258 | 0 three one do i + loop 3 chk space ( Non-literal counter & limit ) 259 | 0 10 20 do i + loop 20 chk space ( "Invalid loop" ) 260 | test-loop 25 chk space 261 | test-leave 11 chk cr 262 | 263 | ." +LOOP " 0 500 -300 do i + 2 +loop -25936 chk space ( Count up ) 264 | 0 -300 500 do i + -3 +loop 26967 chk space ( Count down ) 265 | 0 500 -300 do i + two +loop -25936 chk space ( Generic, count up ) 266 | 0 -300 500 do i + minus-three +loop 26967 chk cr ( Generic, count down ) 267 | 268 | ." I' " 0 10 0 do i' + loop 100 chk cr 269 | 270 | ." GOTO " 5 goto skip 6 label skip 5 chk space ( Forward goto ) 271 | test-goto 120 chk cr ( Backward goto ) 272 | ; 273 | 274 | : print 275 | ." EMIT " ascii * emit cr 276 | ." SPACE " space ascii * emit cr 277 | ." SPACES " 2 spaces ascii * emit cr 278 | ( 0 29 at ." AT" ) 279 | ." TYPE " 15424 5 type space ." RULES" cr 280 | ; 281 | 282 | : test-in-out 283 | ." PLAYING SOUND..." 284 | 12345 285 | 100 begin 286 | 65278 in drop ( pull speaker ) 287 | 300 0 do loop 288 | 0 65278 out ( push speaker ) 289 | 300 0 do loop 290 | 1- dup 0= 291 | until drop ; 292 | 293 | : test-inkey 294 | ." *PRESS SPACE* " 295 | begin 296 | inkey 32 = 297 | until ; 298 | 299 | : double 2* ; 300 | :m test-macro 1 100 + postpone lit postpone double ; 301 | 302 | : misc 303 | ." LIT " [ 5 3 * ] lit 15 chk cr 304 | ." CONST " SCREEN 9216 chk cr 305 | ." MACRO " test-macro 202 chk cr 306 | 307 | ." BASE " 8 base c! 255 . cr ( ff ) 308 | ." HEX " hex 255 . cr ( ff ) 309 | ." DEC " decimal 255 . cr ( 255 ) 310 | ." .S " 1 2 3 .s drop drop drop cr 311 | ; 312 | 313 | : i/o 314 | ." INKEY " test-inkey cr 315 | ." IN OUT " test-in-out cr 12345 chk cr 316 | ; 317 | 318 | : benchmark-stack 319 | 10000 0 do 320 | dup dup dup dup dup dup dup dup dup dup 321 | drop drop drop drop drop drop drop drop drop drop 322 | loop ; 323 | 324 | : benchmark-over 325 | 100 0 do 326 | over over over over over over over over over over 327 | over over over over over over over over over over 328 | over over over over over over over over over over 329 | over over over over over over over over over over 330 | over over over over over over over over over over 331 | STKBOT @ 14 + SPARE ! ( Reset stack, except profile start time ) 332 | loop ; 333 | 334 | : benchmark-swap 335 | 1 2 336 | 10000 0 do 337 | swap swap swap swap swap swap swap swap swap swap 338 | loop 2drop ; 339 | 340 | : benchmark-loop 341 | 200 0 do 342 | 200 0 do loop 343 | loop ; 344 | 345 | : benchmark-rstack 346 | 5000 0 do 347 | >r r> >r r> >r r> >r r> >r r> >r r> >r r> >r r> 348 | >r r> >r r> >r r> >r r> >r r> >r r> >r r> >r r> 349 | loop ; 350 | 351 | : benchmark-arith 352 | 5 353 | 10000 0 do 354 | dup + dup + dup + dup + dup - dup - dup - dup - 355 | loop drop ; 356 | 357 | : benchmark-arith2 358 | 5 359 | 10000 0 do 360 | 1 + 2 + 3 + 4 + 5 + 361 | 1 - 2 - 3 - 4 - 5 - 362 | loop drop ; 363 | 364 | : benchmark-1+ 365 | 0 366 | 10000 0 do 367 | 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 368 | loop drop ; 369 | 370 | : benchmark-2* 371 | 5000 0 do 372 | 3 2* 2* 2* 2* 2* 2* 2* 2* 2* drop 373 | loop ; 374 | 375 | : benchmark-2/ 376 | 500 0 do 377 | 31111 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ drop 378 | loop ; 379 | 380 | : benchmark-* 381 | 2 382 | 1000 0 do 383 | 2 * 7 * 123 * 256 * 789 * 384 | loop drop ; 385 | 386 | : benchmark-c* 387 | 2 388 | 1000 0 do 389 | 2 c* 5 c* 9 c* 10 c* 7 c* 390 | loop drop ; 391 | 392 | : time ( -- time ) 393 | 252 in ( lo byte ) 394 | 253 in ( hi byte ) 395 | 256 * + ; 396 | 397 | : begin-profile ( -- start-time ) time ; 398 | 399 | : end-profile ( start-time -- ) time swap - . cr ; 400 | 401 | : main 402 | fast di cls invis 403 | stack 404 | arith 405 | rel-ops 406 | mem 407 | control-flow 408 | print 409 | misc 410 | 411 | cr ." Running benchmarks..." cr 412 | ." STACK " begin-profile benchmark-stack end-profile ( 17830 -> 5680, 3.1 times faster ) 413 | ." OVER " begin-profile benchmark-over end-profile ( 2257 -> 204, 11 times faster ) 414 | ." SWAP " begin-profile benchmark-swap end-profile ( 15091 -> 3865, 3.9 times faster ) 415 | ." LOOP " begin-profile benchmark-loop end-profile ( 4676 -> 598, 7.8 times faster ) 416 | ." >R R> " begin-profile benchmark-rstack end-profile ( 11088 -> 5000, 2.2 times faster ) 417 | ." ARITH " begin-profile benchmark-arith end-profile ( 24795 -> 5151, 4.8 times faster ) 418 | ." ARITH2 " begin-profile benchmark-arith2 end-profile ( 27322 -> 751, 36 times faster ) 419 | ." 1+ " begin-profile benchmark-1+ end-profile ( 12266 -> 425, 29 times faster ) 420 | ." 2* " begin-profile benchmark-2* end-profile ( 14256 -> 613, 23 times faster ) 421 | ." 2/ " begin-profile benchmark-2/ end-profile ( 19159 -> 62, 309 times faster ) 422 | ." * " begin-profile benchmark-* end-profile ( 3435 -> 1232, 2.8 times faster ) 423 | ." C* " begin-profile benchmark-c* end-profile ( 3689 -> 523, 7.1 times faster ) 424 | 425 | cr i/o 426 | 427 | cr ." All tests passed!" 428 | ; 429 | -------------------------------------------------------------------------------- /z80_opcodes.lua: -------------------------------------------------------------------------------- 1 | return { 2 | [0x00] = "NOP", 3 | [0x01] = { nn = { nn = "LD BC,nn" } }, 4 | [0x02] = "LD (BC),A", 5 | [0x03] = "INC BC", 6 | [0x04] = "INC B", 7 | [0x05] = "DEC B", 8 | [0x06] = { n = "LD B,n" }, 9 | [0x07] = "RLCA", 10 | [0x08] = "EX AF,AF'", 11 | [0x09] = "ADD HL,BC", 12 | [0x0a] = "LD A,(BC)", 13 | [0x0b] = "DEC BC", 14 | [0x0c] = "INC C", 15 | [0x0d] = "DEC C", 16 | [0x0e] = { n = "LD C,n" }, 17 | [0x0f] = "RRCA", 18 | [0x10] = { o = "DJNZ o" }, 19 | [0x11] = { nn = { nn = "LD DE,nn" } }, 20 | [0x12] = "LD (DE),A", 21 | [0x13] = "INC DE", 22 | [0x14] = "INC D", 23 | [0x15] = "DEC D", 24 | [0x16] = { n = "LD D,n" }, 25 | [0x17] = "RLA", 26 | [0x18] = { o = "JR o" }, 27 | [0x19] = "ADD HL,DE", 28 | [0x1a] = "LD A,(DE)", 29 | [0x1b] = "DEC DE", 30 | [0x1c] = "INC E", 31 | [0x1d] = "DEC E", 32 | [0x1e] = { n = "LD E,n" }, 33 | [0x1f] = "RRA", 34 | [0x20] = { o = "JR NZ,o" }, 35 | [0x21] = { nn = { nn = "LD HL,nn" } }, 36 | [0x22] = { nn = { nn = "LD (nn),HL" } }, 37 | [0x23] = "INC HL", 38 | [0x24] = "INC H", 39 | [0x25] = "DEC H", 40 | [0x26] = { n = "LD H,n" }, 41 | [0x27] = "DAA", 42 | [0x28] = { o = "JR Z,o" }, 43 | [0x29] = "ADD HL,HL", 44 | [0x2a] = { nn = { nn = "LD HL,(nn)" } }, 45 | [0x2b] = "DEC HL", 46 | [0x2c] = "INC L", 47 | [0x2d] = "DEC L", 48 | [0x2e] = { n = "LD L,n" }, 49 | [0x2f] = "CPL", 50 | [0x30] = { o = "JR NC,o" }, 51 | [0x31] = { nn = { nn = "LD SP,nn" } }, 52 | [0x32] = { nn = { nn = "LD (nn),A" } }, 53 | [0x33] = "INC SP", 54 | [0x34] = "INC (HL)", 55 | [0x35] = "DEC (HL)", 56 | [0x36] = { n = "LD (HL),n" }, 57 | [0x37] = "SCF", 58 | [0x38] = { o = "JR C,o" }, 59 | [0x39] = "ADD HL,SP", 60 | [0x3a] = { nn = { nn = "LD A,(nn)" } }, 61 | [0x3b] = "DEC SP", 62 | [0x3c] = "INC A", 63 | [0x3d] = "DEC A", 64 | [0x3e] = { n = "LD A,n" }, 65 | [0x3f] = "CCF", 66 | [0x40] = "LD B,B", 67 | [0x41] = "LD B,C", 68 | [0x42] = "LD B,D", 69 | [0x43] = "LD B,E", 70 | [0x44] = "LD B,H", 71 | [0x45] = "LD B,L", 72 | [0x46] = "LD B,(HL)", 73 | [0x47] = "LD B,A", 74 | [0x48] = "LD C,B", 75 | [0x49] = "LD C,C", 76 | [0x4a] = "LD C,D", 77 | [0x4b] = "LD C,E", 78 | [0x4c] = "LD C,H", 79 | [0x4d] = "LD C,L", 80 | [0x4e] = "LD C,(HL)", 81 | [0x4f] = "LD C,A", 82 | [0x50] = "LD D,B", 83 | [0x51] = "LD D,C", 84 | [0x52] = "LD D,D", 85 | [0x53] = "LD D,E", 86 | [0x54] = "LD D,H", 87 | [0x55] = "LD D,L", 88 | [0x56] = "LD D,(HL)", 89 | [0x57] = "LD D,A", 90 | [0x58] = "LD E,B", 91 | [0x59] = "LD E,C", 92 | [0x5a] = "LD E,D", 93 | [0x5b] = "LD E,E", 94 | [0x5c] = "LD E,H", 95 | [0x5d] = "LD E,L", 96 | [0x5e] = "LD E,(HL)", 97 | [0x5f] = "LD E,A", 98 | [0x60] = "LD H,B", 99 | [0x61] = "LD H,C", 100 | [0x62] = "LD H,D", 101 | [0x63] = "LD H,E", 102 | [0x64] = "LD H,H", 103 | [0x65] = "LD H,L", 104 | [0x66] = "LD H,(HL)", 105 | [0x67] = "LD H,A", 106 | [0x68] = "LD L,B", 107 | [0x69] = "LD L,C", 108 | [0x6a] = "LD L,D", 109 | [0x6b] = "LD L,E", 110 | [0x6c] = "LD L,H", 111 | [0x6d] = "LD L,L", 112 | [0x6e] = "LD L,(HL)", 113 | [0x6f] = "LD L,A", 114 | [0x70] = "LD (HL),B", 115 | [0x71] = "LD (HL),C", 116 | [0x72] = "LD (HL),D", 117 | [0x73] = "LD (HL),E", 118 | [0x74] = "LD (HL),H", 119 | [0x75] = "LD (HL),L", 120 | [0x76] = "HALT", 121 | [0x77] = "LD (HL),A", 122 | [0x78] = "LD A,B", 123 | [0x79] = "LD A,C", 124 | [0x7a] = "LD A,D", 125 | [0x7b] = "LD A,E", 126 | [0x7c] = "LD A,H", 127 | [0x7d] = "LD A,L", 128 | [0x7e] = "LD A,(HL)", 129 | [0x7f] = "LD A,A", 130 | [0x80] = "ADD A,B", 131 | [0x81] = "ADD A,C", 132 | [0x82] = "ADD A,D", 133 | [0x83] = "ADD A,E", 134 | [0x84] = "ADD A,H", 135 | [0x85] = "ADD A,L", 136 | [0x86] = "ADD A,(HL)", 137 | [0x87] = "ADD A,A", 138 | [0x88] = "ADC A,B", 139 | [0x89] = "ADC A,C", 140 | [0x8a] = "ADC A,D", 141 | [0x8b] = "ADC A,E", 142 | [0x8c] = "ADC A,H", 143 | [0x8d] = "ADC A,L", 144 | [0x8e] = "ADC A,(HL)", 145 | [0x8f] = "ADC A,A", 146 | [0x90] = "SUB B", 147 | [0x91] = "SUB C", 148 | [0x92] = "SUB D", 149 | [0x93] = "SUB E", 150 | [0x94] = "SUB H", 151 | [0x95] = "SUB L", 152 | [0x96] = "SUB (HL)", 153 | [0x97] = "SUB A", 154 | [0x98] = "SBC A,B", 155 | [0x99] = "SBC A,C", 156 | [0x9a] = "SBC A,D", 157 | [0x9b] = "SBC A,E", 158 | [0x9c] = "SBC A,H", 159 | [0x9d] = "SBC A,L", 160 | [0x9e] = "SBC A,(HL)", 161 | [0x9f] = "SBC A,A", 162 | [0xa0] = "AND B", 163 | [0xa1] = "AND C", 164 | [0xa2] = "AND D", 165 | [0xa3] = "AND E", 166 | [0xa4] = "AND H", 167 | [0xa5] = "AND L", 168 | [0xa6] = "AND (HL)", 169 | [0xa7] = "AND A", 170 | [0xa8] = "XOR B", 171 | [0xa9] = "XOR C", 172 | [0xaa] = "XOR D", 173 | [0xab] = "XOR E", 174 | [0xac] = "XOR H", 175 | [0xad] = "XOR L", 176 | [0xae] = "XOR (HL)", 177 | [0xaf] = "XOR A", 178 | [0xb0] = "OR B", 179 | [0xb1] = "OR C", 180 | [0xb2] = "OR D", 181 | [0xb3] = "OR E", 182 | [0xb4] = "OR H", 183 | [0xb5] = "OR L", 184 | [0xb6] = "OR (HL)", 185 | [0xb7] = "OR A", 186 | [0xb8] = "CP B", 187 | [0xb9] = "CP C", 188 | [0xba] = "CP D", 189 | [0xbb] = "CP E", 190 | [0xbc] = "CP H", 191 | [0xbd] = "CP L", 192 | [0xbe] = "CP (HL)", 193 | [0xbf] = "CP A", 194 | [0xc0] = "RET NZ", 195 | [0xc1] = "POP BC", 196 | [0xc2] = { nn = { nn = "JP NZ,nn" } }, 197 | [0xc3] = { nn = { nn = "JP nn" } }, 198 | [0xc4] = { nn = { nn = "CALL NZ,nn" } }, 199 | [0xc5] = "PUSH BC", 200 | [0xc6] = { n = "ADD A,n" }, 201 | [0xc7] = "RST 0", 202 | [0xc8] = "RET Z", 203 | [0xc9] = "RET", 204 | [0xca] = { nn = { nn = "JP Z,nn" } }, 205 | [0xcb] = { 206 | [0x00] = "RLC B", 207 | [0x01] = "RLC C", 208 | [0x02] = "RLC D", 209 | [0x03] = "RLC E", 210 | [0x04] = "RLC H", 211 | [0x05] = "RLC L", 212 | [0x06] = "RLC (HL)", 213 | [0x07] = "RLC A", 214 | [0x08] = "RRC B", 215 | [0x09] = "RRC C", 216 | [0x0a] = "RRC D", 217 | [0x0b] = "RRC E", 218 | [0x0c] = "RRC H", 219 | [0x0d] = "RRC L", 220 | [0x0e] = "RRC (HL)", 221 | [0x0f] = "RRC A", 222 | [0x10] = "RL B", 223 | [0x11] = "RL C", 224 | [0x12] = "RL D", 225 | [0x13] = "RL E", 226 | [0x14] = "RL H", 227 | [0x15] = "RL L", 228 | [0x16] = "RL (HL)", 229 | [0x17] = "RL A", 230 | [0x18] = "RR B", 231 | [0x19] = "RR C", 232 | [0x1a] = "RR D", 233 | [0x1b] = "RR E", 234 | [0x1c] = "RR H", 235 | [0x1d] = "RR L", 236 | [0x1e] = "RR (HL)", 237 | [0x1f] = "RR A", 238 | [0x20] = "SLA B", 239 | [0x21] = "SLA C", 240 | [0x22] = "SLA D", 241 | [0x23] = "SLA E", 242 | [0x24] = "SLA H", 243 | [0x25] = "SLA L", 244 | [0x26] = "SLA (HL)", 245 | [0x27] = "SLA A", 246 | [0x28] = "SRA B", 247 | [0x29] = "SRA C", 248 | [0x2a] = "SRA D", 249 | [0x2b] = "SRA E", 250 | [0x2c] = "SRA H", 251 | [0x2d] = "SRA L", 252 | [0x2e] = "SRA (HL)", 253 | [0x2f] = "SRA A", 254 | [0x38] = "SRL B", 255 | [0x39] = "SRL C", 256 | [0x3a] = "SRL D", 257 | [0x3b] = "SRL E", 258 | [0x3c] = "SRL H", 259 | [0x3d] = "SRL L", 260 | [0x3e] = "SRL (HL)", 261 | [0x3f] = "SRL A", 262 | [0x40] = "BIT 0,B", 263 | [0x41] = "BIT 0,C", 264 | [0x42] = "BIT 0,D", 265 | [0x43] = "BIT 0,E", 266 | [0x44] = "BIT 0,H", 267 | [0x45] = "BIT 0,L", 268 | [0x46] = "BIT 0,(HL)", 269 | [0x47] = "BIT 0,A", 270 | [0x48] = "BIT 1,B", 271 | [0x49] = "BIT 1,C", 272 | [0x4a] = "BIT 1,D", 273 | [0x4b] = "BIT 1,E", 274 | [0x4c] = "BIT 1,H", 275 | [0x4d] = "BIT 1,L", 276 | [0x4e] = "BIT 1,(HL)", 277 | [0x4f] = "BIT 1,A", 278 | [0x50] = "BIT 2,B", 279 | [0x51] = "BIT 2,C", 280 | [0x52] = "BIT 2,D", 281 | [0x53] = "BIT 2,E", 282 | [0x54] = "BIT 2,H", 283 | [0x55] = "BIT 2,L", 284 | [0x56] = "BIT 2,(HL)", 285 | [0x57] = "BIT 2,A", 286 | [0x58] = "BIT 3,B", 287 | [0x59] = "BIT 3,C", 288 | [0x5a] = "BIT 3,D", 289 | [0x5b] = "BIT 3,E", 290 | [0x5c] = "BIT 3,H", 291 | [0x5d] = "BIT 3,L", 292 | [0x5e] = "BIT 3,(HL)", 293 | [0x5f] = "BIT 3,A", 294 | [0x60] = "BIT 4,B", 295 | [0x61] = "BIT 4,C", 296 | [0x62] = "BIT 4,D", 297 | [0x63] = "BIT 4,E", 298 | [0x64] = "BIT 4,H", 299 | [0x65] = "BIT 4,L", 300 | [0x66] = "BIT 4,(HL)", 301 | [0x67] = "BIT 4,A", 302 | [0x68] = "BIT 5,B", 303 | [0x69] = "BIT 5,C", 304 | [0x6a] = "BIT 5,D", 305 | [0x6b] = "BIT 5,E", 306 | [0x6c] = "BIT 5,H", 307 | [0x6d] = "BIT 5,L", 308 | [0x6e] = "BIT 5,(HL)", 309 | [0x6f] = "BIT 5,A", 310 | [0x70] = "BIT 6,B", 311 | [0x71] = "BIT 6,C", 312 | [0x72] = "BIT 6,D", 313 | [0x73] = "BIT 6,E", 314 | [0x74] = "BIT 6,H", 315 | [0x75] = "BIT 6,L", 316 | [0x76] = "BIT 6,(HL)", 317 | [0x77] = "BIT 6,A", 318 | [0x78] = "BIT 7,B", 319 | [0x79] = "BIT 7,C", 320 | [0x7a] = "BIT 7,D", 321 | [0x7b] = "BIT 7,E", 322 | [0x7c] = "BIT 7,H", 323 | [0x7d] = "BIT 7,L", 324 | [0x7e] = "BIT 7,(HL)", 325 | [0x7f] = "BIT 7,A", 326 | [0x80] = "RES 0,B", 327 | [0x81] = "RES 0,C", 328 | [0x82] = "RES 0,D", 329 | [0x83] = "RES 0,E", 330 | [0x84] = "RES 0,H", 331 | [0x85] = "RES 0,L", 332 | [0x86] = "RES 0,(HL)", 333 | [0x87] = "RES 0,A", 334 | [0x88] = "RES 1,B", 335 | [0x89] = "RES 1,C", 336 | [0x8a] = "RES 1,D", 337 | [0x8b] = "RES 1,E", 338 | [0x8c] = "RES 1,H", 339 | [0x8d] = "RES 1,L", 340 | [0x8e] = "RES 1,(HL)", 341 | [0x8f] = "RES 1,A", 342 | [0x90] = "RES 2,B", 343 | [0x91] = "RES 2,C", 344 | [0x92] = "RES 2,D", 345 | [0x93] = "RES 2,E", 346 | [0x94] = "RES 2,H", 347 | [0x95] = "RES 2,L", 348 | [0x96] = "RES 2,(HL)", 349 | [0x97] = "RES 2,A", 350 | [0x98] = "RES 3,B", 351 | [0x99] = "RES 3,C", 352 | [0x9a] = "RES 3,D", 353 | [0x9b] = "RES 3,E", 354 | [0x9c] = "RES 3,H", 355 | [0x9d] = "RES 3,L", 356 | [0x9e] = "RES 3,(HL)", 357 | [0x9f] = "RES 3,A", 358 | [0xa0] = "RES 4,B", 359 | [0xa1] = "RES 4,C", 360 | [0xa2] = "RES 4,D", 361 | [0xa3] = "RES 4,E", 362 | [0xa4] = "RES 4,H", 363 | [0xa5] = "RES 4,L", 364 | [0xa6] = "RES 4,(HL)", 365 | [0xa7] = "RES 4,A", 366 | [0xa8] = "RES 5,B", 367 | [0xa9] = "RES 5,C", 368 | [0xaa] = "RES 5,D", 369 | [0xab] = "RES 5,E", 370 | [0xac] = "RES 5,H", 371 | [0xad] = "RES 5,L", 372 | [0xae] = "RES 5,(HL)", 373 | [0xaf] = "RES 5,A", 374 | [0xb0] = "RES 6,B", 375 | [0xb1] = "RES 6,C", 376 | [0xb2] = "RES 6,D", 377 | [0xb3] = "RES 6,E", 378 | [0xb4] = "RES 6,H", 379 | [0xb5] = "RES 6,L", 380 | [0xb6] = "RES 6,(HL)", 381 | [0xb7] = "RES 6,A", 382 | [0xb8] = "RES 7,B", 383 | [0xb9] = "RES 7,C", 384 | [0xba] = "RES 7,D", 385 | [0xbb] = "RES 7,E", 386 | [0xbc] = "RES 7,H", 387 | [0xbd] = "RES 7,L", 388 | [0xbe] = "RES 7,(HL)", 389 | [0xbf] = "RES 7,A", 390 | [0xc0] = "SET 0,B", 391 | [0xc1] = "SET 0,C", 392 | [0xc2] = "SET 0,D", 393 | [0xc3] = "SET 0,E", 394 | [0xc4] = "SET 0,H", 395 | [0xc5] = "SET 0,L", 396 | [0xc6] = "SET 0,(HL)", 397 | [0xc7] = "SET 0,A", 398 | [0xc8] = "SET 1,B", 399 | [0xc9] = "SET 1,C", 400 | [0xca] = "SET 1,D", 401 | [0xcb] = "SET 1,E", 402 | [0xcc] = "SET 1,H", 403 | [0xcd] = "SET 1,L", 404 | [0xce] = "SET 1,(HL)", 405 | [0xcf] = "SET 1,A", 406 | [0xd0] = "SET 2,B", 407 | [0xd1] = "SET 2,C", 408 | [0xd2] = "SET 2,D", 409 | [0xd3] = "SET 2,E", 410 | [0xd4] = "SET 2,H", 411 | [0xd5] = "SET 2,L", 412 | [0xd6] = "SET 2,(HL)", 413 | [0xd7] = "SET 2,A", 414 | [0xd8] = "SET 3,B", 415 | [0xd9] = "SET 3,C", 416 | [0xda] = "SET 3,D", 417 | [0xdb] = "SET 3,E", 418 | [0xdc] = "SET 3,H", 419 | [0xdd] = "SET 3,L", 420 | [0xde] = "SET 3,(HL)", 421 | [0xdf] = "SET 3,A", 422 | [0xe0] = "SET 4,B", 423 | [0xe1] = "SET 4,C", 424 | [0xe2] = "SET 4,D", 425 | [0xe3] = "SET 4,E", 426 | [0xe4] = "SET 4,H", 427 | [0xe5] = "SET 4,L", 428 | [0xe6] = "SET 4,(HL)", 429 | [0xe7] = "SET 4,A", 430 | [0xe8] = "SET 5,B", 431 | [0xe9] = "SET 5,C", 432 | [0xea] = "SET 5,D", 433 | [0xeb] = "SET 5,E", 434 | [0xec] = "SET 5,H", 435 | [0xed] = "SET 5,L", 436 | [0xee] = "SET 5,(HL)", 437 | [0xef] = "SET 5,A", 438 | [0xf0] = "SET 6,B", 439 | [0xf1] = "SET 6,C", 440 | [0xf2] = "SET 6,D", 441 | [0xf3] = "SET 6,E", 442 | [0xf4] = "SET 6,H", 443 | [0xf5] = "SET 6,L", 444 | [0xf6] = "SET 6,(HL)", 445 | [0xf7] = "SET 6,A", 446 | [0xf8] = "SET 7,B", 447 | [0xf9] = "SET 7,C", 448 | [0xfa] = "SET 7,D", 449 | [0xfb] = "SET 7,E", 450 | [0xfc] = "SET 7,H", 451 | [0xfd] = "SET 7,L", 452 | [0xfe] = "SET 7,(HL)", 453 | [0xff] = "SET 7,A" }, 454 | [0xcc] = { nn = { nn = "CALL Z,nn" } }, 455 | [0xcd] = { nn = { nn = "CALL nn" } }, 456 | [0xce] = { n = "ADC A,n" }, 457 | [0xcf] = "RST 8H", 458 | [0xd0] = "RET NC", 459 | [0xd1] = "POP DE", 460 | [0xd2] = { nn = { nn = "JP NC,nn" } }, 461 | [0xd3] = { n = "OUT (n),A" }, 462 | [0xd4] = { nn = { nn = "CALL NC,nn" } }, 463 | [0xd5] = "PUSH DE", 464 | [0xd6] = { n = "SUB n" }, 465 | [0xd7] = "RST 10H", 466 | [0xd8] = "RET C", 467 | [0xd9] = "EXX", 468 | [0xda] = { nn = { nn = "JP C,nn" } }, 469 | [0xdb] = { n = "IN A,(n)" }, 470 | [0xdc] = { nn = { nn = "CALL C,nn" } }, 471 | [0xdd] = { 472 | [0x09] = "ADD IX,BC", 473 | [0x19] = "ADD IX,DE", 474 | [0x21] = { nn = { nn = "LD IX,nn" } }, 475 | [0x22] = { nn = { nn = "LD (nn),IX" } }, 476 | [0x23] = "INC IX", 477 | [0x24] = "INC IXh", 478 | [0x25] = "DEC IXh", 479 | [0x26] = { n = "LD IXh,n" }, 480 | [0x29] = "ADD IX,IX", 481 | [0x2a] = { nn = { nn = "LD IX,(nn)" } }, 482 | [0x2b] = "DEC IX", 483 | [0x2c] = "INC IXl", 484 | [0x2d] = "DEC IXl", 485 | [0x2e] = { n = "LD IXl,n" }, 486 | [0x34] = { o = "INC (IX+o)" }, 487 | [0x35] = { o = "DEC (IX+o)" }, 488 | [0x36] = { o = { n = "LD (IX+o),n" } }, 489 | [0x39] = "ADD IX,SP", 490 | [0x44] = "LD B,IXh", 491 | [0x45] = "LD B,IXl", 492 | [0x46] = { o = "LD B,(IX+o)" }, 493 | [0x4c] = "LD C,IXh", 494 | [0x4d] = "LD C,IXl", 495 | [0x4e] = { o = "LD C,(IX+o)" }, 496 | [0x54] = "LD D,IXh", 497 | [0x55] = "LD D,IXl", 498 | [0x56] = { o = "LD D,(IX+o)" }, 499 | [0x5c] = "LD E,IXh", 500 | [0x5d] = "LD E,IXl", 501 | [0x5e] = { o = "LD E,(IX+o)" }, 502 | [0x64] = "LD IXh,h", 503 | [0x65] = "LD IXh,l", 504 | [0x66] = { o = "LD H,(IX+o)" }, 505 | [0x6c] = "LD IXl,h", 506 | [0x6d] = "LD IXl,l", 507 | [0x6e] = { o = "LD L,(IX+o)" }, 508 | [0x70] = { o = "LD (IX+o),B" }, 509 | [0x71] = { o = "LD (IX+o),C" }, 510 | [0x72] = { o = "LD (IX+o),D" }, 511 | [0x73] = { o = "LD (IX+o),E" }, 512 | [0x74] = { o = "LD (IX+o),H" }, 513 | [0x75] = { o = "LD (IX+o),L" }, 514 | [0x77] = { o = "LD (IX+o),A" }, 515 | [0x7c] = "LD A,IXh", 516 | [0x7d] = "LD A,IXl", 517 | [0x7e] = { o = "LD A,(IX+o)" }, 518 | [0x84] = "ADD A,IXh", 519 | [0x85] = "ADD A,IXl", 520 | [0x86] = { o = "ADD A,(IX+o)" }, 521 | [0x8c] = "ADC A,IXh", 522 | [0x8d] = "ADC A,IXl", 523 | [0x8e] = { o = "ADC A,(IX+o)" }, 524 | [0x94] = "SUB IXh", 525 | [0x95] = "SUB IXl", 526 | [0x96] = { o = "SUB (IX+o)" }, 527 | [0x9c] = "SBC A,IXh", 528 | [0x9d] = "SBC A,IXl", 529 | [0x9e] = { o = "SBC A,(IX+o)" }, 530 | [0xa4] = "AND IXh", 531 | [0xa5] = "AND IXl", 532 | [0xa6] = { o = "AND (IX+o)" }, 533 | [0xac] = "XOR IXh", 534 | [0xad] = "XOR IXl", 535 | [0xae] = { o = "XOR (IX+o)" }, 536 | [0xb4] = "OR IXh", 537 | [0xb5] = "OR IXl", 538 | [0xb6] = { o = "OR (IX+o)" }, 539 | [0xbc] = "CP IXh", 540 | [0xbd] = "CP IXl", 541 | [0xbe] = { o = "CP (IX+o)" }, 542 | [0xcb] = { o = { 543 | [0x06] = "RLC (IX+o)", 544 | [0x0e] = "RRC (IX+o)", 545 | [0x16] = "RL (IX+o)", 546 | [0x1e] = "RR (IX+o)", 547 | [0x26] = "SLA (IX+o)", 548 | [0x2e] = "SRA (IX+o)", 549 | [0x3e] = "SRL (IX+o)", 550 | [0x46] = "BIT 0,(IX+o)", 551 | [0x4e] = "BIT 1,(IX+o)", 552 | [0x56] = "BIT 2,(IX+o)", 553 | [0x5e] = "BIT 3,(IX+o)", 554 | [0x66] = "BIT 4,(IX+o)", 555 | [0x6e] = "BIT 5,(IX+o)", 556 | [0x76] = "BIT 6,(IX+o)", 557 | [0x7e] = "BIT 7,(IX+o)", 558 | [0x86] = "RES 0,(IX+o)", 559 | [0x8e] = "RES 1,(IX+o)", 560 | [0x96] = "RES 2,(IX+o)", 561 | [0x9e] = "RES 3,(IX+o)", 562 | [0xa6] = "RES 4,(IX+o)", 563 | [0xae] = "RES 5,(IX+o)", 564 | [0xb6] = "RES 6,(IX+o)", 565 | [0xbe] = "RES 7,(IX+o)", 566 | [0xc6] = "SET 0,(IX+o)", 567 | [0xce] = "SET 1,(IX+o)", 568 | [0xd6] = "SET 2,(IX+o)", 569 | [0xde] = "SET 3,(IX+o)", 570 | [0xe6] = "SET 4,(IX+o)", 571 | [0xee] = "SET 5,(IX+o)", 572 | [0xf6] = "SET 6,(IX+o)", 573 | [0xfe] = "SET 7,(IX+o)" } }, 574 | [0xe1] = "POP IX", 575 | [0xe3] = "EX (SP),IX", 576 | [0xe5] = "PUSH IX", 577 | [0xe9] = "JP (IX)", 578 | [0xf9] = "LD SP,IX" }, 579 | [0xde] = { n = "SBC A,n" }, 580 | [0xdf] = "RST 18H", 581 | [0xe0] = "RET PO", 582 | [0xe1] = "POP HL", 583 | [0xe2] = { nn = { nn = "JP PO,nn" } }, 584 | [0xe3] = "EX (SP),HL", 585 | [0xe4] = { nn = { nn = "CALL PO,nn" } }, 586 | [0xe5] = "PUSH HL", 587 | [0xe6] = { n = "AND n" }, 588 | [0xe7] = "RST 20H", 589 | [0xe8] = "RET PE", 590 | [0xe9] = "JP (HL)", 591 | [0xea] = { nn = { nn = "JP PE,nn" } }, 592 | [0xeb] = "EX DE,HL", 593 | [0xec] = { nn = { nn = "CALL PE,nn" } }, 594 | [0xed] = { 595 | [0x40] = "IN B,(C)", 596 | [0x41] = "OUT (C),B", 597 | [0x42] = "SBC HL,BC", 598 | [0x43] = { nn = { nn = "LD (nn),BC" } }, 599 | [0x44] = "NEG", 600 | [0x45] = "RETN", 601 | [0x46] = "IM 0", 602 | [0x47] = "LD I,A", 603 | [0x48] = "IN C,(C)", 604 | [0x49] = "OUT (C),C", 605 | [0x4a] = "ADC HL,BC", 606 | [0x4b] = { nn = { nn = "LD BC,(nn)" } }, 607 | [0x4d] = "RETI", 608 | [0x4f] = "LD R,A", 609 | [0x50] = "IN D,(C)", 610 | [0x51] = "OUT (C),D", 611 | [0x52] = "SBC HL,DE", 612 | [0x53] = { nn = { nn = "LD (nn),DE" } }, 613 | [0x56] = "IM 1", 614 | [0x57] = "LD A,I", 615 | [0x58] = "IN E,(C)", 616 | [0x59] = "OUT (C),E", 617 | [0x5a] = "ADC HL,DE", 618 | [0x5b] = { nn = { nn = "LD DE,(nn)" } }, 619 | [0x5e] = "IM 2", 620 | [0x5f] = "LD A,R", 621 | [0x60] = "IN H,(C)", 622 | [0x61] = "OUT (C),H", 623 | [0x62] = "SBC HL,HL", 624 | [0x67] = "RRD", 625 | [0x68] = "IN L,(C)", 626 | [0x69] = "OUT (C),L", 627 | [0x6a] = "ADC HL,HL", 628 | [0x6f] = "RLD", 629 | [0x70] = "IN F,(C)", 630 | [0x72] = "SBC HL,SP", 631 | [0x73] = { nn = { nn = "LD (nn),SP" } }, 632 | [0x78] = "IN A,(C)", 633 | [0x79] = "OUT (C),A", 634 | [0x7a] = "ADC HL,SP", 635 | [0x7b] = { nn = { nn = "LD SP,(nn)" } }, 636 | [0xa0] = "LDI", 637 | [0xa1] = "CPI", 638 | [0xa2] = "INI", 639 | [0xa3] = "OUTI", 640 | [0xa8] = "LDD", 641 | [0xa9] = "CPD", 642 | [0xaa] = "IND", 643 | [0xab] = "OUTD", 644 | [0xb0] = "LDIR", 645 | [0xb1] = "CPIR", 646 | [0xb2] = "INIR", 647 | [0xb3] = "OTIR", 648 | [0xb8] = "LDDR", 649 | [0xb9] = "CPDR", 650 | [0xba] = "INDR", 651 | [0xbb] = "OTDR", 652 | [0xc1] = "MULUB A,B", 653 | [0xc3] = "MULUW HL,BC", 654 | [0xc9] = "MULUB A,C", 655 | [0xd1] = "MULUB A,D", 656 | [0xd9] = "MULUB A,E", 657 | [0xe1] = "MULUB A,H", 658 | [0xe9] = "MULUB A,L", 659 | [0xf3] = "MULUW HL,SP", 660 | [0xf9] = "MULUB A,A" }, 661 | [0xee] = { n = "XOR n" }, 662 | [0xef] = "RST 28H", 663 | [0xf0] = "RET P", 664 | [0xf1] = "POP AF", 665 | [0xf2] = { nn = { nn = "JP P,nn" } }, 666 | [0xf3] = "DI", 667 | [0xf4] = { nn = { nn = "CALL P,nn" } }, 668 | [0xf5] = "PUSH AF", 669 | [0xf6] = { n = "OR n" }, 670 | [0xf7] = "RST 30H", 671 | [0xf8] = "RET M", 672 | [0xf9] = "LD SP,HL", 673 | [0xfa] = { nn = { nn = "JP M,nn" } }, 674 | [0xfb] = "EI", 675 | [0xfc] = { nn = { nn = "CALL M,nn" } }, 676 | [0xfd] = { 677 | [0x09] = "ADD IY,BC", 678 | [0x19] = "ADD IY,DE", 679 | [0x21] = { nn = { nn = "LD IY,nn" } }, 680 | [0x22] = { nn = { nn = "LD (nn),IY" } }, 681 | [0x23] = "INC IY", 682 | [0x24] = "INC IYh", 683 | [0x25] = "DEC IYh", 684 | [0x26] = { n = "LD IYh,n" }, 685 | [0x29] = "ADD IY,IY", 686 | [0x2a] = { nn = { nn = "LD IY,(nn)" } }, 687 | [0x2b] = "DEC IY", 688 | [0x2c] = "INC IYl", 689 | [0x2d] = "DEC IYl", 690 | [0x2e] = { n = "LD IYl,n" }, 691 | [0x34] = { o = "INC (IY+o)" }, 692 | [0x35] = { o = "DEC (IY+o)" }, 693 | [0x36] = { o = { n = "LD (IY+o),n" } }, 694 | [0x39] = "ADD IY,SP", 695 | [0x44] = "LD B,IYh", 696 | [0x45] = "LD B,IYl", 697 | [0x46] = { o = "LD B,(IY+o)" }, 698 | [0x4c] = "LD C,IYh", 699 | [0x4d] = "LD C,IYl", 700 | [0x4e] = { o = "LD C,(IY+o)" }, 701 | [0x54] = "LD D,IYh", 702 | [0x55] = "LD D,IYl", 703 | [0x56] = { o = "LD D,(IY+o)" }, 704 | [0x5c] = "LD E,IYh", 705 | [0x5d] = "LD E,IYl", 706 | [0x5e] = { o = "LD E,(IY+o)" }, 707 | [0x64] = "LD IYh,h", 708 | [0x65] = "LD IYh,l", 709 | [0x66] = { o = "LD H,(IY+o)" }, 710 | [0x6c] = "LD IYl,h", 711 | [0x6d] = "LD IYl,l", 712 | [0x6e] = { o = "LD L,(IY+o)" }, 713 | [0x70] = { o = "LD (IY+o),B" }, 714 | [0x71] = { o = "LD (IY+o),C" }, 715 | [0x72] = { o = "LD (IY+o),D" }, 716 | [0x73] = { o = "LD (IY+o),E" }, 717 | [0x74] = { o = "LD (IY+o),H" }, 718 | [0x75] = { o = "LD (IY+o),L" }, 719 | [0x77] = { o = "LD (IY+o),A" }, 720 | [0x7c] = "LD A,IYh", 721 | [0x7d] = "LD A,IYl", 722 | [0x7e] = { o = "LD A,(IY+o)" }, 723 | [0x84] = "ADD A,IYh", 724 | [0x85] = "ADD A,IYl", 725 | [0x86] = { o = "ADD A,(IY+o)" }, 726 | [0x8c] = "ADC A,IYh", 727 | [0x8d] = "ADC A,IYl", 728 | [0x8e] = { o = "ADC A,(IY+o)" }, 729 | [0x94] = "SUB IYh", 730 | [0x95] = "SUB IYl", 731 | [0x96] = { o = "SUB (IY+o)" }, 732 | [0x9c] = "SBC A,IYh", 733 | [0x9d] = "SBC A,IYl", 734 | [0x9e] = { o = "SBC A,(IY+o)" }, 735 | [0xa4] = "AND IYh", 736 | [0xa5] = "AND IYl", 737 | [0xa6] = { o = "AND (IY+o)" }, 738 | [0xac] = "XOR IYh", 739 | [0xad] = "XOR IYl", 740 | [0xae] = { o = "XOR (IY+o)" }, 741 | [0xb4] = "OR IYh", 742 | [0xb5] = "OR IYl", 743 | [0xb6] = { o = "OR (IY+o)" }, 744 | [0xbc] = "CP IYh", 745 | [0xbd] = "CP IYl", 746 | [0xbe] = { o = "CP (IY+o)" }, 747 | [0xcb] = { o = { 748 | [0x06] = "RLC (IY+o)", 749 | [0x0e] = "RRC (IY+o)", 750 | [0x16] = "RL (IY+o)", 751 | [0x1e] = "RR (IY+o)", 752 | [0x26] = "SLA (IY+o)", 753 | [0x2e] = "SRA (IY+o)", 754 | [0x3e] = "SRL (IY+o)", 755 | [0x46] = "BIT 0,(IY+o)", 756 | [0x4e] = "BIT 1,(IY+o)", 757 | [0x56] = "BIT 2,(IY+o)", 758 | [0x5e] = "BIT 3,(IY+o)", 759 | [0x66] = "BIT 4,(IY+o)", 760 | [0x6e] = "BIT 5,(IY+o)", 761 | [0x76] = "BIT 6,(IY+o)", 762 | [0x7e] = "BIT 7,(IY+o)", 763 | [0x86] = "RES 0,(IY+o)", 764 | [0x8e] = "RES 1,(IY+o)", 765 | [0x96] = "RES 2,(IY+o)", 766 | [0x9e] = "RES 3,(IY+o)", 767 | [0xa6] = "RES 4,(IY+o)", 768 | [0xae] = "RES 5,(IY+o)", 769 | [0xb6] = "RES 6,(IY+o)", 770 | [0xbe] = "RES 7,(IY+o)", 771 | [0xc6] = "SET 0,(IY+o)", 772 | [0xce] = "SET 1,(IY+o)", 773 | [0xd6] = "SET 2,(IY+o)", 774 | [0xde] = "SET 3,(IY+o)", 775 | [0xe6] = "SET 4,(IY+o)", 776 | [0xee] = "SET 5,(IY+o)", 777 | [0xf6] = "SET 6,(IY+o)", 778 | [0xfe] = "SET 7,(IY+o)" } }, 779 | [0xe1] = "POP IY", 780 | [0xe3] = "EX (SP),IY", 781 | [0xe5] = "PUSH IY", 782 | [0xe9] = "JP (IY)", 783 | [0xf9] = "LD SP,IY" }, 784 | [0xfe] = { n = "CP n" }, 785 | [0xff] = "RST 38H" } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ace-forth 2 | 3 | ace-forth is a Forth cross-compiler for Jupiter Ace. The main benefit of cross-compiling is that it allows editing the source code on host PC and compiling it to TAP file to be executed on a real Jupiter Ace or emulator. 4 | 5 | Features: 6 | 7 | - Compiles to Jupiter Ace compatible interpreted Forth bytecode (compact size) or Z80 machine code (speed!) 8 | - Supports most standard Forth words + many non-standard extras 9 | - Optimizations such as inlining, dead code elimination, tail-calls, byte-size literals, short branches... 10 | - Macros (immediate words executed at compile time) 11 | - Generates a TAP file which can be loaded into emulator or real Jupiter Ace 12 | 13 | 14 | ## Prerequisites 15 | 16 | You need a Lua 5.4 interpreter executable, which can be obtained from 17 | http://www.lua.org/download.html 18 | 19 | Precompiled Lua binaries for many platforms are also available: 20 | http://luabinaries.sourceforge.net/ 21 | 22 | A precompiled executable for macOS comes with the compiler in the 'tools' directory. 23 | 24 | If you are a Sublime Text user, you might also want to install the following Forth syntax plugin with ace-forth support: 25 | https://github.com/petrihakkinen/sublime-forth 26 | 27 | ## Usage 28 | 29 | compile.lua [options] ... 30 | 31 | Options: 32 | -o Sets output filename 33 | -l Write listing to file 34 | --mcode Compile to machine code 35 | --ignore-case Treat all word names as case insensitive 36 | --no-warn Disable all warnings 37 | --verbose Print information while compiling 38 | --main Sets name of main executable word (default 'main') 39 | --filename Sets the filename for tap header (default 'dict') 40 | 41 | Optimizations: 42 | --optimize Enable all optimizations 43 | --minimal-word-names Rename all words as '@', except main word 44 | --inline Inline words that are used only once 45 | --eliminate-unused-words Eliminate unused words when possible 46 | --small-literals Optimize byte-sized literals 47 | --tail-call Optimize tail calls (mcode only) 48 | --short-branches Use relative branches when possible (mcode only) 49 | 50 | On Windows which does not support shebangs you need to prefix the command line with path to the Lua interpreter. 51 | 52 | Examples: 53 | 54 | # Compile myprogram.f to optimized Forth bytecode 55 | ./compile.lua -o myprogram.tap --filename MYPROG --optimize myprogram.f 56 | 57 | # Compile aux.f and myprogram.f to optimized Z80 machine code 58 | ./compile.lua -o myprogram.tap --filename MYPROG --mcode --optimize aux.f myprogram.f 59 | 60 | 61 | ## Differences with Jupiter Ace Forth Interpreter 62 | 63 | - Word names are case sensitive by default. However, you can turn off case sensitivity using the `--ignore-case` option. When in case sensitive mode, standard word names should be written in lower case (e.g. `dup` instead of `DUP`). 64 | 65 | - All word definitions must be terminated with `;`. This includes words defined with `:`, `:M`, `CREATE`, `CODE` and `BYTES`. 66 | 67 | - Floating point literals are not currently supported. 68 | 69 | - Words `DEFINER`, `DOES>` and `RUNS>` are not supported. However, you can create macros (also known as "immediate words") using `:M`. 70 | 71 | - `WHILE` and `REPEAT` are not currently supported. 72 | 73 | - Some commonly used words have been shortened: `CONSTANT` -> `CONST`, `LITERAL` -> `LIT`. 74 | 75 | 76 | ## News Words and Features 77 | 78 | The compiler supports many extras not found on Jupiter Ace's Forth implementation. Some of the features are unique to this compiler. The new features are too numerous to list here, refer to the index at the end of this document. Some highlights: 79 | 80 | - New control flow words `GOTO` and `LABEL`. 81 | 82 | - Infinite loops using `BEGIN` and `AGAIN` words are supported (you can jump out of them using `EXIT` or `GOTO`). 83 | 84 | - New interpreter words: `[IF]`, `[ELSE]`, `[THEN]`, and `[DEFINED]` for conditionally compiling code (e.g. for stripping debug code). 85 | 86 | - Line comments using `\` word are supported. 87 | 88 | - New variable defining word `BYTE`, which works like `VARIABLE` but defines byte sized variables (remember to use `C@` and `C!` to access them). 89 | 90 | - New defining word `BYTES` which can be used to conveniently embed byte data. For example: 91 | bytes pow2 1 2 4 8 16 32 64 128 ; 92 | 93 | - New defining word `:M` for creating macros (also known as immediate words). `:M name ;` is equivalent to `: name ; IMMEDIATE` in other Forth dialects. Before compiling a word, ace-forth needs to know whether the word should be compiled to Forth bytecode or Z80 machine code. 94 | 95 | - 8-bit unsigned arithmetic and comparison words: `C*` `C=` `C<` `C>`. These are much faster than 16-bit equivalents when compiled to machine code. 96 | 97 | - Many new words have been added: `NIP` `2DUP` `2DROP` `2OVER` `R@` `2*` `2/` `INC` `DEC` `.S` `HEX` `[HEX]` `CODE` `POSTPONE` ... 98 | 99 | 100 | ## Machine Code Compilation 101 | 102 | Using the command line option `--mcode`, the program is compiled into Z80 machine code instead of interpreted Forth bytecode. Machine code is typically 3 to 4 times faster, sometimes even an order of magnitude or more faster than interpreted Forth (see benchmarks below). The downsides are that machine code programs take about 40% to 50% more space and are not relocatable. Therefore, when loading a machine code compiled program, there should be no other user defined words defined previously, so that the loading address is the same where the code was originally compiled to. 103 | 104 | Some Forth words cannot be compiled into machine code and their execution will back to the Forth interpreter. Therefore, the following words should be avoided in performance critical parts: 105 | 106 | FNEGATE F+ F- F* F/ F. UFLOAT INT D+ D< DNEGATE U/MOD */ MOD */MOD /MOD U. U* U< 107 | . # #S #> <# SIGN HOLD CLS SLOW FAST INVIS VIS ABORT QUIT LINE WORD NUMBER CONVERT 108 | RETYPE QUERY PLOT BEEP EXECUTE CALL 109 | 110 | The words `*` and `/`, when compiled to machine code, have special optimizations for power of two values: if the value preceding `*` or `/` is a literal, positive and a power of two (1, 2, 4, 8, 16, ... 16384), the computation is performed by bit shifting. 111 | 112 | For 8-bit multiplication where both operands fits into 8 bits (the result is 16 bit), it is recommended to use the new word `C*` (it is more than twice as fast as `*` when compiled to machine code). 113 | 114 | Similarly, there is a new word `C=` for comparing the low bytes of two numbers for equality. It can be used in place or `=` when the numbers to compare are known to be bytes. 115 | 116 | The following table contains some benchmark results comparing the speed of machine code compiled Forth vs. interpreted Forth running on the Jupiter Ace. "Speed up" is how many times faster the machine code version runs. 117 | 118 | | Benchmark | Speed up | Notes | 119 | | ---------------- | --------- | -------------------------- | 120 | | Stack ops | 3.1 | DUP DROP | 121 | | OVER | 11 | | 122 | | Arithmetic | 4.8 | + - | 123 | | DO LOOP | 7.8 | | 124 | | 1+ | 29 | | 125 | | 2* | 23 | | 126 | | 2/ | 309 | | 127 | | * | 2.8 | 16-bit multiply | 128 | | C* | 7.1 | 8-bit multiply | 129 | 130 | 131 | ## Optimizations 132 | 133 | The compiler supports various optimizations which are controlled by the following command line options: 134 | 135 | `--minimal-word-names`: Renames all words as "@" in the resulting TAP file (except the main word). This can reduce the size of a larger program considerably. 136 | 137 | `--inline`: inline words that are used only once or have been explicitly marked with `INLINE` word. Inlining reduces compiled program size and also makes the code run faster for every word that can be inlined. Note that word definitions containing EXIT words cannot be inlined. In the rare case where you want to disable inlining of a word you can append `NOINLINE` just after its colon definition. This can also be used to silence the "word has side exits" warning. 138 | 139 | `--eliminate-unused-words`: Automatically remove words that are not used anywhere in your program. When a word is eliminated, all symbols inside word definition are ignored. More specifically, the compiler skips symbols until the word end marker `;` is found. 140 | 141 | `--small-literals`: Reduce the size of byte sized literals. Normally every literal takes 4 bytes in compiled code. With this option byte sized literals can be encoded in 3 bytes. This option does nothing when compiling to machine code. 142 | 143 | `--tail-call`: (machine code only) In the generated machine code, replace CALL followed by RET instruction with JP instruction when possible. 144 | 145 | `--short-branches`: (machine code only) Optimize IF and ELSE to use relative branches instead of jumping to absolute address when possible. 146 | 147 | `--optimize`: Enables all of the above optimizations. 148 | 149 | 150 | ## Word Index 151 | 152 | The following letters are used to denote values on the stack: 153 | 154 | - `n` number (16-bit signed integer) 155 | - `d` double length number (32-bit signed integer) occupying two stack slots 156 | - `f` floating point number occupying two stack slots 157 | - `flag` a boolean flag with possible values 1 (representing true) and 0 (representing false) 158 | - `addr` numeric address in the memory (where compiled words and variables go) 159 | 160 | ### Stack Manipulation 161 | 162 | | Word | Stack | Description | 163 | | ---------- | ------------------------------- | ------------------------------------------------------------------- | 164 | | DUP | ( n - n n ) | Duplicate topmost stack element | 165 | | ?DUP | ( n - n n ) | Duplicate topmost stack element unless it is zero | 166 | | DROP | ( n - ) | Remove topmost stack element | 167 | | NIP | ( n1 n2 - n2 ) | Remove the second topmost stack element | 168 | | OVER | ( n1 n2 - n1 n2 n1 ) | Duplicate the second topmost stack element | 169 | | SWAP | ( n1 n2 - n2 n1 ) | Swap two elements | 170 | | ROT | ( n1 n2 n3 - n2 n3 n1 ) | Rotate three topmost stack elements | 171 | | PICK | ( n - n ) | Duplicate the Nth topmost stack element | 172 | | ROLL | ( n - ) | Extract the Nth element from stack, moving it to the top | 173 | | 2DUP | ( n1 n2 - n1 n2 n1 n2 ) | Duplicate two topmost stack elements | 174 | | 2DROP | ( n n - ) | Remove two topmost stack elements | 175 | | 2OVER | ( n1 n2 n n - n1 n2 n n n1 n2 ) | Duplicates two elements on the stack | 176 | | >R | S: ( n - ) R: ( - n ) | Move value from data stack to return stack | 177 | | R> | S: ( - n ) R: ( n - ) | Move value from return stack to data stack | 178 | | R@ | S: ( - n ) R: ( n - n ) | Copy value from return stack to data stack (without removing it) | 179 | 180 | ### Arithmetic 181 | 182 | | Word | Stack | Description | 183 | | ---------- | ------------------ | ------------------------------------------------------------------- | 184 | | + | ( n n - n ) | Add two integers | 185 | | - | ( n n - n ) | Subtract two integers | 186 | | * | ( n n - n ) | Multiply two integers | 187 | | C* | ( n n - n ) | Multiply two unsigned 8-bit integers (the result is 16 bit) | 188 | | / | ( n1 n2 - n ) | Divide n1 by n2 | 189 | | 1+ | ( n - n ) | Increment value by 1 | 190 | | 1- | ( n - n ) | Decrement value by 1 | 191 | | 2+ | ( n - n ) | Increment value by 2 | 192 | | 2- | ( n - n ) | Decrement value by 2 | 193 | | 2* | ( n - n ) | Multiply value by 2 | 194 | | 2/ | ( n - n ) | Divide value by 2 | 195 | | NEGATE | ( n - n ) | Negate value | 196 | | ABS | ( n - n ) | Compute the absolute value | 197 | | MIN | ( n1 n2 - n ) | Compute the minimum of two integers | 198 | | MAX | ( n1 n2 - n ) | Compute the maximum of two integers | 199 | | AND | ( n n - n ) | Compute the bitwise and of two integers | 200 | | OR | ( n n - n ) | Compute the bitwise or of two integers | 201 | | XOR | ( n n - n ) | Compute the bitwise exlusive or of two integers | 202 | | F+ | ( f f - f ) | Add two floating point numbers | 203 | | F- | ( f f - f ) | Subtract two floating point numbers | 204 | | F* | ( f f - f ) | Multiply two floating point numbers | 205 | | F/ | ( f f - f ) | Divide two floating point numbers | 206 | | F. | ( f - ) | Print floating point number | 207 | | FNEGATE | ( f - f ) | Negate floating point number | 208 | | D+ | ( d d - d ) | Add two double length integers | 209 | | DNEGATE | ( d - d ) | Negate double length integer | 210 | | U/MOD | | | 211 | | */ | | | 212 | | MOD | | | 213 | | */MOD | | | 214 | | /MOD | | | 215 | | U* | | | 216 | | UFLOAT | | | 217 | | INT | | | 218 | 219 | 220 | ### Comparison 221 | 222 | | Word | Stack | Description | 223 | | ---------- | ------------------ | ------------------------------------------------------------------- | 224 | | = | ( n1 n2 - flag ) | Compare n1 = n2 and set flag accordingly | 225 | | < | ( n1 n2 - flag ) | Compare n1 < n2 and set flag accordingly | 226 | | > | ( n1 n2 - flag ) | Compare n1 > n2 and set flag accordingly | 227 | | C= | ( n1 n2 - flag ) | Compare the low byte of n1 and n2 for equality | 228 | | C< | ( n1 n2 - flag ) | 8-bit unsigned version of < | 229 | | C> | ( n1 n2 - flag ) | 8-bit unsigned version of > | 230 | | D< | ( d1 d1 - flag ) | Compute less than of two double length integers | 231 | | U< | ( n1 n2 - flag ) | Compute less than of two integers, interpreting them as unsigned numbers | 232 | | 0= | ( n - flag ) | Compare n = 0 and set flag accordingly | 233 | | 0< | ( n - flag ) | Compare n < 0 and set flag accordingly | 234 | | 0> | ( n - flag ) | Compare n > 0 and set flag accordingly | 235 | | NOT | ( n - flag ) | Same as 0=, used to denote inversion of a flag | 236 | 237 | 238 | ### Memory 239 | 240 | | Word | Stack | Description | 241 | | ---------- | ------------------ | ----------------------------------------------------------------- | 242 | | @ | ( addr - n ) | Fetch 16-bit value from address | 243 | | ! | ( n addr - ) | Store 16-bit value at address | 244 | | C@ | ( addr - n ) | Fetch 8-bit value from address | 245 | | C! | ( n addr - ) | Store 8-bit value at address | 246 | | INC | ( addr - ) | Add one to byte at address | 247 | | DEC | ( addr - ) | Subtract one from byte at address | 248 | 249 | 250 | ### Compilation 251 | 252 | | Word | Stack | Description | 253 | | ----------------- | ------------------ | ---------------------------------------------------------------------- | 254 | | : \ | ( - ) | Start compiling a new word with name \ ("colon definition") | 255 | | :M \ | ( - ) | Start compiling a new macro with name \ | 256 | | ; | ( - ) | Mark the end of word definition and stop compiling | 257 | | , | ( n - ) | Enclose 16-bit value to next free location in dictionary | 258 | | C, | ( n - ) | Enclose 8-bit value to next free location in dictionary | 259 | | " \ " | ( - ) | Enclose \ as bytes into the dictionary | 260 | | ( | ( - ) | Block comment; skip characters until next ) | 261 | | \ | ( - ) | Line comment; skip characters until end of line | 262 | | [ | ( - ) | Change from compile to interpreter state | 263 | | ] | ( - ) | Change from interpreter to compile state | 264 | | CREATE \ | ( - ) | Add new (empty) word to dictionary with name \ | 265 | | CODE \ | ( - ) | Define a new word with machine code defined as following bytes of data | 266 | | CONST \ | ( n - ) | Capture number from stack to a new word with name \ | 267 | | VARIABLE \ | ( n - ) | Create new 16-bit variable with name \ and with initial value n | 268 | | BYTE \ | ( n - ) | Create new 8-bit variable with name \ and with initial value n | 269 | | BYTES \ | ( n - ) | Start compiling a byte array. All bytes pushed to compiler stack are enclosed to the dictionary until ; | 270 | | ALLOT | ( n - ) | Allocate space for n bytes from the dictionary | 271 | | ASCII \ | ( - (n) ) | Emit literal containing the ASCII code of the following symbol | 272 | | [HEX] \ | ( - (n) ) | Parse the next symbol as hexadecimal number, regardless of numeric base | 273 | | HERE | ( - n ) | Push the address of the next free location in the dictionary | 274 | | LIT | ( n - ) | Emit value from data stack to the dictionary | 275 | | POSTPONE \ | ( - ) | (Macros) Emit code for invoking a word \ into the dictionary | 276 | | INLINE | ( - ) | Mark previous colon definition to be inlined | 277 | | NOINLINE | ( - ) | Prevent automatic inlining of previous colon definition | 278 | | [IF] | ( flag - ) | Pop a value from compiler stack. If zero, skip until next [ELSE] or [THEN]. | 279 | | [ELSE] | ( - ) | See [IF] | 280 | | [THEN] | ( - ) | See [THEN] | 281 | | [DEFINED] \ | ( - flag ) | If word named \ is defined, push 1 to compiler stack. Otherwise push 0. | 282 | | FIND \ | ( - addr ) | Push the compilation address of a word to compiler stack | 283 | 284 | 285 | ### Runtime 286 | 287 | | Word | Stack | Description | 288 | | ----------------- | ------------------ | ---------------------------------------------------------------------- | 289 | | FAST | ( - ) | Turn off stack underflow checks | 290 | | SLOW | ( - ) | Turn on stack underflow checks | 291 | | DI | ( - ) | Disable interrupts | 292 | | EI | ( - ) | Enable interrupts | 293 | | CALL | ( addr - ) | Call a machine code routine. The routine must end with JP (IY) (compiling to Forth bytecode) or RET (compiling to machine code) | 294 | | EXECUTE | ( addr - ) | Execute a word given its compilation address | 295 | | INVIS | ( - ) | Turn off printing of executed words | 296 | | VIS | ( - ) | Turn on printing of executed words | 297 | | ABORT | ( - ) | | 298 | | QUIT | ( - ) | | 299 | 300 | 301 | ### Constants and Variables 302 | 303 | | Word | Stack | Description | 304 | | --------------- | ------------------ | ------------------------------------------------------------------- | 305 | | TRUE | ( - flag ) | Push one | 306 | | FALSE | ( - flag ) | Push zero | 307 | | BL | ( - n ) | Push 32, the ASCII code of space character | 308 | | PAD | ( - n ) | Push the address of PAD (2701 in hex) | 309 | | BASE | ( - addr ) | Push the address of built-in numeric base variable | 310 | | DECIMAL | ( - ) | Switch numeric base to decimal (shortcut for 10 BASE C!) | 311 | | HEX | ( - ) | Switch numeric base to hexadecimal (shortcut for 16 BASE C!) | 312 | 313 | Note: names of constants (i.e. TRUE, FALSE, BL and PAD) are always written in upper-case! 314 | 315 | 316 | ### Control Flow 317 | 318 | | Word | Stack | Description | 319 | | -------------- | ------------------ | --------------------------------------------------------------------------------- | 320 | | IF | ( flag - ) | If flag is zero, skip to next ELSE or THEN, otherwise continue to next statement | 321 | | ELSE | ( - ) | See IF | 322 | | THEN | ( - ) | See IF | 323 | | BEGIN | ( - ) | Mark the beginning of indefinite or until loop | 324 | | UNTIL | ( flag - ) | If flag is zero, jump to previous BEGIN, otherwise continue to next statement | 325 | | AGAIN | ( - ) | Jump (unconditionally) to previous BEGIN | 326 | | DO | ( n1 n2 - ) | Initialize do loop, n1 is the limit value, n2 is the initial value of counter | 327 | | LOOP | ( - ) | Increment loop counter by 1, jump to previous DO if counter has not reached limit | 328 | | +LOOP | ( n - ) | Add n to counter, jump to previous DO if counter has not reached limit | 329 | | REPEAT | ( - ) | Not supported currently! | 330 | | WHILE | ( - ) | Not supported currently! | 331 | | EXIT | ( - ) | Exit immediately from current word (make sure return stack is balanced!) | 332 | | I | ( - n ) | Push the loop counter of innermost loop | 333 | | I' | ( - n ) | Push the limit value of innermost loop | 334 | | J | ( - n ) | Push the loop counter of second innermost loop | 335 | | LEAVE | ( - ) | Set the loop counter to limit for innermost loop | 336 | | LABEL \ | ( - ) | Mark the current position in dictionary with a label | 337 | | GOTO \ | ( - ) | Jump to a label defined in the current word definition | 338 | 339 | 340 | ### Input and Output 341 | 342 | | Word | Stack | Description | 343 | | ---------- | ------------------ | ----------------------------------------------------------------- | 344 | | . | ( n - ) | Print value using current numeric base followed by space | 345 | | ." | ( - ) | Print the following characters until terminating " | 346 | | .S | ( - ) | Print the contents of the data stack | 347 | | CR | ( - ) | Print newline character | 348 | | SPACE | ( - ) | Print space character | 349 | | SPACES | ( n - ) | Print n space characters | 350 | | EMIT | ( n - ) | Print character, where n is the ASCII code | 351 | | IN | ( port - n ) | Read a 8-bit value from I/O port | 352 | | OUT | ( n port - ) | Write a 8-bit value to I/O port | 353 | | AT | ( y x - ) | Move the cursor to column x on row y | 354 | | TYPE | ( addr n -- ) | Print a string stored in memory | 355 | | PLOT | ( x y n - ) | Plot a pixel at x, y with mode n (0=unplot, 1=plot, 2=move, 3=change) | 356 | | INKEY | ( - n ) | Read current pressed key (0 = not pressed) | 357 | | CLS | ( - ) | Clear the screen | 358 | | BEEP | ( m n - ) | Play sounds (8*m = period in us, n = time in ms) | 359 | | # | | | 360 | | #S | | | 361 | | U. | | | 362 | | #> | | | 363 | | <# | | | 364 | | SIGN | | | 365 | | HOLD | | | 366 | | LINE | | | 367 | | WORD | | | 368 | | NUMBER | | | 369 | | RETYPE | | | 370 | | QUERY | | | 371 | | CONVERT | | | 372 | -------------------------------------------------------------------------------- /compile.lua: -------------------------------------------------------------------------------- 1 | #!tools/lua 2 | 3 | -- Ace Forth cross compiler 4 | -- Copyright (c) 2021 Petri Häkkinen 5 | -- See LICENSE file for details 6 | -- 7 | -- Each user defined word has the following structure: 8 | -- Name array of bytes, the last character has high bit set which marks the end of string 9 | -- Word length short, the length of the word in bytes excluding the name 10 | -- Link pointer to name length field of previous defined word 11 | -- Name length byte, length of name in bytes 12 | -- Code field machine code address, called when the word is executed (for example, DO_COLON or DO_PARAM) 13 | -- Parameter field optional area for storing word specific data (compiled forth code for DO_COLON words) 14 | -- 15 | -- The first user defined word is placed at 3C51 in RAM. 16 | -- The function create_word() below adds a new word header to the output dictionary. 17 | 18 | local mcode = require "mcode" 19 | 20 | local DO_COLON = 0x0EC3 -- DoColon routine in ROM, the value of code field for user defined words 21 | local DO_PARAM = 0x0FF0 -- Routine which pushes the parameter field to stack, code field value for variables 22 | local DO_CONSTANT = 0x0FF5 -- Routine which pushes short from parameter field to stack, code field value for constants 23 | local FORTH_END = 0x04B6 -- Internal word, returns from current word 24 | local PUSH_BYTE = 0x104B -- Internal word, pushes the following literal byte to stack 25 | local PUSH_WORD = 0x1011 -- Internal word, pushes the following literal word to stack 26 | local PUSH_ZERO = 0x0688 -- Internal word, push zero stack 27 | local CBRANCH = 0x1283 -- Internal word, conditional branch '?branch', the following word is the branch offset 28 | local BRANCH = 0x1276 -- Internal word, unconditional branch 'branch', the following word is the branch offset 29 | local PRINT = 0x1396 -- Internal word, prints a string, string length word + data follows 30 | local DO = 0x1323 -- Internal word, runtime part of DO (pushes 2 values from data stack to return stack) 31 | local LOOP = 0x1332 -- Internal word, runtime part of LOOP, the following word is the branch offset 32 | local PLUS_LOOP = 0x133C -- Internal word, runtime part of +LOOP, the following word is the branch offset 33 | local POSTPONE = 0x0001 -- Internal word, hacky way to postpone compilation of words, not actual ROM code! 34 | 35 | local start_address = 0x3c51 36 | local v_current = 0x3C4C 37 | local v_context = 0x3C4C 38 | local v_voclink = 0x3C4F 39 | 40 | -- parse args 41 | local args = {...} 42 | 43 | local input_files = {} 44 | local output_file 45 | 46 | opts = { main_word = "main", tap_filename = "dict" } 47 | 48 | function fatal_error(msg) 49 | io.stderr:write(msg, "\n") 50 | os.exit(-1) 51 | end 52 | 53 | do 54 | local i = 1 55 | while i <= #args do 56 | local arg = args[i] 57 | if string.match(arg, "^%-") then 58 | if arg == "--minimal-word-names" then 59 | opts.minimal_word_names = true 60 | elseif arg == "--inline" then 61 | opts.inline_words = true 62 | elseif arg == "--eliminate-unused-words" then 63 | opts.eliminate_unused_words = true 64 | elseif arg == "--small-literals" then 65 | opts.small_literals = true 66 | elseif arg == "--tail-call" then 67 | opts.tail_call = true 68 | elseif arg == "--short-branches" then 69 | opts.short_branches = true 70 | elseif arg == "--optimize" then 71 | opts.inline_words = true 72 | opts.minimal_word_names = true 73 | opts.eliminate_unused_words = true 74 | opts.small_literals = true 75 | opts.tail_call = true 76 | opts.short_branches = true 77 | elseif arg == "--verbose" then 78 | opts.verbose = true 79 | elseif arg == "--ignore-case" then 80 | opts.ignore_case = true 81 | elseif arg == "--no-warn" then 82 | opts.no_warn = true 83 | elseif arg == "--mcode" then 84 | opts.mcode = true 85 | elseif arg == "--main" then 86 | i = i + 1 87 | opts.main_word = args[i] 88 | if opts.main_word == nil then fatal_error("Word name must follow --main") end 89 | elseif arg == "--filename" then 90 | i = i + 1 91 | opts.tap_filename = args[i] 92 | if opts.tap_filename == nil then fatal_error("TAP filename must follow --filename") end 93 | if #opts.tap_filename > 10 then fatal_error("TAP filename too long (max 10 chars)") end 94 | elseif arg == "-o" then 95 | i = i + 1 96 | output_file = args[i] 97 | if output_file == nil then fatal_error("Output filename must follow -o") end 98 | elseif arg == "-l" then 99 | i = i + 1 100 | opts.listing_file = args[i] 101 | if opts.listing_file == nil then fatal_error("Listing filename must follow -l") end 102 | else 103 | fatal_error("Invalid option: " .. arg) 104 | end 105 | else 106 | input_files[#input_files + 1] = arg 107 | end 108 | i = i + 1 109 | end 110 | end 111 | 112 | if #input_files == 0 then 113 | print("Usage: compile.lua [options] ...") 114 | print("\nOptions:") 115 | print(" -o Sets output filename") 116 | print(" -l Write listing to file") 117 | print(" --mcode Compile to machine code") 118 | print(" --ignore-case Treat all word names as case insensitive") 119 | print(" --no-warn Disable all warnings") 120 | print(" --verbose Print information while compiling") 121 | print(" --main Sets name of main executable word (default 'main')") 122 | print(" --filename Sets the filename for tap header (default 'dict')") 123 | print("\nOptimizations:") 124 | print(" --optimize Enable all optimizations") 125 | print(" --minimal-word-names Rename all words as '@', except main word") 126 | print(" --inline Inline words that are used only once") 127 | print(" --eliminate-unused-words Eliminate unused words when possible") 128 | print(" --small-literals Optimize byte-sized literals") 129 | print(" --tail-call Optimize tail calls (mcode only)") 130 | print(" --short-branches Use relative branches when possible (mcode only)") 131 | os.exit(-1) 132 | end 133 | 134 | function verbose(...) 135 | if opts.verbose then 136 | print(string.format(...)) 137 | end 138 | end 139 | 140 | local pass = 1 141 | 142 | eliminate_words = {} 143 | inline_words = {} 144 | 145 | ::restart:: 146 | 147 | verbose("Pass %d", pass) 148 | 149 | local input -- source code as string 150 | local input_file -- current input filename 151 | local cur_pos -- current position in input 152 | local cur_line -- current line in input 153 | local compile_mode = false -- interpret or compile mode? 154 | local inside_definition = false -- are we inside CODE or CREATE definition? 155 | local prev_compile_mode -- previous value of compile_mode (before [ was invoked) 156 | local stack = {} -- the compiler stack 157 | local mem = { [0] = 10 } -- compiler memory 158 | local output_pos = start_address -- current output position in the dictionary 159 | local next_immediate_word = 1 -- next free address for compiled immediate words 160 | local labels = {} -- label -> address for current word 161 | local gotos = {} -- address to be patched -> label for current word 162 | local last_word -- name of last user defined word 163 | local word_counts = {} -- how many times each word is used in generated code? 164 | local word_flags = {} -- bitfield of F_* flags 165 | local list_headers = {} -- listing headers (addr -> string) 166 | local list_lines = {} -- listing lines (addr -> string) 167 | local list_comments = {} -- listing comments (addr -> string) 168 | local dont_allow_redefining = false -- if set, do not allow redefining word behaviors (hack for library words) 169 | local warnings = {} -- array of strings 170 | 171 | -- address of prev word's name length field in RAM 172 | -- initial value: address of FORTH in RAM 173 | local prev_word_link = 0x3C49 174 | 175 | -- should we run another pass after this one? 176 | more_work = false 177 | 178 | rom_words = { 179 | FORTH = 0x3c4a, UFLOAT = 0x1d59, INT = 0x1d22, FNEGATE = 0x1d0f, ["F/"] = 0x1c7b, ["F*"] = 0x1c4b, 180 | ["F+"] = 0x1bb1, ["F-"] = 0x1ba4, LOAD = 0x198a, BVERIFY = 0x1979, VERIFY = 0x1967, BLOAD = 0x1954, 181 | BSAVE = 0x1944, SAVE = 0x1934, LIST = 0x1670, EDIT = 0x165e, FORGET = 0x1638, REDEFINE = 0x13fd, 182 | EXIT = 0x13f0, [".\""] = 0x1388, ["("] = 0x1361, ["["] = 0x13d5, ["+LOOP"] = 0x12d0, LOOP = 0x12bd, 183 | DO = 0x12ab, UNTIL = 0x1263, REPEAT = 0x124c, BEGIN = 0x121a, THEN = 0x1207, ELSE = 0x11ec, 184 | WHILE = 0x11d5, IF = 0x11c0, ["]"] = 0x13e1, LEAVE = 0x1316, J = 0x1302, ["I'"] = 0x12f7, I = 0x12e9, 185 | DEFINITIONS = 0x11ab, VOCABULARY = 0x117d, IMMEDIATE = 0x1160, ["RUNS>"] = 0x1125, ["DOES>"] = 0x10b4, 186 | COMPILER = 0x10f5, CALL = 0x10a7, DEFINER = 0x1074, ASCII = 0x1028, LITERAL = 0x1006, CONSTANT = 0x0fe2, 187 | VARIABLE = 0x0fcf, ALLOT = 0x0f76, ["C,"] = 0x0f5f, [","] = 0x0f4e, CREATE = 0x0ed0, [":"] = 0x0eaf, 188 | DECIMAL = 0x0ea3, MIN = 0x0e87, MAX = 0x0e75, XOR = 0x0e60, AND = 0x0e4b, OR = 0x0e36, ["2-"] = 0x0e29, 189 | ["1-"] = 0x0e1f, ["2+"] = 0x0e13, ["1+"] = 0x0e09, ["D+"] = 0x0dee, ["-"] = 0x0de1, ["+"] = 0x0dd2, 190 | DNEGATE = 0x0dba, NEGATE = 0x0da9, ["U/MOD"] = 0x0d8c, ["*/"] = 0x0d7a, ["*"] = 0x0d6d, MOD = 0x0d61, 191 | ["/"] = 0x0d51, ["*/MOD"] = 0x0d31, ["/MOD"] = 0x0d00, ["U*"] = 0x0ca8, ["D<"] = 0x0c83, ["U<"] = 0x0c72, 192 | ["<"] = 0x0c65, [">"] = 0x0c56, ["="] = 0x0c4a, ["0>"] = 0x0c3a, ["0<"] = 0x0c2e, ["0="] = 0x0c1a, 193 | ABS = 0x0c0d, OUT = 0x0bfd, IN = 0x0beb, INKEY = 0x0bdb, BEEP = 0x0b98, PLOT = 0x0b4a, AT = 0x0b19, 194 | ["F."] = 0x0aaf, EMIT = 0x0aa3, CR = 0x0a95, SPACES = 0x0a83, SPACE = 0x0a73, HOLD = 0x0a5c, CLS = 0x0a1d, 195 | ["#"] = 0x09f7, ["#S"] = 0x09e1, ["U."] = 0x09d0, ["."] = 0x09b3, SIGN = 0x0a4a, ["#>"] = 0x099c, 196 | ["<#"] = 0x098d, TYPE = 0x096e, ROLL = 0x0933, PICK = 0x0925, OVER = 0x0912, ROT = 0x08ff, ["?DUP"] = 0x08ee, 197 | ["R>"] = 0x08df, [">R"] = 0x08d2, ["!"] = 0x08c1, ["@"] = 0x08b3, ["C!"] = 0x08a5, ["C@"] = 0x0896, 198 | SWAP = 0x0885, DROP = 0x0879, DUP = 0x086b, SLOW = 0x0846, FAST = 0x0837, INVIS = 0x0828, VIS = 0x0818, 199 | CONVERT = 0x078a, NUMBER = 0x06a9, EXECUTE = 0x069a, FIND = 0x063d, VLIST = 0x062d, WORD = 0x05ab, 200 | RETYPE = 0x0578, QUERY = 0x058c, LINE = 0x0506, [";"] = 0x04a1, PAD = 0x0499, BASE = 0x048a, 201 | CURRENT = 0x0480, CONTEXT = 0x0473, HERE = 0x0460, ABORT = 0x00ab, QUIT = 0x0099 202 | } 203 | 204 | -- word flags 205 | F_NO_INLINE = 0x01 -- words that should never we inlined (explicitly marked as 'noinline' or cannot be inlined) 206 | F_NO_ELIMINATE = 0x02 -- words that should not be eliminated even when they are not used 207 | F_HAS_SIDE_EXITS = 0x04 -- words that have side-exits and cannot there be inlined 208 | F_INVISIBLE = 0x08 -- word cannot be seen from user written code 209 | F_MACRO = 0x10 -- word is a macro (to be executed immediately at compile time) 210 | F_FORCE_INLINE = 0x20 -- word has been marked with 'inline' 211 | 212 | -- starting addresses of user defined words 213 | local word_start_addresses = {} 214 | 215 | -- compilation addresses of user defined words 216 | compilation_addresses = {} 217 | 218 | -- inverse mapping of compilation addresses back to word names (for executing compiled code) 219 | local compilation_addr_to_name = {} 220 | 221 | -- Return stack for executing compile time code 222 | local return_stack = {} 223 | 224 | local function r_push(x) 225 | return_stack[#return_stack + 1] = x 226 | end 227 | 228 | local function r_pop() 229 | local x = return_stack[#return_stack] 230 | comp_assert(x, "return stack underflow") 231 | return_stack[#return_stack] = nil 232 | return x 233 | end 234 | 235 | function r_peek(idx) 236 | local v = return_stack[#return_stack + idx + 1] 237 | comp_assert(v, "return stack underflow") 238 | return v 239 | end 240 | 241 | -- Separate stack for control flow constructs 242 | local control_flow_stack = {} 243 | 244 | function cf_push(x) 245 | control_flow_stack[#control_flow_stack + 1] = x 246 | end 247 | 248 | function cf_pop(x) 249 | local x = control_flow_stack[#control_flow_stack] 250 | comp_assert(x ~= nil, "control flow stack underflow") 251 | control_flow_stack[#control_flow_stack] = nil 252 | return x 253 | end 254 | 255 | -- Checks that the control flow stack is empty at the end of word definition, 256 | -- and if not, raises an appropriate error. 257 | function check_control_flow_stack() 258 | local v = control_flow_stack[#control_flow_stack] 259 | 260 | if v == "if" then 261 | comp_error("IF without matching THEN") 262 | elseif v == "begin" then 263 | comp_error("BEGIN without matching UNTIL or AGAIN") 264 | elseif v == "do" then 265 | comp_error("DO without matching LOOP") 266 | elseif v then 267 | comp_error("unbalanced control flow constructs") 268 | end 269 | end 270 | 271 | function printf(...) 272 | print(string.format(...)) 273 | end 274 | 275 | function comp_error(...) 276 | printf("%s:%d: %s", input_file, cur_line, string.format(...)) 277 | os.exit(-1) 278 | end 279 | 280 | function comp_assert(expr, message) 281 | if not expr then 282 | comp_error("%s", message) 283 | end 284 | return expr 285 | end 286 | 287 | function warn(...) 288 | if not opts.no_warn then 289 | warnings[#warnings + 1] = string.format("%s:%d: Warning! %s", input_file, cur_line, string.format(...)) 290 | end 291 | end 292 | 293 | function push(v) 294 | stack[#stack + 1] = v 295 | end 296 | 297 | function push_bool(v) 298 | stack[#stack + 1] = v and 1 or 0 299 | end 300 | 301 | function pop() 302 | local v = stack[#stack] 303 | comp_assert(v, "compiler stack underflow") 304 | stack[#stack] = nil 305 | return v 306 | end 307 | 308 | function pop2() 309 | local a = pop() 310 | local b = pop() 311 | return b, a 312 | end 313 | 314 | function peek(idx) 315 | local v = stack[#stack + idx + 1] 316 | comp_assert(v, "compiler stack underflow") 317 | return v 318 | end 319 | 320 | function remove(idx) 321 | comp_assert(stack[#stack + idx + 1], "compiler stack underflow") 322 | table.remove(stack, #stack + idx + 1) 323 | end 324 | 325 | function peek_char() 326 | local char = input:sub(cur_pos, cur_pos) 327 | if #char == 0 then char = nil end 328 | return char 329 | end 330 | 331 | -- Returns next character from input. Returns nil at end of input. 332 | function next_char() 333 | local char = peek_char() 334 | if char == '\n' then cur_line = cur_line + 1 end 335 | cur_pos = cur_pos + 1 336 | return char 337 | end 338 | 339 | -- Returns the next whitespace delimited symbol from input. Returns nil at end of input. 340 | function next_symbol() 341 | -- skip leading whitespaces 342 | while true do 343 | local char = peek_char() 344 | if char == ' ' or char == '\n' or char == '\t' then 345 | next_char() 346 | else 347 | break 348 | end 349 | end 350 | 351 | -- end of file reached? 352 | if peek_char() == nil then return nil end 353 | 354 | -- scan for next whitespace character 355 | local start = cur_pos 356 | while true do 357 | local char = next_char() 358 | if char == ' ' or char == '\n' or char == '\t' or char == nil then 359 | return input:sub(start, cur_pos - 2) 360 | end 361 | end 362 | end 363 | 364 | -- Returns the next symbol up until next occurrence of given delimiter. 365 | -- Returns nil at the end of input. 366 | function next_symbol_with_delimiter(delimiter) 367 | local start = cur_pos 368 | while true do 369 | local char = next_char() 370 | if char == delimiter then 371 | return input:sub(start, cur_pos - 2) 372 | elseif char == nil then 373 | return nil 374 | end 375 | end 376 | end 377 | 378 | function next_word(allow_eof) 379 | local word = next_symbol() 380 | if word == nil and not allow_eof then comp_error("unexpected end of file") end 381 | if opts.ignore_case and word then word = string.upper(word) end 382 | return word 383 | end 384 | 385 | function next_number() 386 | local sym = next_symbol() 387 | if sym == nil then comp_error("unexpected end of file") end 388 | local n = parse_number(sym) 389 | if n == nil then comp_error("expected number, got '%s'", sym) end 390 | return n 391 | end 392 | 393 | -- Reads symbols until end marker has been reached, processing comments. 394 | -- That is, end markers inside comments are ignored. 395 | function skip_until(end_marker) 396 | while true do 397 | local sym = next_word() 398 | if sym == end_marker then 399 | break 400 | elseif sym == "\\" then 401 | next_symbol_with_delimiter('\n') 402 | elseif sym == "(" then 403 | next_symbol_with_delimiter(')') 404 | end 405 | end 406 | end 407 | 408 | -- Returns a string that unique identifies the current parsing location (file and position within it). 409 | function parse_pos() 410 | return input_file .. "@" .. cur_pos 411 | end 412 | 413 | -- Checks whether two word names are the same, taking case sensitivity option into account. 414 | function match_word(name1, name2) 415 | if opts.ignore_case then 416 | return string.upper(name1) == string.upper(name2) 417 | else 418 | return name1 == name2 419 | end 420 | end 421 | 422 | function read_byte(address) 423 | comp_assert(address < 65536, "address out of range") 424 | return mem[address] or 0 425 | end 426 | 427 | function read_short(address, x) 428 | comp_assert(address < 65536 - 1, "address out of range") 429 | return (mem[address] or 0) | ((mem[address + 1] or 0) << 8) 430 | end 431 | 432 | function write_byte(address, x) 433 | comp_assert(address < 65536 - 1, "address out of range") 434 | if x < 0 then x = x + 256 end 435 | mem[address] = x & 0xff 436 | end 437 | 438 | function write_short(address, x) 439 | comp_assert(address < 65536 - 1, "address out of range") 440 | if x < 0 then x = x + 65536 end 441 | mem[address] = x & 0xff 442 | mem[address + 1] = x >> 8 443 | end 444 | 445 | function emit_byte(x) 446 | comp_assert(output_pos < 65536, "out of space") 447 | mem[output_pos] = x 448 | output_pos = output_pos + 1 449 | end 450 | 451 | function emit_short(x) 452 | if x < 0 then x = x + 65536 end 453 | emit_byte(x & 0xff) 454 | emit_byte(x >> 8) 455 | end 456 | 457 | function emit_string(str) 458 | for i = 1, #str do 459 | emit_byte(str:byte(i)) 460 | end 461 | end 462 | 463 | function emit_literal(n) 464 | if compile_mode == "mcode" then 465 | if n >= -32768 and n < 65536 then 466 | if n < 0 then n = 65536 + n end 467 | mcode.emit_literal(n) 468 | else 469 | comp_error("literal out of range") 470 | end 471 | else 472 | list_line("lit %d", n) 473 | 474 | if n >= 0 and n < 256 and opts.small_literals then 475 | emit_short(PUSH_BYTE) 476 | emit_byte(n) 477 | elseif n >= -32768 and n < 65536 then 478 | if n < 0 then n = 65536 + n end 479 | emit_short(PUSH_WORD) 480 | emit_short(n) 481 | else 482 | comp_error("literal out of range") 483 | end 484 | end 485 | end 486 | 487 | -- Erases last N emitted bytes from output dictionary. 488 | function erase(n) 489 | for i = here() - n, here() - 1 do 490 | mem[i] = 0 491 | end 492 | output_pos = output_pos - n 493 | end 494 | 495 | -- Returns the address of the next free byte in dictionary in Ace's RAM. 496 | function here() 497 | return output_pos 498 | end 499 | 500 | -- Enters interpreter state. Usually called by ; 501 | function interpreter_state() 502 | compile_mode = false 503 | end 504 | 505 | -- Returns the current numeric base used by the compiler. 506 | function base() 507 | return mem[0] 508 | end 509 | 510 | -- Returns string representation of a number in current numeric base. 511 | function format_number(n) 512 | local base = mem[0] 513 | comp_assert(base >= 2 and base <= 36, "invalid numeric base") 514 | 515 | local digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 516 | local result = "" 517 | 518 | if n == 0 then return "0" end 519 | 520 | local neg = n < 0 521 | if neg then n = math.abs(n) end 522 | 523 | while n > 0 do 524 | local d = n % base 525 | result = digits:sub(d + 1, d + 1) .. result 526 | n = n // base 527 | end 528 | 529 | if neg then result = "-" ..result end 530 | 531 | return result 532 | end 533 | 534 | -- Parses number from a string using current numeric base. 535 | function parse_number(str) 536 | local base = mem[0] 537 | comp_assert(base >= 2 and base <= 36, "invalid numeric base") 538 | return tonumber(str, base) 539 | end 540 | 541 | -- Fills the word length field of previous word in dictionary. 542 | function update_word_length() 543 | if prev_word_link >= start_address then 544 | -- prev_word_link points to the name length field of the last defined word 545 | -- word length field is always 4 bytes before this 546 | local word_length_addr = prev_word_link - 4 547 | local length = here() - prev_word_link + 4 548 | write_short(word_length_addr, length) 549 | end 550 | end 551 | 552 | -- Inserts a header for a new word to output dictionary. The new word has a header but with empty parameter field. 553 | -- Its word length is also zero. The word length field is updated to correct value when the next word is added. 554 | -- This means that the last word will have zero in the word length field. This is how the ROM code works too 555 | -- (and its documented in Jupiter Ace Forth Programming, page 121). 556 | function create_word(code_field, name, flags) 557 | flags = flags or 0 558 | 559 | comp_assert(not inside_definition, "; expected") 560 | 561 | word_start_addresses[name] = here() 562 | word_flags[name] = flags 563 | word_counts[name] = word_counts[name] or 0 564 | 565 | list_header(name) 566 | 567 | if not opts.mcode then 568 | update_word_length() 569 | 570 | list_comment("word header") 571 | 572 | -- write name to dictionary, with terminator bit set for the last character 573 | local name = name 574 | if opts.minimal_word_names and name ~= opts.main_word then name = "@" end 575 | name = string.upper(name) 576 | emit_string(name:sub(1, #name - 1) .. string.char(name:byte(#name) | 128)) 577 | 578 | emit_short(0) -- placeholder word length 579 | emit_short(prev_word_link) 580 | 581 | prev_word_link = here() 582 | emit_byte(#name) 583 | end 584 | 585 | -- compilation addresses work differently with interpreted Forth and machine code: 586 | -- interpreter: compilation address points to code field of the word 587 | -- machine code: compilation address points directly to the start of machine code 588 | local compilation_addr = here() 589 | 590 | if not opts.mcode then 591 | emit_short(code_field) -- code field 592 | end 593 | 594 | -- remember compilation addresses for FIND 595 | compilation_addresses[name] = compilation_addr 596 | 597 | -- add word to compile dictionary so that other words can refer to it when compiling 598 | if (flags & F_INVISIBLE) == 0 then 599 | compile_dict[name] = function() 600 | word_counts[name] = word_counts[name] + 1 601 | list_line(name) 602 | emit_short(compilation_addr) 603 | end 604 | end 605 | 606 | return name 607 | end 608 | 609 | function mark_used(name) 610 | word_counts[name] = word_counts[name] + 1 611 | end 612 | 613 | function last_word_name() 614 | return last_word 615 | end 616 | 617 | function set_word_flag(name, flag) 618 | word_flags[name] = word_flags[name] | flag 619 | end 620 | 621 | -- Erases previously compiled word from dictionary. 622 | -- Returns the contents of the parameter field of the erased word. 623 | function erase_previous_word() 624 | local name = last_word 625 | 626 | local start_addr = word_start_addresses[name] 627 | assert(start_addr, "could not determine starting address of previous word") 628 | 629 | local compilation_addr = compilation_addresses[name] 630 | assert(compilation_addr, "could not determine compilation address of previous word") 631 | 632 | -- fix prev word link 633 | if not opts.mcode then 634 | prev_word_link = read_short(compilation_addr - 3) 635 | end 636 | 637 | local code_start = compilation_addr 638 | if not opts.mcode then code_start = code_start + 2 end 639 | 640 | -- store old code & listing (skip code field) 641 | local code = {} 642 | local list = {} 643 | local comments = {} 644 | for i = code_start, here() - 1 do 645 | code[#code + 1] = mem[i] 646 | list[i - code_start + 1] = list_lines[i] 647 | comments[i - code_start + 1] = list_comments[i] 648 | end 649 | 650 | for i = start_addr, here() - 1 do 651 | mem[i] = 0 652 | list_lines[i] = nil 653 | list_comments[i] = nil 654 | end 655 | 656 | word_start_addresses[name] = nil 657 | compilation_addresses[name] = nil 658 | 659 | output_pos = start_addr 660 | 661 | return code, list, comments, start_addr 662 | end 663 | 664 | -- Execute user defined word at compile time. 665 | function execute(pc) 666 | local function fetch_byte() 667 | local x = mem[pc] 668 | pc = pc + 1 669 | return x 670 | end 671 | 672 | local function fetch_short() 673 | local x = read_short(pc) 674 | pc = pc + 2 675 | return x 676 | end 677 | 678 | local function fetch_signed() 679 | local x = fetch_short() 680 | if x > 32767 then x = x - 65536 end 681 | return x 682 | end 683 | 684 | while true do 685 | local instr = fetch_short() 686 | local name = compilation_addr_to_name[instr] 687 | if name then 688 | local func = interpret_dict[name] 689 | if func == nil then 690 | comp_error("could not determine address of %s when executing compiled code", name) 691 | end 692 | func() 693 | elseif instr == FORTH_END then 694 | break 695 | elseif instr == PUSH_BYTE then 696 | push(fetch_byte()) 697 | elseif instr == PUSH_WORD then 698 | push(fetch_short()) 699 | elseif instr == PUSH_ZERO then 700 | push(0) 701 | elseif instr == CBRANCH then 702 | local offset = fetch_signed() - 1 703 | if pop() == 0 then 704 | pc = pc + offset 705 | end 706 | elseif instr == BRANCH then 707 | pc = pc + fetch_signed() - 1 708 | elseif instr == DO then 709 | local limit, counter = pop2() 710 | r_push(limit) 711 | r_push(counter) 712 | elseif instr == LOOP or instr == PLUS_LOOP then 713 | local offset = fetch_signed() - 1 714 | local counter = r_pop() 715 | local limit = r_pop() 716 | local step = instr == LOOP and 1 or pop() 717 | counter = counter + step 718 | if (step >= 0 and counter < limit) or (step < 0 and counter > limit) then 719 | r_push(limit) 720 | r_push(counter) 721 | pc = pc + offset 722 | end 723 | elseif instr == PRINT then 724 | local len = fetch_short() 725 | for i = 1, len do 726 | io.write(string.char(fetch_byte())) 727 | end 728 | elseif instr == POSTPONE then 729 | local len = fetch_short() 730 | local name = "" 731 | for i = 1, len do 732 | name = name .. string.char(fetch_byte()) 733 | end 734 | 735 | local func 736 | if compile_mode == "mcode" then 737 | func = mcode_dict[name] 738 | else 739 | func = compile_dict[name] 740 | end 741 | 742 | if func == nil then 743 | comp_error("POSTPONE failed -- could not find compile behavior for word '%s'", name) 744 | end 745 | func() 746 | else 747 | comp_error("unknown compilation address $%04x encountered when executing compiled code", instr) 748 | end 749 | end 750 | end 751 | 752 | function execute_string(src, filename) 753 | -- initialize parser state 754 | input = src 755 | input_file = filename 756 | cur_pos = 1 757 | cur_line = 1 758 | 759 | -- execute input 760 | while true do 761 | local sym = next_word(true) 762 | if sym == nil then break end 763 | --printf("symbol [%s]", sym) 764 | 765 | if compile_mode then 766 | -- compile mode 767 | local func 768 | if compile_mode == "mcode" then 769 | func = mcode_dict[sym] 770 | else 771 | func = compile_dict[sym] 772 | end 773 | if func == nil then 774 | -- is it a number? 775 | local n = parse_number(sym) 776 | if n == nil then comp_error("undefined word '%s'", sym) end 777 | emit_literal(n) 778 | else 779 | func() 780 | end 781 | else 782 | -- interpret mode 783 | local func = interpret_dict[sym] 784 | if func == nil then 785 | -- is it a number? 786 | local n = parse_number(sym) 787 | if n == nil then comp_error("undefined word '%s'", sym) end 788 | push(n) 789 | else 790 | func() 791 | end 792 | end 793 | end 794 | end 795 | 796 | -- Listings 797 | 798 | function list_header(...) 799 | if opts.listing_file then 800 | list_headers[here()] = string.format(...) 801 | end 802 | end 803 | 804 | function list_line(...) 805 | if opts.listing_file then 806 | list_lines[here()] = string.format(...) 807 | end 808 | end 809 | 810 | function list_comment(...) 811 | if opts.listing_file then 812 | list_comments[here()] = string.format(...) 813 | end 814 | end 815 | 816 | function list_comment_append(addr, ...) 817 | if opts.listing_file then 818 | list_comments[addr] = (list_comments[addr] or "") .. string.format(...) 819 | end 820 | end 821 | 822 | -- Patches hex literal (jump address) in already emitted listing line. 823 | function list_patch(addr, pattern, replacement) 824 | if opts.listing_file then 825 | local line = list_lines[addr] 826 | assert(line, "invalid listing line") 827 | line = line:gsub(pattern, replacement) 828 | list_lines[addr] = line 829 | end 830 | end 831 | 832 | -- Erases all listing lines in given address range. 833 | function list_erase(start_addr, end_addr) 834 | if opts.listing_file then 835 | for i = start_addr, end_addr do 836 | -- not clearing headers on purpose, because erase_literal() at the start of word would erase the header... 837 | --list_headers[i] = nil 838 | list_lines[i] = nil 839 | list_comments[i] = nil 840 | end 841 | end 842 | end 843 | 844 | function write_listing(filename) 845 | local file = io.open(filename, "wb") 846 | local addr = start_address 847 | local len = 0 848 | 849 | local function align(x) 850 | local spaces = x - len 851 | if spaces > 0 then 852 | file:write(string.rep(" ", spaces)) 853 | len = len + spaces 854 | end 855 | end 856 | 857 | while addr < here() do 858 | if list_headers[addr] then 859 | if addr > start_address then file:write("\n") end 860 | file:write(list_headers[addr], ":\n") 861 | end 862 | 863 | -- find end address of line 864 | local e = here() 865 | for i = addr + 1, here() do 866 | if list_headers[i] or list_lines[i] or list_comments[i] then 867 | e = i 868 | break 869 | end 870 | end 871 | assert(e > addr) 872 | 873 | -- add line breaks for long sections of data 874 | e = math.min(e, addr + 16) 875 | 876 | file:write(string.format("%04x", addr)) 877 | len = 4 878 | 879 | -- emit bytes 880 | for i = addr, e - 1 do 881 | file:write(string.format(" %02x", read_byte(i))) 882 | len = len + 3 883 | end 884 | 885 | if list_lines[addr] then 886 | align(20) 887 | file:write(" ", list_lines[addr]) 888 | len = len + #list_lines[addr] + 1 889 | end 890 | 891 | if list_comments[addr] then 892 | align(40) 893 | file:write(" ; ", list_comments[addr]) 894 | end 895 | 896 | file:write("\n") 897 | addr = e 898 | end 899 | 900 | file:close() 901 | end 902 | 903 | function patch_forth_jump(instr_addr, jump_to_addr) 904 | write_short(instr_addr + 2, jump_to_addr - instr_addr - 3) 905 | list_patch(instr_addr, "%$%x+", string.format("$%04x", jump_to_addr)) 906 | end 907 | 908 | interpret_dict = { 909 | create = function() 910 | local name = next_word() 911 | if not eliminate_words[name] then 912 | create_word(DO_PARAM, name, F_NO_INLINE) 913 | inside_definition = true 914 | 915 | -- make it possible to refer to the word from machine code 916 | local addr = here() 917 | mcode_dict[name] = function() 918 | mcode.emit_literal(addr, name) 919 | word_counts[name] = word_counts[name] + 1 920 | end 921 | else 922 | skip_until(';') 923 | end 924 | end, 925 | [':'] = function() 926 | local name = next_word() 927 | if not eliminate_words[name] then 928 | local flags = 0 929 | if compile_dict[name] and dont_allow_redefining then flags = F_INVISIBLE end 930 | 931 | last_word = create_word(DO_COLON, name, flags) 932 | 933 | compile_mode = true 934 | 935 | if opts.mcode then 936 | -- load top of stack to DE if this is the machine code entry point from Forth 937 | if name == opts.main_word then 938 | list_line("rst 24") 939 | list_comment("adjust stack for machine code") 940 | emit_byte(0xc7 + 24) 941 | end 942 | 943 | compile_mode = "mcode" 944 | 945 | if mcode_dict[name] == nil or not dont_allow_redefining then 946 | mcode_dict[name] = function() 947 | mcode.call_mcode(name) 948 | end 949 | end 950 | end 951 | else 952 | skip_until(';') 953 | end 954 | end, 955 | [':m'] = function() 956 | -- compile macro 957 | last_word = create_word(0, next_word(), F_MACRO | F_NO_INLINE | F_NO_ELIMINATE) 958 | compile_mode = true 959 | 960 | local addr = next_immediate_word 961 | interpret_dict[last_word] = function() execute(addr) end 962 | compile_dict[last_word] = function() execute(addr) end 963 | mcode_dict[last_word] = function() execute(addr) end 964 | end, 965 | [';'] = function() 966 | -- marks end of CREATE, CODE or BYTES definition 967 | comp_assert(inside_definition, "unexpected ;") 968 | 969 | if inside_definition == "bytes" then 970 | -- find start of bytes block 971 | local start 972 | for i = #stack, 1, -1 do 973 | if stack[i] == 'bytes' then 974 | start = i 975 | break 976 | end 977 | end 978 | 979 | comp_assert(start, "could not find start of BYTES data (unbalanced compiler stack?)") 980 | 981 | for i = start + 1, #stack do 982 | emit_byte(stack[i]) 983 | stack[i] = nil 984 | end 985 | 986 | stack[start] = nil 987 | end 988 | 989 | inside_definition = false 990 | end, 991 | noinline = function() 992 | -- forbid inlining previous word 993 | comp_assert(last_word, "invalid use of NOINLINE") 994 | word_flags[last_word] = word_flags[last_word] | F_NO_INLINE 995 | end, 996 | inline = function() 997 | -- force inline previous word 998 | comp_assert(last_word, "invalid use of INLINE") 999 | comp_assert((word_flags[last_word] & F_HAS_SIDE_EXITS) == 0, "Cannot inline word with side exits") 1000 | comp_assert((word_flags[last_word] & F_NO_INLINE) == 0, string.format("Word '%s' cannot be inlined", last_word)) 1001 | word_flags[last_word] = word_flags[last_word] | F_FORCE_INLINE 1002 | end, 1003 | code = function() 1004 | local name = next_word() 1005 | if not eliminate_words[name] then 1006 | create_word(0, name, F_NO_INLINE) 1007 | inside_definition = true 1008 | 1009 | -- patch codefield 1010 | if not opts.mcode then 1011 | write_short(here() - 2, here()) 1012 | end 1013 | 1014 | -- make it possible to call CODE words from machine code 1015 | if mcode_dict[name] == nil or not dont_allow_redefining then 1016 | mcode_dict[name] = function() 1017 | mcode.call_code(name) 1018 | end 1019 | end 1020 | else 1021 | skip_until(';') 1022 | end 1023 | end, 1024 | bytes = function() -- emit bytes, terminated by ; symbol 1025 | local name = next_word() 1026 | if not eliminate_words[name] then 1027 | create_word(DO_PARAM, name, F_NO_INLINE) 1028 | local addr = here() 1029 | inside_definition = "bytes" 1030 | 1031 | -- make it possible to refer to variable from machine code 1032 | mcode_dict[name] = function() 1033 | mcode.emit_literal(addr, name) 1034 | mark_used(name) 1035 | end 1036 | 1037 | push('bytes') 1038 | else 1039 | skip_until(';') 1040 | end 1041 | end, 1042 | byte = function() -- byte-sized variable 1043 | local name = create_word(DO_PARAM, next_word(), F_NO_ELIMINATE | F_NO_INLINE) 1044 | local value = pop() 1045 | comp_assert(value >= 0 and value < 256, "byte variable out of range") 1046 | local addr = here() 1047 | emit_byte(value) 1048 | 1049 | -- make it possible to refer to variable from machine code 1050 | mcode_dict[name] = function() 1051 | mcode.emit_literal(addr, name) 1052 | end 1053 | end, 1054 | variable = function() 1055 | local name = create_word(DO_PARAM, next_word(), F_NO_ELIMINATE | F_NO_INLINE) 1056 | local addr = here() 1057 | emit_short(pop()) -- write variable value to dictionary 1058 | 1059 | -- make it possible to refer to variable from machine code 1060 | mcode_dict[name] = function() 1061 | mcode.emit_literal(addr, name) 1062 | end 1063 | end, 1064 | const = function() 1065 | local name = next_word() 1066 | local value = pop() 1067 | 1068 | comp_assert(not inside_definition, "; expected") 1069 | 1070 | -- add compile time word which emits the constant as literal 1071 | compile_dict[name] = function() 1072 | list_comment(name) 1073 | emit_literal(value) 1074 | end 1075 | 1076 | -- add mcode behavior for the word which emits the constant as machine code literal 1077 | mcode_dict[name] = function() 1078 | list_comment(name) 1079 | emit_literal(value) 1080 | end 1081 | 1082 | -- add word to interpreter dictionary so that the constant can be used at compile time 1083 | interpret_dict[name] = function() 1084 | push(value) 1085 | end 1086 | end, 1087 | allot = function() 1088 | local count = pop() 1089 | for i = 1, count do 1090 | emit_byte(0) 1091 | end 1092 | end, 1093 | find = function() 1094 | local name = next_word() 1095 | local addr = compilation_addresses[name] 1096 | if addr == nil then comp_error("undefined word %s", name) end 1097 | push(addr) 1098 | end, 1099 | [','] = function() 1100 | emit_short(pop() & 0xffff) 1101 | end, 1102 | ['c,'] = function() 1103 | emit_byte(pop() & 0xff) 1104 | end, 1105 | ['"'] = function() 1106 | local str = next_symbol_with_delimiter('"') 1107 | for i = 1, #str do 1108 | emit_byte(str:byte(i)) 1109 | end 1110 | end, 1111 | ['('] = function() 1112 | -- skip block comment 1113 | comp_assert(next_symbol_with_delimiter(')'), "unfinished comment") 1114 | end, 1115 | ['\\'] = function() 1116 | -- skip line comment 1117 | next_symbol_with_delimiter('\n') 1118 | end, 1119 | [']'] = function() 1120 | comp_assert(previous_compile_mode ~= nil, "] without matching [") 1121 | compile_mode = previous_compile_mode 1122 | previous_compile_mode = nil 1123 | end, 1124 | ['."'] = function() 1125 | local str = next_symbol_with_delimiter("\"") 1126 | io.write(str) 1127 | end, 1128 | dup = function() push(peek(-1)) end, 1129 | over = function() push(peek(-2)) end, 1130 | drop = function() pop() end, 1131 | nip = function() local a = pop(); pop(); push(a) end, 1132 | ['2dup'] = function() push(peek(-2)); push(peek(-2)) end, 1133 | ['2drop'] = function() pop2() end, 1134 | ['2over'] = function() push(peek(-4)); push(peek(-4)) end, 1135 | rot = function() push(peek(-3)); remove(-4) end, 1136 | swap = function() local a, b = pop2(); push(b); push(a) end, 1137 | pick = function() push(peek(-pop())) end, 1138 | roll = function() local i = pop(); push(peek(-i)); remove(-i - 1) end, 1139 | ['>r'] = function() r_push(pop()) end, 1140 | ['r>'] = function() push(r_pop()) end, 1141 | ['r@'] = function() push(r_peek(-1)) end, 1142 | ['+'] = function() local a, b = pop2(); push(a + b) end, 1143 | ['-'] = function() local a, b = pop2(); push(a - b) end, 1144 | ['*'] = function() local a, b = pop2(); push(a * b) end, 1145 | ['/'] = function() local a, b = pop2(); push(a // b) end, 1146 | ['*/'] = function() local c = pop(); local a, b = pop2(); push(a * b // c) end, 1147 | ['<'] = function() local a, b = pop2(); push_bool(a < b) end, 1148 | ['>'] = function() local a, b = pop2(); push_bool(a > b) end, 1149 | ['='] = function() local a, b = pop2(); push_bool(a == b) end, 1150 | ['0<'] = function() push_bool(pop() < 0) end, 1151 | ['0>'] = function() push_bool(pop() > 0) end, 1152 | ['0='] = function() push_bool(pop() == 0) end, 1153 | ['1+'] = function() push(pop() + 1) end, 1154 | ['1-'] = function() push(pop() - 1) end, 1155 | ['2+'] = function() push(pop() + 2) end, 1156 | ['2-'] = function() push(pop() - 2) end, 1157 | ['2*'] = function() push(pop() * 2) end, 1158 | ['2/'] = function() push(pop() // 2) end, 1159 | ['.'] = function() io.write(format_number(pop()), " ") end, 1160 | negate = function() push(-pop()) end, 1161 | xor = function() local a, b = pop2(); push(a ~ b) end, 1162 | ['and'] = function() local a, b = pop2(); push(a & b) end, 1163 | ['or'] = function() local a, b = pop2(); push(a | b) end, 1164 | ['not'] = function() push_bool(pop() == 0) end, 1165 | abs = function() push(math.abs(pop())) end, 1166 | min = function() local a, b = pop2(); push(math.min(a, b)) end, 1167 | max = function() local a, b = pop2(); push(math.max(a, b)) end, 1168 | cr = function() io.write("\n") end, 1169 | emit = function() io.write(string.char(pop())) end, 1170 | space = function() io.write(" ") end, 1171 | spaces = function() io.write(string.rep(" ", pop())) end, 1172 | here = function() push(here()) end, 1173 | ascii = function() 1174 | local char = next_symbol() 1175 | if #char ~= 1 then comp_error("invalid symbol following ASCII") end 1176 | push(char:byte(1)) 1177 | end, 1178 | ['[hex]'] = function() 1179 | local sym = next_symbol() 1180 | local n = comp_assert(tonumber(sym, 16), "invalid symbol following [HEX]") 1181 | push(n) 1182 | end, 1183 | ['c!'] = function() 1184 | local n, addr = pop2() 1185 | if n < 0 then n = n + 256 end 1186 | comp_assert(addr >= 0 and addr < 65536, "invalid address") 1187 | comp_assert(n >= 0 and n < 256, "value out of range") 1188 | mem[addr] = n 1189 | end, 1190 | ['c@'] = function() 1191 | local addr = pop() 1192 | comp_assert(addr >= 0 and addr < 65536, "invalid address") 1193 | push(mem[addr] or 0) 1194 | end, 1195 | ['!'] = function() 1196 | local n, addr = pop2() 1197 | if n < 0 then n = n + 256 end 1198 | comp_assert(addr >= 0 and addr < 65536, "invalid address") 1199 | comp_assert(n >= 0 and n < 65536, "value out of range") 1200 | write_short(addr, n) 1201 | end, 1202 | ['@'] = function() 1203 | local addr = pop() 1204 | comp_assert(addr >= 0 and addr < 65536, "invalid address") 1205 | push(read_short(addr) or 0) 1206 | end, 1207 | base = function() push(0) end, 1208 | hex = function() mem[0] = 16 end, 1209 | decimal = function() mem[0] = 10 end, 1210 | ['[if]'] = function() 1211 | if pop() == 0 then 1212 | -- skip until next [ELSE] or [THEN] 1213 | local depth = 0 1214 | while true do 1215 | local sym = next_word() 1216 | if match_word(sym, '[if]') then 1217 | depth = depth + 1 1218 | elseif match_word(sym, '[else]') and depth == 0 then 1219 | break 1220 | elseif match_word(sym, '[then]') then 1221 | if depth == 0 then break end 1222 | depth = depth - 1 1223 | end 1224 | end 1225 | end 1226 | end, 1227 | ['[else]'] = function() 1228 | -- skip until matching [THEN] 1229 | local depth = 0 1230 | while true do 1231 | local sym = next_word() 1232 | if match_word(sym, '[if]') then 1233 | depth = depth + 1 1234 | elseif match_word(sym, '[then]') then 1235 | if depth == 0 then break end 1236 | depth = depth - 1 1237 | end 1238 | end 1239 | end, 1240 | ['[then]'] = function() end, 1241 | ['[defined]'] = function() 1242 | push(compile_dict[next_word()] and 255 or 0) 1243 | end, 1244 | i = function() 1245 | push(r_peek(-1)) 1246 | end, 1247 | ['.s'] = function() 1248 | for i = 1, #stack do 1249 | io.write(format_number(stack[i]), " ") 1250 | end 1251 | end, 1252 | } 1253 | 1254 | compile_dict = { 1255 | [':'] = function() 1256 | comp_error("invalid :") 1257 | end, 1258 | [';'] = function() 1259 | list_line("forth-end") 1260 | emit_short(FORTH_END) 1261 | compile_mode = false 1262 | 1263 | check_control_flow_stack() 1264 | 1265 | -- patch gotos 1266 | for patch_loc, label in pairs(gotos) do 1267 | local target_addr = labels[label] 1268 | if target_addr == nil then comp_error("undefined label '%s'", label) end 1269 | patch_forth_jump(patch_loc, target_addr) 1270 | end 1271 | labels = {} 1272 | gotos = {} 1273 | 1274 | -- inlining 1275 | if inline_words[last_word] then 1276 | local name = last_word 1277 | local code, list, comments = erase_previous_word() 1278 | 1279 | -- when the inlined word is compiled, we emit its code 1280 | compile_dict[name] = function() 1281 | -- skip ret at the end 1282 | list_comment("inlined %s", name) 1283 | for i = 1, #code - 2 do 1284 | if list[i] then list_line("%s", list[i]) end 1285 | if comments[i] and i > 1 then list_comment("%s", comments[i]) end 1286 | emit_byte(code[i]) 1287 | end 1288 | end 1289 | end 1290 | 1291 | -- finish macro 1292 | if (word_flags[last_word] & F_MACRO) ~= 0 then 1293 | local code = erase_previous_word() 1294 | 1295 | -- store code in compiler memory 1296 | for _, byte in ipairs(code) do 1297 | mem[next_immediate_word] = byte 1298 | next_immediate_word = next_immediate_word + 1 1299 | end 1300 | end 1301 | end, 1302 | ['['] = function() 1303 | -- temporarily fall back to the interpreter 1304 | previous_compile_mode = compile_mode 1305 | compile_mode = false 1306 | end, 1307 | ['."'] = function() 1308 | local str = next_symbol_with_delimiter('"') 1309 | list_line(' ." %s"', str) 1310 | emit_short(PRINT) 1311 | emit_short(#str) 1312 | emit_string(str) 1313 | end, 1314 | ['if'] = function() 1315 | -- emit conditional branch 1316 | list_line("?branch $0000") 1317 | cf_push(here()) 1318 | cf_push('if') 1319 | emit_short(CBRANCH) 1320 | emit_short(0) -- placeholder branch offset 1321 | end, 1322 | ['else'] = function() 1323 | comp_assert(cf_pop() == 'if', "ELSE without matching IF") 1324 | local where = cf_pop() 1325 | -- emit jump to THEN 1326 | list_line("branch $0000") 1327 | cf_push(here()) 1328 | cf_push('if') 1329 | emit_short(BRANCH) 1330 | emit_short(0) -- placeholder branch offset 1331 | -- patch ?branch at IF 1332 | patch_forth_jump(where, here()) 1333 | end, 1334 | ['then']= function() 1335 | -- patch ?branch at IF 1336 | comp_assert(cf_pop() == 'if', "THEN without matching IF") 1337 | local where = cf_pop() 1338 | patch_forth_jump(where, here()) 1339 | end, 1340 | begin = function() 1341 | cf_push(here()) 1342 | cf_push('begin') 1343 | end, 1344 | ['until'] = function() 1345 | comp_assert(cf_pop() == 'begin', "UNTIL without matching BEGIN") 1346 | local target = cf_pop() 1347 | list_line("?branch $%04x", target) 1348 | emit_short(CBRANCH) 1349 | emit_short(target - here() - 1) 1350 | end, 1351 | again = function() 1352 | comp_assert(cf_pop() == 'begin', "AGAIN without matching BEGIN") 1353 | local target = cf_pop() 1354 | list_line("branch $%04x", target) 1355 | emit_short(BRANCH) 1356 | emit_short(target - here() - 1) 1357 | end, 1358 | ['do'] = function() 1359 | list_line("do") 1360 | emit_short(DO) 1361 | cf_push(here()) 1362 | cf_push('do') 1363 | end, 1364 | loop = function() 1365 | comp_assert(cf_pop() == 'do', "LOOP without matching DO") 1366 | local target = cf_pop() 1367 | list_line("loop $%04x", target) 1368 | emit_short(LOOP) 1369 | emit_short(target - here() - 1) 1370 | end, 1371 | ['+loop'] = function() 1372 | comp_assert(cf_pop() == 'do', "+LOOP without matching DO") 1373 | local target = cf_pop() 1374 | list_line("+loop $%04x", target) 1375 | emit_short(PLUS_LOOP) 1376 | emit_short(target - here() - 1) 1377 | end, 1378 | ['while'] = function() comp_error("WHILE not implemented") end, 1379 | ['repeat'] = function() comp_error("REPEAT not implemented") end, 1380 | ['goto'] = function() 1381 | local label = next_symbol() 1382 | list_line("branch $0000", label) 1383 | gotos[here()] = label 1384 | emit_short(BRANCH) 1385 | emit_short(0) -- place holder branch offset 1386 | end, 1387 | label = function() 1388 | local label = next_symbol() 1389 | labels[label] = here() 1390 | end, 1391 | exit = function() 1392 | list_line("exit") 1393 | emit_short(rom_words.EXIT) 1394 | word_flags[last_word] = word_flags[last_word] | F_HAS_SIDE_EXITS 1395 | end, 1396 | ascii = function() 1397 | local char = next_symbol() 1398 | if #char ~= 1 then comp_error("invalid symbol following ASCII") end 1399 | emit_literal(char:byte(1)) 1400 | end, 1401 | ['[hex]'] = function() 1402 | local sym = next_symbol() 1403 | local n = comp_assert(tonumber(sym, 16), "invalid symbol following [HEX]") 1404 | emit_literal(n) 1405 | end, 1406 | lit = function() emit_literal(pop()) end, 1407 | postpone = function() 1408 | local name = next_word() 1409 | if compile_dict[name] == nil then comp_error("undefined word %s", name) end 1410 | list_line("postpone") 1411 | emit_short(POSTPONE) 1412 | list_comment("%s", name) 1413 | emit_short(#name) 1414 | emit_string(name) 1415 | if word_counts[name] then mark_used(name) end 1416 | end, 1417 | ['r@'] = function() 1418 | -- R@ is alias for I 1419 | list_line("r@") 1420 | emit_short(rom_words.I) 1421 | end, 1422 | ['not'] = function() 1423 | -- NOT is alias for 0= 1424 | list_line("not") 1425 | emit_short(rom_words['0=']) 1426 | end, 1427 | } 1428 | 1429 | mcode_dict = mcode.get_dict() 1430 | 1431 | -- the following words have identical interpreter, compile and mcode behaviors 1432 | for _, name in ipairs{ "(", "\\", "[if]", "[else]", "[then]", "[defined]" } do 1433 | local func = assert(interpret_dict[name]) 1434 | compile_dict[name] = func 1435 | mcode_dict[name] = func 1436 | end 1437 | 1438 | -- insert built-in ROM words into compilation dict 1439 | for name, addr in pairs(rom_words) do 1440 | name = string.lower(name) 1441 | compile_dict[name] = compile_dict[name] or function() 1442 | list_line(name) 1443 | emit_short(addr) 1444 | end 1445 | 1446 | compilation_addr_to_name[addr] = name 1447 | end 1448 | 1449 | -- emit header for the main word enclosing the whole machine code program 1450 | if opts.mcode then 1451 | -- write name to dictionary, with terminator bit set for the last character 1452 | local name = string.upper(opts.main_word) 1453 | list_header("main word header") 1454 | emit_string(name:sub(1, #name - 1) .. string.char(name:byte(#name) | 128)) 1455 | emit_short(0) -- placeholder word length 1456 | emit_short(prev_word_link) 1457 | prev_word_link = here() 1458 | emit_byte(#name) 1459 | emit_short(0) -- placeholder code field 1460 | end 1461 | 1462 | if opts.mcode then 1463 | mcode.emit_subroutines() 1464 | end 1465 | 1466 | local library_words = [[ 1467 | 1 const TRUE 1468 | 0 const FALSE 1469 | 32 const BL 1470 | 9985 const PAD 1471 | 1472 | : 2dup over over ; 1473 | : 2drop drop drop ; 1474 | : 2over 4 pick 4 pick ; 1475 | : nip swap drop ; 1476 | : 2* dup + ; 1477 | : 2/ 2 / ; 1478 | : hex 16 base c! ; 1479 | : .s 15419 @ here 12 + over over - if do i @ . 2 +loop else drop drop then ; 1480 | 1481 | : c* 255 and swap 255 and * ; 1482 | : c= - 255 and 0= ; 1483 | : c< 255 and swap 255 and swap < ; 1484 | : c> 255 and swap 255 and swap > ; 1485 | 1486 | : inc dup c@ 1+ swap c! ; 1487 | : dec dup c@ 1- swap c! ; 1488 | 1489 | code di 243 c, 253 c, 233 c, ; 1490 | code ei 251 c, 253 c, 233 c, ; 1491 | ]] 1492 | 1493 | -- Compile library words which are not natively available on Jupiter Ace's ROM. 1494 | -- These are added at the beginning of every program, but they may be dead code eliminated. 1495 | -- Note that behaviors for some of these words may already exist and it's important 1496 | -- that we don't overwrite for example the optimized machine code implementations. 1497 | -- We prevent that by setting this ugly flag here... 1498 | dont_allow_redefining = true 1499 | execute_string(library_words, "") 1500 | dont_allow_redefining = false 1501 | 1502 | -- convert all words to uppercase if we're in case insensitive mode 1503 | if opts.ignore_case then 1504 | local function to_upper_case(dict) 1505 | local t = {} 1506 | for name, func in pairs(dict) do 1507 | t[string.upper(name)] = func 1508 | end 1509 | return t 1510 | end 1511 | 1512 | interpret_dict = to_upper_case(interpret_dict) 1513 | compile_dict = to_upper_case(compile_dict) 1514 | mcode_dict = to_upper_case(mcode_dict) 1515 | end 1516 | 1517 | -- compile all files 1518 | for _, filename in ipairs(input_files) do 1519 | -- load input file 1520 | local file, err = io.open(filename, "r") 1521 | if file == nil then fatal_error(err) end 1522 | local src = file:read("a") 1523 | file:close() 1524 | 1525 | -- execute it! 1526 | execute_string(src, filename) 1527 | end 1528 | 1529 | -- patch code field for main word 1530 | if opts.mcode then 1531 | local addr = compilation_addresses[opts.main_word] 1532 | if addr == nil then comp_error("could not find word '%s'", opts.main_word) end 1533 | write_short(prev_word_link + 1, addr) 1534 | end 1535 | 1536 | update_word_length() 1537 | 1538 | -- eliminate unused words 1539 | if opts.eliminate_unused_words then 1540 | -- mark unused words for next pass 1541 | for name in pairs(compilation_addresses) do 1542 | if word_counts[name] == 0 and name ~= opts.main_word and (word_flags[name] & F_NO_ELIMINATE) == 0 then 1543 | verbose("Eliminating unused word: %s", name) 1544 | eliminate_words[name] = true 1545 | more_work = true 1546 | end 1547 | end 1548 | end 1549 | 1550 | -- inline words that are used only once and have no side exits 1551 | if opts.inline_words then 1552 | for name, compilation_addr in pairs(compilation_addresses) do 1553 | local flags = word_flags[name] 1554 | if (word_counts[name] == 1 and (flags & F_NO_INLINE) == 0) or (flags & F_FORCE_INLINE) ~= 0 then 1555 | -- check for side exits 1556 | if (flags & F_HAS_SIDE_EXITS) == 0 then 1557 | verbose("Inlining word: %s", name) 1558 | inline_words[name] = true 1559 | more_work = true 1560 | else 1561 | warn("Word '%s' has side exits and cannot be inlined", name) 1562 | end 1563 | end 1564 | end 1565 | end 1566 | 1567 | -- run another pass if we could optimize something 1568 | if more_work then 1569 | pass = pass + 1 1570 | assert(pass < 10, "exceeded maximum number of compilation passes (compiler got stuck?)") 1571 | goto restart 1572 | end 1573 | 1574 | -- print warnings 1575 | for _, msg in ipairs(warnings) do 1576 | print(msg) 1577 | end 1578 | 1579 | -- write output 1580 | if output_file then 1581 | local file = io.open(output_file, "wb") 1582 | 1583 | local function shortstr(x) 1584 | return string.char(x & 0xff) .. string.char(x >> 8) 1585 | end 1586 | 1587 | local function checksum(str) 1588 | local chk = 0 1589 | for i = 1, #str do 1590 | chk = chk ~ str:byte(i) -- xor 1591 | end 1592 | return chk & 0xff 1593 | end 1594 | 1595 | -- header 1596 | local dict_data_size = here() - start_address 1597 | local dict_data_end = here() 1598 | local filename = opts.tap_filename .. string.rep(" ", 10 - #opts.tap_filename) 1599 | local header = "\26\0\0" .. 1600 | filename .. 1601 | shortstr(dict_data_size) .. 1602 | shortstr(start_address) .. 1603 | shortstr(prev_word_link) .. 1604 | shortstr(v_current) .. 1605 | shortstr(v_context) .. 1606 | shortstr(v_voclink) .. 1607 | shortstr(dict_data_end) 1608 | assert(#header == 27) 1609 | file:write(header) 1610 | file:write(string.char(checksum(header:sub(3)))) 1611 | 1612 | -- data 1613 | file:write(shortstr(dict_data_size + 1)) 1614 | local chk = 0 1615 | for addr = start_address, dict_data_end - 1 do 1616 | local byte = mem[addr] 1617 | file:write(string.char(byte)) 1618 | chk = chk ~ byte 1619 | end 1620 | file:write(string.char(chk & 0xff)) 1621 | file:close() 1622 | end 1623 | 1624 | -- write listing file 1625 | if opts.listing_file then 1626 | write_listing(opts.listing_file) 1627 | end -------------------------------------------------------------------------------- /mcode.lua: -------------------------------------------------------------------------------- 1 | -- Machine code compile dictionary 2 | 3 | local decode_tree = require "z80_opcodes" 4 | 5 | local labels = {} -- label -> address for current word 6 | local gotos = {} -- address to be patched -> label for current word 7 | 8 | local literal_pos -- the dictionary position just after the newest emitted literal 9 | local literal_pos2 -- the dictionary position of the second newest literal 10 | 11 | local call_pos -- the dictionary position just after the newest emitted Z80 call instruction 12 | local jump_targets = {} -- addresses targeted by (forward) jumps, for detecting when tail-calls can't be used 13 | 14 | local long_jumps = {} -- locations in source code where jumps must be long (for ELSE and THEN) 15 | 16 | -- Z80 registers 17 | local A = 7 18 | local B = 0 19 | local C = 1 20 | local D = 2 21 | local E = 3 22 | local H = 4 23 | local L = 5 24 | local AF = 0x10 25 | local BC = 0x20 26 | local DE = 0x30 27 | local HL = 0x40 28 | local IX = 0x50 29 | local IY = 0x60 30 | local SP = 0x70 31 | local BC_INDIRECT = 0x80 32 | local DE_INDIRECT = 0x90 33 | local HL_INDIRECT = 0xa0 34 | 35 | -- system variables 36 | local SCRPOS = 0x3c1c 37 | local STKBOT = 0x3c37 38 | local SPARE = 0x3c3b 39 | 40 | local reg_name = { 41 | [A] = "a", 42 | [B] = "b", 43 | [C] = "c", 44 | [D] = "d", 45 | [E] = "e", 46 | [H] = "h", 47 | [L] = "l", 48 | [AF] = "af", 49 | [BC] = "bc", 50 | [DE] = "de", 51 | [HL] = "hl", 52 | [IX] = "ix", 53 | [IY] = "iy", 54 | [SP] = "sp", 55 | [BC_INDIRECT] = "(bc)", 56 | [DE_INDIRECT] = "(de)", 57 | [HL_INDIRECT] = "(hl)", 58 | } 59 | 60 | local function _ld(dest, src) 61 | list_line("ld %s,%s", reg_name[dest], reg_name[src]) 62 | 63 | if dest == BC_INDIRECT and src == A then 64 | -- ld (bc), A 65 | emit_byte(0x02) 66 | elseif dest == DE_INDIRECT and src == A then 67 | -- ld (de), A 68 | emit_byte(0x12) 69 | elseif dest == HL_INDIRECT then 70 | -- ld (hl), r 71 | assert(src >= 0 and src <= 7, "_ld: unknown src register") 72 | emit_byte(0x70 + src) 73 | elseif dest == A and src == BC_INDIRECT then 74 | -- ld a, (bc) 75 | emit_byte(0x0a) 76 | elseif dest == A and src == DE_INDIRECT then 77 | -- ld a, (de) 78 | emit_byte(0x1a) 79 | elseif src == HL_INDIRECT then 80 | -- ld r, (de) 81 | -- LD A,(HL) 7E 82 | -- LD B,(HL) 46 83 | -- LD C,(HL) 4E 84 | -- LD D,(HL) 56 85 | -- LD E,(HL) 5E 86 | -- LD H,(HL) 66 87 | -- LD L,(HL) 6E 88 | assert(dest >= 0 and dest <= 7, "_ld: unknown dest register") 89 | emit_byte(0x46 + dest * 8) 90 | else 91 | -- ld r,r 92 | assert(dest >= 0 and dest <= 7, "_ld: unknown dest register") 93 | assert(src >= 0 and src <= 7, "_ld: unknown src register") 94 | emit_byte(0x40 + dest * 8 + src) 95 | end 96 | end 97 | 98 | local function _ld_const(r, value) 99 | -- LD A,n 3E n 100 | -- LD B,n 06 n 101 | -- LD C,n 0E n 102 | -- LD D,n 16 n 103 | -- LD E,n 1E n 104 | -- LD H,n 26 n 105 | -- LD L,n 2E n 106 | -- LD BC,nn 01 nn nn 107 | -- LD DE,nn 11 nn nn 108 | -- LD HL,nn 21 nn nn 109 | -- LD IX,nn DD 21 nn nn 110 | -- LD IY,nn FD 21 nn nn 111 | 112 | if r >= 0 and r <= 7 then 113 | list_line("ld %s,$%02x", reg_name[r], value) 114 | else 115 | list_line("ld %s,$%04x", reg_name[r], value) 116 | end 117 | 118 | if r == BC then 119 | emit_byte(0x01) 120 | emit_short(value) 121 | elseif r == DE then 122 | emit_byte(0x11) 123 | emit_short(value) 124 | elseif r == HL then 125 | emit_byte(0x21) 126 | emit_short(value) 127 | elseif r == IX then 128 | emit_byte(0xdd) 129 | emit_byte(0x21) 130 | emit_short(value) 131 | elseif r == IY then 132 | emit_byte(0xfd) 133 | emit_byte(0x21) 134 | emit_short(value) 135 | elseif r >= 0 and r <= 7 then 136 | emit_byte(0x06 + r * 8) 137 | emit_byte(value) 138 | else 139 | error("_ld_const: unknown register") 140 | end 141 | end 142 | 143 | local function _ld_fetch(r, addr) 144 | -- LD A,(nn) 3A nn nn 145 | -- LD BC,(nn) ED 4B nn nn 146 | -- LD DE,(nn) ED 5B nn nn 147 | -- LD HL,(nn) 2A nn nn 148 | -- LD IX,(nn) DD 2A nn nn 149 | -- LD IY,(nn) FD 2A nn nn 150 | -- LD SP,(nn) ED 7B nn nn 151 | 152 | list_line("ld %s,($%04x)", reg_name[r], addr) 153 | 154 | if r == A then 155 | emit_byte(0x3a) 156 | elseif r == BC then 157 | emit_byte(0xed) 158 | emit_byte(0x4b) 159 | elseif r == DE then 160 | emit_byte(0xed) 161 | emit_byte(0x5b) 162 | elseif r == HL then 163 | emit_byte(0x2a) 164 | elseif r == IX then 165 | emit_byte(0xdd) 166 | emit_byte(0x2a) 167 | elseif r == IY then 168 | emit_byte(0xfd) 169 | emit_byte(0x2a) 170 | elseif r == SP then 171 | emit_byte(0xed) 172 | emit_byte(0x7b) 173 | else 174 | error("_ld_fetch: unknown register") 175 | end 176 | emit_short(addr) 177 | end 178 | 179 | local function _ld_store(addr, r) 180 | -- LD (nn),A 32 nn nn 181 | -- LD (nn),BC ED 43 nn nn 182 | -- LD (nn),DE ED 53 nn nn 183 | -- LD (nn),HL 22 nn nn 184 | -- LD (nn),IX DD 22 nn nn 185 | -- LD (nn),IY FD 22 nn nn 186 | -- LD (nn),SP ED 73 nn nn 187 | 188 | list_line("ld ($%04x),%s", addr, reg_name[r]) 189 | 190 | if r == A then 191 | emit_byte(0x32) 192 | elseif r == BC then 193 | emit_byte(0xed) 194 | emit_byte(0x43) 195 | elseif r == DE then 196 | emit_byte(0xed) 197 | emit_byte(0x53) 198 | elseif r == HL then 199 | emit_byte(0x22) 200 | elseif r == IX then 201 | emit_byte(0xdd) 202 | emit_byte(0x22) 203 | elseif r == IY then 204 | emit_byte(0xfd) 205 | emit_byte(0x22) 206 | elseif r == SP then 207 | emit_byte(0xed) 208 | emit_byte(0x73) 209 | else 210 | error("_ld_store: unknown register") 211 | end 212 | emit_short(addr) 213 | end 214 | 215 | local function _ld_store_offset_const(r, offset, value) 216 | -- LD (IX+OFFSET),N DD 36 o n 217 | -- LD (IY+OFFSET),N FD 36 o n 218 | 219 | list_line("ld (%s+$%02x),$%02x", reg_name[r], offset, value) 220 | 221 | if r == IX then 222 | emit_byte(0xdd) 223 | elseif r == IY then 224 | emit_byte(0xfd) 225 | else 226 | error("_ld_store_offset_const: unknown register") 227 | end 228 | 229 | emit_byte(0x36) 230 | emit_byte(offset) 231 | emit_byte(value) 232 | end 233 | 234 | local function _exx() 235 | list_line("exx") 236 | emit_byte(0xd9) 237 | end 238 | 239 | local function _ex_de_hl() 240 | list_line("ex de,hl") 241 | emit_byte(0xeb) 242 | end 243 | 244 | local function _ex_af_af() 245 | list_line("ex af,af'") 246 | emit_byte(0x08) 247 | end 248 | 249 | local function _inc(r) 250 | -- INC A 3C 251 | -- INC B 04 252 | -- INC C 0C 253 | -- INC D 14 254 | -- INC E 1C 255 | -- INC H 24 256 | -- INC BC 03 257 | -- INC DE 13 258 | -- INC HL 23 259 | -- INC (HL) 34 260 | 261 | list_line("inc %s", reg_name[r]) 262 | 263 | if r == BC then 264 | emit_byte(0x03) 265 | elseif r == DE then 266 | emit_byte(0x13) 267 | elseif r == HL then 268 | emit_byte(0x23) 269 | elseif r == HL_INDIRECT then 270 | emit_byte(0x34) 271 | elseif r >= 0 and r <= 7 then 272 | emit_byte(0x04 + r * 8) 273 | else 274 | error("_dec: unknown register") 275 | end 276 | end 277 | 278 | local function _dec(r) 279 | -- DEC A 3D 280 | -- DEC B 05 281 | -- DEC C 0D 282 | -- DEC D 15 283 | -- DEC E 1D 284 | -- DEC H 25 285 | -- DEC BC 0B 286 | -- DEC DE 1B 287 | -- DEC HL 2B 288 | -- DEC (HL) 35 289 | 290 | list_line("dec %s", reg_name[r]) 291 | 292 | if r == BC then 293 | emit_byte(0x0b) 294 | elseif r == DE then 295 | emit_byte(0x1b) 296 | elseif r == HL then 297 | emit_byte(0x2b) 298 | elseif r == HL_INDIRECT then 299 | emit_byte(0x35) 300 | elseif r >= 0 and r <= 7 then 301 | emit_byte(0x05 + r * 8) 302 | else 303 | error("_dec: unknown register") 304 | end 305 | end 306 | 307 | local function _xor(r) 308 | assert(r >= 0 and r <= 7, "_xor: unknown register") 309 | list_line("xor %s", reg_name[r]) 310 | emit_byte(0xa8 + r) 311 | end 312 | 313 | local function _xor_const(n) 314 | list_line("xor %d", n) 315 | emit_byte(0xee) 316 | emit_byte(n) 317 | end 318 | 319 | local function _and(r) 320 | assert(r >= 0 and r <= 7, "_and: unknown register") 321 | list_line("and %s", reg_name[r]) 322 | emit_byte(0xa0 + r) 323 | end 324 | 325 | local function _and_const(n) 326 | list_line("and %d", n) 327 | emit_byte(0xe6) 328 | emit_byte(n) 329 | end 330 | 331 | local function _or(r) 332 | assert(r >= 0 and r <= 7, "_or: unknown register") 333 | list_line("or %s", reg_name[r]) 334 | emit_byte(0xb0 + r) 335 | end 336 | 337 | local function _or_const(n) 338 | list_line("or %d", n) 339 | emit_byte(0xf6) 340 | emit_byte(n) 341 | end 342 | 343 | local function _ccf() 344 | list_line("ccf") 345 | emit_byte(0x3f) 346 | end 347 | 348 | local function _scf() 349 | list_line("scf") 350 | emit_byte(0x37) 351 | end 352 | 353 | local function _add(dest, src) 354 | -- ADD HL,BC 09 355 | -- ADD HL,DE 19 356 | -- ADD HL,HL 29 357 | -- ADD HL,SP 39 358 | 359 | list_line("add %s,%s", reg_name[dest], reg_name[src]) 360 | 361 | if dest == HL then 362 | if src == BC then 363 | emit_byte(0x09) 364 | elseif src == DE then 365 | emit_byte(0x19) 366 | elseif src == HL then 367 | emit_byte(0x29) 368 | elseif src == SP then 369 | emit_byte(0x39) 370 | else 371 | error("_add: unknown src register") 372 | end 373 | elseif dest == A then 374 | assert(src >= 0 and src <= 7, "_add: unknown src register") 375 | emit_byte(0x80 + src) 376 | else 377 | error("_add: unknown operands") 378 | end 379 | end 380 | 381 | local function _add_const(n) 382 | list_line("add %d", n) 383 | emit_byte(0xc6) 384 | emit_byte(n) 385 | end 386 | 387 | local function _adc(dest, src) 388 | -- ADC HL,BC ED 4A 389 | -- ADC HL,DE ED 5A 390 | -- ADC HL,HL ED 6A 391 | -- ADC HL,SP ED 7A 392 | 393 | list_line("adc %s,%s", reg_name[dest], reg_name[src]) 394 | 395 | if dest == HL then 396 | if src == BC then 397 | emit_byte(0xed) 398 | emit_byte(0x4a) 399 | elseif src == DE then 400 | emit_byte(0xed) 401 | emit_byte(0x5a) 402 | elseif src == HL then 403 | emit_byte(0xed) 404 | emit_byte(0x6a) 405 | elseif src == SP then 406 | emit_byte(0xed) 407 | emit_byte(0x7a) 408 | else 409 | error("_adc: unknown src register") 410 | end 411 | elseif dest == A then 412 | assert(src >= 0 and src <= 7, "_adc: unknown src register") 413 | emit_byte(0x88 + src) 414 | else 415 | error("_adc: unknown operands") 416 | end 417 | end 418 | 419 | local function _sub(r) 420 | assert(r >= 0 and r <= 7, "_sub: unknown register") 421 | list_line("sub %s", reg_name[r]) 422 | emit_byte(0x90 + r) 423 | end 424 | 425 | local function _sub_const(n) 426 | list_line("sub %d", n) 427 | emit_byte(0xd6) 428 | emit_byte(n) 429 | end 430 | 431 | local function _sbc(dest, src) 432 | -- SBC HL,BC ED 42 433 | -- SBC HL,DE ED 52 434 | -- SBC HL,HL ED 62 435 | -- SBC HL,SP ED 72 436 | 437 | list_line("sbc %s,%s", reg_name[dest], reg_name[src]) 438 | 439 | if dest == HL then 440 | if src == BC then 441 | emit_byte(0xed) 442 | emit_byte(0x42) 443 | elseif src == DE then 444 | emit_byte(0xed) 445 | emit_byte(0x52) 446 | elseif src == HL then 447 | emit_byte(0xed) 448 | emit_byte(0x62) 449 | elseif src == SP then 450 | emit_byte(0xed) 451 | emit_byte(0x72) 452 | else 453 | error("_sbc: unknown src register") 454 | end 455 | elseif dest == A then 456 | assert(src >= 0 and src <= 7, "_sbc: unknown src register") 457 | emit_byte(0x98 + src) 458 | else 459 | error("_sbc: unknown operands") 460 | end 461 | end 462 | 463 | local function _cp_const(n) 464 | list_line("cp %d", n) 465 | emit_byte(0xfe) 466 | emit_byte(n) 467 | end 468 | 469 | local function _bit(i, r) 470 | assert(r >= 0 and r <= 7, "_bit: unknown register") 471 | list_line("bit %s,%s", i, reg_name[r]) 472 | emit_byte(0xcb) 473 | emit_byte(0x40 + 8 * i + r) 474 | end 475 | 476 | local function _sla(r) 477 | assert(r >= 0 and r <= 7, "_sla: unknown register") 478 | list_line("sla %s", reg_name[r]) 479 | emit_byte(0xcb) 480 | emit_byte(0x20 + r) 481 | end 482 | 483 | local function _sra(r) 484 | assert(r >= 0 and r <= 7, "_sra: unknown register") 485 | list_line("sra %s", reg_name[r]) 486 | emit_byte(0xcb) 487 | emit_byte(0x28 + r) 488 | end 489 | 490 | local function _rl(r) 491 | assert(r >= 0 and r <= 7, "_rl: unknown register") 492 | list_line("rl %s", reg_name[r]) 493 | emit_byte(0xcb) 494 | emit_byte(0x10 + r) 495 | end 496 | 497 | local function _rr(r) 498 | assert(r >= 0 and r <= 7, "_rr: unknown register") 499 | list_line("rr %s", reg_name[r]) 500 | emit_byte(0xcb) 501 | emit_byte(0x18 + r) 502 | end 503 | 504 | local function _rla() 505 | list_line("rla") 506 | emit_byte(0x17) 507 | end 508 | 509 | local function _ldir() 510 | list_line("ldir") 511 | emit_byte(0xed) 512 | emit_byte(0xb0) 513 | end 514 | 515 | local function _push(r) 516 | -- PUSH AF F5 517 | -- PUSH BC C5 518 | -- PUSH DE D5 519 | -- PUSH HL E5 520 | -- PUSH IX DD E5 521 | -- PUSH IY FD E5 522 | 523 | list_line("push %s", reg_name[r]) 524 | 525 | if r == AF then 526 | emit_byte(0xf5) 527 | elseif r == BC then 528 | emit_byte(0xc5) 529 | elseif r == DE then 530 | emit_byte(0xd5) 531 | elseif r == HL then 532 | emit_byte(0xe5) 533 | elseif r == IX then 534 | emit_byte(0xdd) 535 | emit_byte(0xe5) 536 | elseif r == IY then 537 | emit_byte(0xfd) 538 | emit_byte(0xe5) 539 | else 540 | error("_push: unknown register") 541 | end 542 | end 543 | 544 | local function _pop(r) 545 | -- POP AF F1 546 | -- POP BC C1 547 | -- POP DE D1 548 | -- POP HL E1 549 | -- POP IX DD E1 550 | -- POP IY FD E1 551 | 552 | list_line("pop %s", reg_name[r]) 553 | 554 | if r == AF then 555 | emit_byte(0xf1) 556 | elseif r == BC then 557 | emit_byte(0xc1) 558 | elseif r == DE then 559 | emit_byte(0xd1) 560 | elseif r == HL then 561 | emit_byte(0xe1) 562 | elseif r == IX then 563 | emit_byte(0xdd) 564 | emit_byte(0xe1) 565 | elseif r == IY then 566 | emit_byte(0xfd) 567 | emit_byte(0xe1) 568 | else 569 | error("_pop: unknown register") 570 | end 571 | end 572 | 573 | local function _call(addr) 574 | list_line("call $%04x", addr) 575 | emit_byte(0xcd) 576 | emit_short(addr) 577 | call_pos = here() 578 | end 579 | 580 | local function _ret() 581 | list_line("ret") 582 | emit_byte(0xc9) 583 | end 584 | 585 | local function _ret_c() 586 | list_line("ret c") 587 | emit_byte(0xd8) 588 | end 589 | 590 | local function _ret_nc() 591 | list_line("ret nc") 592 | emit_byte(0xd0) 593 | end 594 | 595 | local function _jp(addr) 596 | list_line("jp $%04x", addr) 597 | emit_byte(0xc3) 598 | emit_short(addr) 599 | end 600 | 601 | local function _jp_z(addr) 602 | list_line("jp z,$%04x", addr) 603 | emit_byte(0xca) 604 | emit_short(addr) 605 | end 606 | 607 | local function _jp_nz(addr) 608 | list_line("jp nz,$%04x", addr) 609 | emit_byte(0xc2) 610 | emit_short(addr) 611 | end 612 | 613 | local function _jp_c(addr) 614 | list_line("jp c,$%04x", addr) 615 | emit_byte(0xda) 616 | emit_short(addr) 617 | end 618 | 619 | local function _jp_nc(addr) 620 | list_line("jp nc,$%04x", addr) 621 | emit_byte(0xd2) 622 | emit_short(addr) 623 | end 624 | 625 | local function _jp_m(addr) 626 | list_line("jp m,$%04x", addr) 627 | emit_byte(0xfa) 628 | emit_short(addr) 629 | end 630 | 631 | local function _jp_p(addr) 632 | list_line("jp p,$%04x", addr) 633 | emit_byte(0xf2) 634 | emit_short(addr) 635 | end 636 | 637 | local function _jp_indirect(r) 638 | assert(r == HL or r == IX or r == IY, "_jp_indirect: unknown register") 639 | list_line("jp (%s)", reg_name[r]) 640 | if r == HL then 641 | emit_byte(0xe9) -- jp (hl) 642 | elseif r == IX then 643 | emit_byte(0xdd) -- jp (ix) 644 | emit_byte(0xe9) 645 | elseif r == IY then 646 | emit_byte(0xfd) -- jp (iy) 647 | emit_byte(0xe9) 648 | end 649 | end 650 | 651 | local function _di() 652 | list_line("di") 653 | emit_byte(0xf3) 654 | end 655 | 656 | local function _ei() 657 | list_line("ei") 658 | emit_byte(0xfb) 659 | end 660 | 661 | local function offset_to_absolute(offset) 662 | if offset > 127 then offset = offset - 256 end 663 | return here() + offset + 2 664 | end 665 | 666 | local function _jr(offset) 667 | list_line("jr $%04x", offset_to_absolute(offset)) 668 | emit_byte(0x18) 669 | emit_byte(offset) 670 | end 671 | 672 | local function _jr_z(offset) 673 | list_line("jr z,$%04x", offset_to_absolute(offset)) 674 | emit_byte(0x28) 675 | emit_byte(offset) 676 | end 677 | 678 | local function _jr_nz(offset) 679 | list_line("jr nz,$%04x", offset_to_absolute(offset)) 680 | emit_byte(0x20) 681 | emit_byte(offset) 682 | end 683 | 684 | local function _jr_c(offset) 685 | list_line("jr c,$%04x", offset_to_absolute(offset)) 686 | emit_byte(0x38) 687 | emit_byte(offset) 688 | end 689 | 690 | local function _jr_nc(offset) 691 | list_line("jr nc,$%04x", offset_to_absolute(offset)) 692 | emit_byte(0x30) 693 | emit_byte(offset) 694 | end 695 | 696 | local function _in(r, port) 697 | -- IN A,(C) ED 78 698 | -- IN B,(C) ED 40 699 | -- IN C,(C) ED 48 700 | -- IN D,(C) ED 50 701 | -- IN E,(C) ED 58 702 | -- IN H,(C) ED 60 703 | -- IN L,(C) ED 68 704 | -- IN F,(C) ED 70 not implemented! 705 | assert(port == C, "_in: invalid port") 706 | assert(r >= 0 and r <= 7, "_in: unknown register") 707 | list_line("in %s,(%s)", reg_name[r], reg_name[port]) 708 | emit_byte(0xed) 709 | emit_byte(0x40 + r * 8) 710 | end 711 | 712 | local function _in_const(r, port_addr) 713 | assert(r == A, "_in_const: invalid register") 714 | assert(port_addr >= 0 and port_addr <= 255, "_in_const: invalid port") 715 | list_line("in a,($%02x)", port_addr) 716 | emit_byte(0xdb) 717 | emit_byte(port_addr) 718 | end 719 | 720 | local function _out(port, r) 721 | -- OUT (C),A ED 79 722 | -- OUT (C),B ED 41 723 | -- OUT (C),C ED 49 724 | -- OUT (C),D ED 51 725 | -- OUT (C),E ED 59 726 | -- OUT (C),H ED 61 727 | -- OUT (C),L ED 69 728 | assert(port == C, "_out: invalid port") 729 | assert(r >= 0 and r <= 7, "_out: unknown register") 730 | list_line("out (%s),%s", reg_name[port], reg_name[r]) 731 | emit_byte(0xed) 732 | emit_byte(0x41 + r * 8) 733 | end 734 | 735 | local function _out_const(port_addr, r) 736 | assert(r == A, "_out_const: invalid register") 737 | assert(port_addr >= 0 and port_addr <= 255, "_out_const: invalid port") 738 | list_line("out ($%02x),a", port_addr) 739 | emit_byte(0xd3) 740 | emit_byte(port_addr) 741 | end 742 | 743 | local function _rst(i) 744 | assert(i >= 0 and i <= 0x38 and (i & 7) == 0, "invalid reset vector") 745 | list_line("rst %s", i) 746 | emit_byte(0xc7 + i) 747 | end 748 | 749 | -- Pushes DE on Forth stack, trashes HL. 750 | local function stk_push_de() 751 | _rst(16) 752 | end 753 | 754 | -- Pops value from Forth stack and puts it in DE register, trashes HL. 755 | local function stk_pop_de() 756 | _rst(24) 757 | end 758 | 759 | -- Pops value from Forth stack and puts it in BC register. 760 | local function stk_pop_bc() 761 | _call(0x084e) 762 | end 763 | 764 | local function stk_push_de_inline() 765 | _ld_fetch(HL, SPARE) 766 | _ld(HL_INDIRECT, E) 767 | _inc(HL) 768 | _ld(HL_INDIRECT, D) 769 | _inc(HL) 770 | _ld_store(SPARE, HL) 771 | end 772 | 773 | local function stk_pop_de_inline() 774 | _ld_fetch(HL, SPARE) 775 | _dec(HL) 776 | _ld(D, HL_INDIRECT) 777 | _dec(HL) 778 | _ld(E, HL_INDIRECT) 779 | _ld_store(SPARE, HL) 780 | end 781 | 782 | local function stk_pop_bc_inline() 783 | _ld_fetch(HL, SPARE) 784 | _dec(HL) 785 | _ld(B, HL_INDIRECT) 786 | _dec(HL) 787 | _ld(C, HL_INDIRECT) 788 | _ld_store(SPARE, HL) 789 | end 790 | 791 | local function branch_offset(jump_to_addr, instr_addr) 792 | instr_addr = instr_addr or here() 793 | local offset = jump_to_addr - instr_addr - 2 794 | if offset < -128 or offset > 127 then return end -- branch too long 795 | if offset < 0 then offset = offset + 256 end 796 | return offset 797 | end 798 | 799 | -- Emits unconditional jump to . 800 | local function jump(addr) 801 | local offset = branch_offset(addr) 802 | if offset then 803 | _jr(offset) 804 | else 805 | _jp(addr) 806 | end 807 | end 808 | 809 | -- Emits conditional jump which causes a jump to if Z flag is set. 810 | local function jump_z(addr) 811 | local offset = branch_offset(addr) 812 | if offset then 813 | _jr_z(offset) 814 | else 815 | _jp_z(addr) 816 | end 817 | end 818 | 819 | -- Emits conditional jump which causes a jump to if C flag is set. 820 | local function jump_c(addr) 821 | local offset = branch_offset(addr) 822 | if offset then 823 | _jr_c(offset) 824 | else 825 | _jp_c(addr) 826 | end 827 | end 828 | 829 | -- Emits conditional jump which causes a jump to if C flag is clear. 830 | local function jump_nc(addr) 831 | local offset = branch_offset(addr) 832 | if offset then 833 | _jr_nc(offset) 834 | else 835 | _jp_nc(addr) 836 | end 837 | end 838 | 839 | -- Patch already emitted jump instruction to jump to a new address. 840 | -- Returns false if the jump could not be patched (branch too long). 841 | local function patch_jump(instr_addr, jump_to_addr) 842 | local opcode = read_byte(instr_addr) 843 | if opcode < 0x80 then 844 | -- relative jump 845 | local offset = branch_offset(jump_to_addr, instr_addr) 846 | if offset == nil then return false end 847 | write_byte(instr_addr + 1, offset) 848 | else 849 | -- absolute jump 850 | write_short(instr_addr + 1, jump_to_addr) 851 | end 852 | list_patch(instr_addr, "%$%x+", string.format("$%04x", jump_to_addr)) 853 | jump_targets[jump_to_addr] = true 854 | return true 855 | end 856 | 857 | local function record_long_jump(ppos) 858 | if not long_jumps[ppos] then 859 | verbose("Deoptimizing branch to jump (%s)", ppos) 860 | long_jumps[ppos] = true 861 | more_work = true 862 | end 863 | end 864 | 865 | local function z80_decode(code, i) 866 | local node = decode_tree 867 | assert(node) 868 | 869 | local immediate 870 | local offset 871 | 872 | while true do 873 | if type(node) == "string" then break end 874 | 875 | local byte = assert(code[i]) 876 | i = i + 1 877 | 878 | if node.n or node.nn then 879 | if immediate == nil then 880 | immediate = byte 881 | else 882 | immediate = immediate | (byte << 8) 883 | end 884 | node = node.n or node.nn 885 | elseif node.o then 886 | offset = byte 887 | if offset > 127 then offset = offset - 256 end 888 | node = node.o 889 | else 890 | node = assert(node[byte]) 891 | end 892 | end 893 | 894 | local instr = node 895 | 896 | if immediate then 897 | instr = instr:gsub("nn", string.format("$%04x", immediate)) 898 | instr = instr:gsub("n", string.format("$%02x", immediate)) 899 | end 900 | 901 | if offset then 902 | instr = instr:gsub("o", offset) 903 | end 904 | 905 | return instr, immediate, offset, i 906 | end 907 | 908 | -- Relocates machine code to start at new address. 909 | -- 'code' is an array of bytes, 910 | -- 'list' is listing lines for that code (using same indices as code!) 911 | -- For example, list[3] contains the listing line for the instruction at code[3]. 912 | local function relocate_mcode(code, list, old_start_addr, new_start_addr) 913 | local rel_code = {} 914 | local rel_list = {} 915 | 916 | local abs_jumps = { 917 | [0xc3] = "jp nn", 918 | [0xda] = "jp c,nn", 919 | [0xfa] = "jp m,nn", 920 | [0xd2] = "jp nc,nn", 921 | [0xc2] = "jp nz,nn", 922 | [0xf2] = "jp p,nn", 923 | [0xea] = "jp pe,nn", 924 | [0xe2] = "jp po,nn", 925 | [0xca] = "jp z,nn", 926 | } 927 | 928 | local rel_jumps = { 929 | [0x18] = "jr o", 930 | [0x38] = "jr c,o", 931 | [0x30] = "jr nc,o", 932 | [0x20] = "jr nz,o", 933 | [0x28] = "jr z,o", 934 | } 935 | 936 | local i = 1 937 | while i <= #code do 938 | local s = i -- start of instruction 939 | local instr, immediate, offset, e = z80_decode(code, i) 940 | 941 | for j = 1, e - s do 942 | rel_code[i] = code[i] 943 | rel_list[i] = list[i] 944 | i = i + 1 945 | end 946 | 947 | local opcode = code[s] -- only valid for instructions without prefix bytes! 948 | 949 | -- relocate absolute jumps 950 | if abs_jumps[opcode] then 951 | local jump_to_addr = immediate 952 | local new_addr = jump_to_addr - old_start_addr + new_start_addr 953 | 954 | rel_code[s + 1] = new_addr & 0xff 955 | rel_code[s + 2] = new_addr >> 8 956 | 957 | rel_list[s] = abs_jumps[opcode]:gsub("nn", string.format("$%04x", new_addr)) 958 | end 959 | 960 | -- relocate relative jumps (listing file only) 961 | if rel_jumps[opcode] then 962 | local jump_to_addr = new_start_addr + s + offset + 1 963 | rel_list[s] = rel_jumps[opcode]:gsub("o", string.format("$%04x", jump_to_addr)) 964 | end 965 | 966 | -- skip over embedded strings 967 | if opcode == 0xcd and immediate == compilation_addresses["__print"] then 968 | local len = code[i] | (code[i + 1] << 8) 969 | 970 | for j = 1, len + 2 do 971 | rel_code[i] = code[i] 972 | rel_list[i] = list[i] 973 | i = i + 1 974 | end 975 | end 976 | 977 | -- skip over embedded Forth 978 | -- NOTE: This is pretty limited. We don't support jumping inside Forth code, for example. 979 | -- This should be fine because the mcode compiler only generates calls to Forth words. 980 | if opcode == 0xcd and immediate == 0x04b9 then 981 | -- copy bytes until Forth code end marker 0x1a0e is encountered 982 | -- every forth call address is 16-bit so we do two bytes per loop 983 | while true do 984 | local forth_end = (code[i] | (code[i + 1] << 8)) == 0x1a0e 985 | 986 | rel_code[i] = code[i] 987 | rel_list[i] = list[i] 988 | i = i + 1 989 | 990 | rel_code[i] = code[i] 991 | rel_list[i] = list[i] 992 | i = i + 1 993 | 994 | if forth_end then break end 995 | end 996 | end 997 | end 998 | 999 | return rel_code, rel_list 1000 | end 1001 | 1002 | local function call_forth(name) 1003 | -- Calling Forth word from machine code 1004 | local addr = rom_words[string.upper(name)] 1005 | if addr == nil then 1006 | comp_error("could not find compilation address of word %s", name) 1007 | end 1008 | stk_push_de() 1009 | list_comment("call forth") 1010 | _call(0x04b9) -- call forth 1011 | list_line(name) 1012 | emit_short(addr) 1013 | list_line("end-forth") 1014 | emit_short(0x1a0e) -- end-forth 1015 | stk_pop_de() 1016 | end 1017 | 1018 | local function call_code(name) 1019 | -- Calling word created using CODE from machine code 1020 | local addr = compilation_addresses[name] 1021 | if addr == nil then 1022 | comp_error("could not find compilation address of word %s", name) 1023 | end 1024 | list_comment(name) 1025 | _call(addr) -- words created using CODE don't have wrappers 1026 | mark_used(name) 1027 | end 1028 | 1029 | local function call_mcode(name) 1030 | -- Calling machine code word from another machine code word 1031 | local addr = compilation_addresses[name] 1032 | if addr == nil then 1033 | comp_error("could not find compilation address of word %s", name) 1034 | end 1035 | list_comment(name) 1036 | _call(addr) 1037 | mark_used(name) 1038 | end 1039 | 1040 | -- Emit a return instruction, or change the previous call to tail call when possible. 1041 | local function ret_or_tail_call() 1042 | -- Tail-call optimization must be disabled in the following cases: 1043 | -- 1. When the RET is targeted by a jump 1044 | -- 2. When the word is inlined 1045 | if opts.tail_call and call_pos == here() and not inline_words[last_word_name()] then 1046 | -- check that the call opcode is really there 1047 | assert(read_byte(call_pos - 3) == 0xcd) 1048 | -- change it to jp 1049 | write_byte(call_pos - 3, 0xc3) 1050 | list_patch(call_pos - 3, "call", "jp") 1051 | list_comment_append(call_pos - 3, " (tail-call)") 1052 | 1053 | -- ret cannot be eliminated if there's a jump to the address where the ret instruction should be 1054 | if jump_targets[here()] then 1055 | _ret() 1056 | end 1057 | else 1058 | _ret() 1059 | end 1060 | end 1061 | 1062 | -- Emits invisible subroutine words to be used by mcode words. 1063 | local function emit_subroutines() 1064 | local function is_word_used(name) 1065 | return not eliminate_words[name] 1066 | end 1067 | 1068 | -- rot 1069 | if is_word_used("__rot") then 1070 | -- >r swap r> swap 1071 | create_word(0, "__rot", F_INVISIBLE | F_NO_INLINE) 1072 | _push(DE) 1073 | stk_pop_de() 1074 | _call(here() + 5) -- call swap 1075 | stk_push_de() 1076 | _pop(DE) 1077 | -- fall through to swap... 1078 | end 1079 | 1080 | -- swap 1081 | if is_word_used("__swap") or is_word_used("__rot") then 1082 | create_word(0, "__swap", F_INVISIBLE | F_NO_INLINE) 1083 | _ld_fetch(HL, SPARE) -- load second element from top of stack to BC 1084 | _dec(HL) 1085 | _ld(B, HL_INDIRECT) 1086 | _dec(HL) 1087 | _ld(C, HL_INDIRECT) 1088 | _ld(HL_INDIRECT, E) -- push old top 1089 | _inc(HL) 1090 | _ld(HL_INDIRECT, D) 1091 | _inc(HL) 1092 | _ld_store(SPARE, HL) 1093 | _ld(D, B) -- second element to DE 1094 | _ld(E, C) 1095 | _ret() 1096 | end 1097 | 1098 | -- 2dup 1099 | if is_word_used("__2dup") then 1100 | -- over over 1101 | create_word(0, "__2dup", F_INVISIBLE | F_NO_INLINE) 1102 | _call(here() + 3) -- call over 1103 | -- fall through to over... 1104 | end 1105 | 1106 | -- over 1107 | if is_word_used("__over") or is_word_used("__2dup") then 1108 | create_word(0, "__over", F_INVISIBLE | F_NO_INLINE) 1109 | _ld_fetch(HL, SPARE) -- push old top 1110 | _ld(B, H) 1111 | _ld(C, L) 1112 | _ld(HL_INDIRECT, E) 1113 | _inc(HL) 1114 | _ld(HL_INDIRECT, D) 1115 | _inc(HL) 1116 | _ld_store(SPARE, HL) 1117 | _dec(BC) -- second element to DE 1118 | _ld(A, BC_INDIRECT) 1119 | _ld(D, A) 1120 | _dec(BC) 1121 | _ld(A, BC_INDIRECT) 1122 | _ld(E, A) 1123 | _ret() 1124 | end 1125 | 1126 | -- 2over 1127 | if is_word_used("__2over") then 1128 | -- 4 pick 4 pick 1129 | create_word(0, "__2over", F_INVISIBLE | F_NO_INLINE) 1130 | stk_push_de() 1131 | for i = 1, 2 do 1132 | _ld_const(DE, 4) 1133 | stk_push_de() 1134 | _call(0x094d) 1135 | end 1136 | stk_pop_de() 1137 | _ret() 1138 | end 1139 | 1140 | -- roll 1141 | if is_word_used("__roll") then 1142 | create_word(0, "__roll", F_INVISIBLE | F_NO_INLINE) 1143 | stk_push_de() 1144 | _call(0x094d) 1145 | _ex_de_hl() 1146 | _ld_fetch(HL, STKBOT) 1147 | _ld(H, D) 1148 | _ld(L, E) 1149 | _inc(HL) 1150 | _inc(HL) 1151 | _ldir() 1152 | _ld_store(SPARE, DE) 1153 | stk_pop_de() 1154 | _ret() 1155 | end 1156 | 1157 | -- add 1158 | if is_word_used("__add") then 1159 | create_word(0, "__add", F_INVISIBLE | F_NO_INLINE) 1160 | stk_pop_bc_inline() 1161 | _ex_de_hl() 1162 | _add(HL, BC) 1163 | _ex_de_hl() 1164 | _ret() 1165 | end 1166 | 1167 | -- sub 1168 | if is_word_used("__sub") then 1169 | create_word(0, "__sub", F_INVISIBLE | F_NO_INLINE) 1170 | _ld(B, D) 1171 | _ld(C, E) 1172 | stk_pop_de_inline() 1173 | _ex_de_hl() 1174 | _or(A) -- clear carry 1175 | _sbc(HL, BC) 1176 | _ex_de_hl() 1177 | _ret() 1178 | end 1179 | 1180 | -- signed 16-bit * 16-bit multiplication routine 1181 | if is_word_used("__mult16") then 1182 | create_word(0, "__mult16", F_INVISIBLE | F_NO_INLINE) 1183 | stk_pop_bc() 1184 | _ld_const(HL, 0) 1185 | _ld_const(A, 16) 1186 | -- loop: 1187 | _add(HL, HL) 1188 | _ex_de_hl() 1189 | _adc(HL, HL) 1190 | _ex_de_hl() 1191 | _jr_nc(4) --> skip 1192 | _add(HL, BC) 1193 | _jr_nc(1) --> skip 1194 | _inc(DE) 1195 | -- skip: 1196 | _dec(A) 1197 | _jr_nz(0xf2) --> loop 1198 | _ex_de_hl() 1199 | _ret() 1200 | end 1201 | 1202 | -- unsigned 8-bit * 8-bit multiplication routine 1203 | -- source: http://map.grauw.nl/sources/external/z80bits.html#1.1 1204 | if is_word_used("__mult8") then 1205 | create_word(0, "__mult8", F_INVISIBLE | F_NO_INLINE) 1206 | stk_pop_bc() 1207 | _ld(H, C) 1208 | _ld_const(L, 0) 1209 | _sla(H) 1210 | _jr_nc(1) --> skip 1211 | _ld(L, E) 1212 | -- skip: 1213 | for i = 1, 7 do 1214 | _add(HL, HL) 1215 | _jr_nc(1) --> skipn 1216 | _add(HL, DE) 1217 | -- skipn: 1218 | end 1219 | _ex_de_hl() 1220 | _ret() 1221 | end 1222 | 1223 | -- gt 1224 | if is_word_used("__gt") then 1225 | create_word(0, "__gt", F_INVISIBLE | F_NO_INLINE) 1226 | _ld_fetch(HL, SPARE) -- load second value from top to BC 1227 | _dec(HL) 1228 | _ld(B, HL_INDIRECT) 1229 | _dec(HL) 1230 | _ld(C, HL_INDIRECT) 1231 | _ld_store(SPARE, HL) 1232 | _ex_de_hl() -- HL = top value 1233 | -- sign: HL = value1, BC = value2 1234 | _ld(A, H) 1235 | _xor(B) 1236 | _jp_m(here() + 5) --> skip 1237 | _sbc(HL, BC) 1238 | -- skip: 1239 | _rl(H) 1240 | _ld_const(A, 0) 1241 | _ld(D, A) 1242 | _rla() 1243 | _ld(E, A) 1244 | _ret() 1245 | end 1246 | 1247 | -- lt 1248 | if is_word_used("__lt") then 1249 | create_word(0, "__lt", F_INVISIBLE | F_NO_INLINE) 1250 | _ld_fetch(HL, SPARE) -- load second value from top to BC 1251 | _dec(HL) 1252 | _ld(B, HL_INDIRECT) 1253 | _dec(HL) 1254 | _ld(C, HL_INDIRECT) 1255 | _ld_store(SPARE, HL) 1256 | _ld(H, B) 1257 | _ld(L, C) 1258 | -- sign: HL = value1, DE = value2 1259 | _ld(A, H) 1260 | _xor(D) 1261 | _jp_m(here() + 5) --> skip 1262 | _sbc(HL, DE) 1263 | -- skip: 1264 | _rl(H) 1265 | _ld_const(A, 0) 1266 | _ld(D, A) 1267 | _rla() 1268 | _ld(E, A) 1269 | _ret() 1270 | end 1271 | 1272 | -- min 1273 | if is_word_used("__min") then 1274 | create_word(0, "__min", F_INVISIBLE | F_NO_INLINE) 1275 | stk_pop_bc_inline() 1276 | _ld(H, D) 1277 | _ld(L, E) 1278 | _or(A) -- clear carry 1279 | _sbc(HL, BC) 1280 | _rl(H) 1281 | _ret_c() 1282 | _ld(D, B) 1283 | _ld(E, C) 1284 | _ret() 1285 | end 1286 | 1287 | -- max 1288 | if is_word_used("__max") then 1289 | create_word(0, "__max", F_INVISIBLE | F_NO_INLINE) 1290 | stk_pop_bc_inline() 1291 | _ld(H, D) 1292 | _ld(L, E) 1293 | _or(A) -- clear carry 1294 | _sbc(HL, BC) 1295 | _rl(H) 1296 | _ret_nc() 1297 | _ld(D, B) 1298 | _ld(E, C) 1299 | _ret() 1300 | end 1301 | 1302 | -- at 1303 | if is_word_used("__at") then 1304 | create_word(0, "__at", F_INVISIBLE | F_NO_INLINE) 1305 | _ld_fetch(HL, SPARE) 1306 | _dec(HL) 1307 | _dec(HL) 1308 | _ld(A, HL_INDIRECT) 1309 | _ld_store(SPARE, HL) 1310 | _call(0x0b28) -- at routine in ROM, in: A = y, E = x 1311 | _ld_store(SCRPOS, HL) 1312 | stk_pop_de() 1313 | _ret() 1314 | end 1315 | 1316 | -- print 1317 | if is_word_used("__print") then 1318 | create_word(0, "__print", F_INVISIBLE | F_NO_INLINE) 1319 | _pop(HL) -- HL = pointer to string data 1320 | _push(DE) -- preserve DE 1321 | _ex_de_hl() -- DE = string data 1322 | _call(0x0979) -- call print embedded string routine 1323 | _ex_de_hl() -- now HL points to end of string 1324 | _pop(DE) -- restore DE 1325 | _jp_indirect(HL) 1326 | end 1327 | 1328 | -- spaces 1329 | if is_word_used("__spaces") then 1330 | create_word(0, "__spaces", F_INVISIBLE | F_NO_INLINE) 1331 | -- loop: 1332 | _dec(DE) 1333 | _bit(7, D) 1334 | _jr_nz(5) --> done 1335 | _ld_const(A, 0x20) 1336 | _rst(8) 1337 | _jr(0xf6) --> loop 1338 | -- done: 1339 | stk_pop_de() 1340 | _ret() 1341 | end 1342 | 1343 | -- type 1344 | if is_word_used("__type") then 1345 | create_word(0, "__type", F_INVISIBLE | F_NO_INLINE) 1346 | _ld(B, D) -- move count from DE to BC 1347 | _ld(C, E) 1348 | stk_pop_de() 1349 | _call(0x097f) -- call print string routine (BC = count, DE = addr) 1350 | stk_pop_de() 1351 | _ret() 1352 | end 1353 | end 1354 | 1355 | local function emit_literal(n, comment) 1356 | if comment then 1357 | list_comment(comment) 1358 | else 1359 | list_comment("lit %d", n) 1360 | end 1361 | 1362 | stk_push_de() 1363 | _ld_const(DE, n) 1364 | 1365 | literal_pos2 = literal_pos 1366 | literal_pos = here() 1367 | end 1368 | 1369 | -- Returns the literal that was just emitted, erasing the code that emitted it. 1370 | local function erase_literal() 1371 | if literal_pos == here() then 1372 | local value = read_short(literal_pos - 2) 1373 | list_erase(here() - 4, here() - 1) 1374 | erase(4) 1375 | literal_pos = literal_pos2 1376 | literal_pos2 = nil 1377 | return value 1378 | end 1379 | end 1380 | 1381 | local function is_pow2(x) 1382 | return x > 0 and (x & (x - 1)) == 0 1383 | end 1384 | 1385 | local dict = { 1386 | [';'] = function() 1387 | -- patch gotos 1388 | -- this must be done before ret() because a goto may target the address of the ret instruction 1389 | for patch_loc, label in pairs(gotos) do 1390 | local jump_to_addr = labels[label] 1391 | if jump_to_addr == nil then comp_error("undefined label '%s'", label) end 1392 | patch_jump(patch_loc, jump_to_addr) 1393 | end 1394 | 1395 | ret_or_tail_call() 1396 | 1397 | interpreter_state() 1398 | check_control_flow_stack() 1399 | 1400 | -- inlining 1401 | local name = last_word_name() 1402 | if inline_words[name] then 1403 | local code, list, comments, old_start_addr = erase_previous_word() 1404 | 1405 | -- when the inlined word is compiled, we emit its code 1406 | mcode_dict[name] = function() 1407 | list_comment("inlined %s", name) 1408 | 1409 | local code, list = relocate_mcode(code, list, old_start_addr, here()) 1410 | 1411 | for i = 1, #code - 1 do -- skip ret at the end 1412 | if list[i] then list_line("%s", list[i]) end 1413 | if comments[i] and i > 1 then list_comment("%s", comments[i]) end 1414 | emit_byte(code[i]) 1415 | end 1416 | end 1417 | end 1418 | 1419 | labels = {} 1420 | gotos = {} 1421 | jump_targets = {} 1422 | 1423 | call_pos = nil 1424 | literal_pos = nil 1425 | literal_pos2 = nil 1426 | end, 1427 | dup = function() 1428 | list_comment("dup") 1429 | stk_push_de() 1430 | end, 1431 | ['?dup'] = function() 1432 | list_comment("?dup") 1433 | _ld(A, D) 1434 | _or(E) 1435 | _jr_z(1) --> skip 1436 | stk_push_de() 1437 | -- skip: 1438 | end, 1439 | over = function() 1440 | call_mcode("__over") 1441 | end, 1442 | drop = function() 1443 | list_comment("drop") 1444 | stk_pop_de() 1445 | end, 1446 | nip = function() 1447 | -- swap drop 1448 | list_comment("nip") 1449 | stk_pop_bc() 1450 | end, 1451 | swap = function() 1452 | call_mcode("__swap") 1453 | end, 1454 | ['2dup'] = function() 1455 | call_mcode("__2dup") 1456 | end, 1457 | ['2drop'] = function() 1458 | list_comment("2drop") 1459 | stk_pop_de() 1460 | stk_pop_de() 1461 | end, 1462 | ['2over'] = function() 1463 | call_mcode("__2over") 1464 | end, 1465 | pick = function() 1466 | list_comment("pick") 1467 | stk_push_de() 1468 | _call(0x094d) 1469 | stk_pop_de() 1470 | end, 1471 | roll = function() 1472 | call_mcode("__roll") 1473 | end, 1474 | rot = function() 1475 | call_mcode("__rot") 1476 | end, 1477 | ['r>'] = function() 1478 | list_comment("r>") 1479 | stk_push_de() 1480 | _pop(DE) 1481 | end, 1482 | ['>r'] = function() 1483 | list_comment(">r") 1484 | _push(DE) 1485 | stk_pop_de() 1486 | end, 1487 | ['r@'] = function() 1488 | list_comment("r@") 1489 | stk_push_de() 1490 | _pop(DE) 1491 | _push(DE) 1492 | end, 1493 | ['+'] = function() 1494 | local lit = erase_literal() 1495 | if lit == 0 then 1496 | -- nothing to do 1497 | elseif lit and lit > 0 and lit <= 4 then 1498 | -- lit*6 cycles, lit*1 bytes 1499 | list_comment("%d + ", lit) 1500 | for i = 1, lit do 1501 | _inc(DE) 1502 | end 1503 | elseif lit and (lit & 0xff) == 0 then 1504 | list_comment("$%04x + ", lit) 1505 | _ld(A, D) 1506 | _add_const((lit & 0xff00) >> 8) 1507 | _ld(D, A) 1508 | elseif lit then 1509 | -- 28 cycles, 7 bytes 1510 | list_comment("%d + ", lit) 1511 | _ex_de_hl() 1512 | _ld_const(DE, lit) 1513 | _add(HL, DE) 1514 | _ex_de_hl() 1515 | else 1516 | call_mcode("__add") 1517 | end 1518 | end, 1519 | ['-'] = function() 1520 | local lit = erase_literal() 1521 | if lit == 0 then 1522 | -- nothing to do 1523 | elseif lit and lit > 0 and lit <= 4 then 1524 | -- lit*6 cycles, lit*1 bytes 1525 | list_comment("%d - ", lit) 1526 | for i = 1, lit do 1527 | _dec(DE) 1528 | end 1529 | elseif lit and (lit & 0xff) == 0 then 1530 | list_comment("$%04x - ", lit) 1531 | _ld(A, D) 1532 | _sub_const((lit & 0xff00) >> 8) 1533 | _ld(D, A) 1534 | elseif lit then 1535 | list_comment("%d - ", lit) 1536 | _ex_de_hl() 1537 | _ld_const(DE, -lit) 1538 | _add(HL, DE) 1539 | _ex_de_hl() 1540 | else 1541 | call_mcode("__sub") 1542 | end 1543 | end, 1544 | ['*'] = function() 1545 | local lit = erase_literal() 1546 | if lit == 0 then 1547 | list_comment("0 *") 1548 | _ld_const(DE, 0) 1549 | elseif lit == 1 then 1550 | -- nothing to do 1551 | elseif lit and is_pow2(lit) and lit <= 32767 then 1552 | list_comment("%d *", lit) 1553 | if lit < 256 then 1554 | while lit > 1 do 1555 | _sla(E) 1556 | _rl(D) 1557 | lit = lit // 2 1558 | end 1559 | else 1560 | _ld(D, E) 1561 | _ld_const(E, 0) 1562 | lit = lit // 256 1563 | while lit > 1 do 1564 | _sla(D) 1565 | lit = lit // 2 1566 | end 1567 | end 1568 | elseif lit then 1569 | emit_literal(lit) 1570 | call_mcode("__mult16") 1571 | else 1572 | call_mcode("__mult16") 1573 | end 1574 | end, 1575 | ['c*'] = function() 1576 | local lit = erase_literal() 1577 | if lit and (lit == 0 or lit >= 256) then 1578 | list_comment("%d c*", lit) 1579 | _ld_const(DE, 0) 1580 | elseif lit == 1 then 1581 | -- nothing to do 1582 | elseif lit and is_pow2(lit) then 1583 | list_comment("%d c*", lit) 1584 | while lit > 1 do 1585 | _sla(E) 1586 | lit = lit // 2 1587 | end 1588 | elseif lit then 1589 | emit_literal(lit) 1590 | call_mcode("__mult8") 1591 | else 1592 | call_mcode("__mult8") 1593 | end 1594 | end, 1595 | ['/'] = function() 1596 | local lit = erase_literal() 1597 | if lit == 1 then 1598 | -- nothing to do 1599 | elseif lit and is_pow2(lit) and lit <= 32767 then 1600 | list_comment("%d /", lit) 1601 | if lit < 256 then 1602 | while lit > 1 do 1603 | _sra(D) 1604 | _rr(E) 1605 | lit = lit // 2 1606 | end 1607 | else 1608 | _ld(E, D) 1609 | _ld_const(D, 0) 1610 | _bit(7, E) 1611 | _jr_z(1) 1612 | _dec(D) 1613 | lit = lit // 256 1614 | while lit > 1 do 1615 | _sra(E) 1616 | lit = lit // 2 1617 | end 1618 | end 1619 | elseif lit then 1620 | emit_literal(lit) 1621 | call_forth("/") 1622 | else 1623 | call_forth("/") 1624 | end 1625 | end, 1626 | ['1+'] = function() 1627 | list_comment("1+") 1628 | _inc(DE) 1629 | end, 1630 | ['1-'] = function() 1631 | list_comment("1-") 1632 | _dec(DE) 1633 | end, 1634 | ['2+'] = function() 1635 | list_comment("2+") 1636 | _inc(DE) 1637 | _inc(DE) 1638 | end, 1639 | ['2-'] = function() 1640 | list_comment("2-") 1641 | _dec(DE) 1642 | _dec(DE) 1643 | end, 1644 | ['2*'] = function() 1645 | list_comment("2*") 1646 | _sla(E) 1647 | _rl(D) 1648 | end, 1649 | ['2/'] = function() 1650 | list_comment("2/") 1651 | _sra(D) 1652 | _rr(E) 1653 | end, 1654 | negate = function() 1655 | list_comment("negate") 1656 | _xor(A) 1657 | _sub(E) 1658 | _ld(E, A) 1659 | _sbc(A, A) 1660 | _sub(D) 1661 | _ld(D, A) 1662 | end, 1663 | abs = function() 1664 | list_comment("abs") 1665 | _bit(7, D) 1666 | _jr_z(6) --> skip 1667 | _xor(A) 1668 | _sub(E) 1669 | _ld(E, A) 1670 | _sbc(A, A) 1671 | _sub(D) 1672 | _ld(D, A) 1673 | -- skip: 1674 | end, 1675 | min = function() 1676 | call_mcode("__min") 1677 | end, 1678 | max = function() 1679 | call_mcode("__max") 1680 | end, 1681 | xor = function() 1682 | local lit = erase_literal() 1683 | if lit then 1684 | if lit ~= 0 then list_comment("%d xor", lit) end 1685 | 1686 | if (lit & 0xff) ~= 0 then 1687 | _ld(A, E) 1688 | _xor_const(lit & 0xff) 1689 | _ld(E, A) 1690 | end 1691 | 1692 | if (lit & 0xff00) ~= 0 then 1693 | _ld(A, D) 1694 | _xor_const((lit & 0xff00) >> 8) 1695 | _ld(D, A) 1696 | end 1697 | else 1698 | list_comment("xor") 1699 | stk_pop_bc() 1700 | _ld(A, E) 1701 | _xor(C) 1702 | _ld(E, A) 1703 | _ld(A, D) 1704 | _xor(B) 1705 | _ld(D, A) 1706 | end 1707 | end, 1708 | ['and'] = function() 1709 | local lit = erase_literal() 1710 | if lit then 1711 | local lo = lit & 0xff 1712 | local hi = (lit & 0xff00) >> 8 1713 | 1714 | if lo ~= 0xff or hi ~= 0xff then list_comment("%d and", lit) end 1715 | 1716 | if lo == 0 then 1717 | _ld_const(E, 0) 1718 | elseif lo ~= 0xff then 1719 | _ld(A, E) 1720 | _and_const(lo) 1721 | _ld(E, A) 1722 | end 1723 | 1724 | if hi == 0 then 1725 | _ld_const(D, 0) 1726 | elseif hi ~= 0xff then 1727 | _ld(A, D) 1728 | _and_const(hi) 1729 | _ld(D, A) 1730 | end 1731 | else 1732 | list_comment("and") 1733 | stk_pop_bc() 1734 | _ld(A, E) 1735 | _and(C) 1736 | _ld(E, A) 1737 | _ld(A, D) 1738 | _and(B) 1739 | _ld(D, A) 1740 | end 1741 | end, 1742 | ['or'] = function() 1743 | local lit = erase_literal() 1744 | if lit then 1745 | local lo = lit & 0xff 1746 | local hi = (lit & 0xff00) >> 8 1747 | 1748 | if lo ~= 0 or hi ~= 0 then list_comment("%d or", lit) end 1749 | 1750 | if lo == 0xff then 1751 | _ld_const(E, 0xff) 1752 | elseif lo ~= 0 then 1753 | _ld(A, E) 1754 | _or_const(lo) 1755 | _ld(E, A) 1756 | end 1757 | 1758 | if hi == 0xff then 1759 | _ld_const(D, 0xff) 1760 | elseif hi ~= 0 then 1761 | _ld(A, D) 1762 | _or_const(hi) 1763 | _ld(D, A) 1764 | end 1765 | else 1766 | list_comment("or") 1767 | stk_pop_bc() 1768 | _ld(A, E) 1769 | _or(C) 1770 | _ld(E, A) 1771 | _ld(A, D) 1772 | _or(B) 1773 | _ld(D, A) 1774 | end 1775 | end, 1776 | ['not'] = function() 1777 | list_comment("not") 1778 | _ld(A, D) 1779 | _or(E) 1780 | _ld_const(DE, 1) 1781 | _jr_z(1) --> skip 1782 | _ld(E, D) -- clear e 1783 | -- skip: 1784 | end, 1785 | ['0='] = function() 1786 | list_comment("0=") 1787 | _ld(A, D) 1788 | _or(E) 1789 | _ld_const(DE, 1) 1790 | _jr_z(1) --> skip 1791 | _ld(E, D) -- clear e 1792 | -- skip: 1793 | end, 1794 | ['0<'] = function() 1795 | list_comment("0<") 1796 | _xor(A) 1797 | _rl(D) 1798 | _ld(D, A) 1799 | _rla() 1800 | _ld(E, A) 1801 | end, 1802 | ['0>'] = function() 1803 | list_comment("0>") 1804 | _ld(A, D) 1805 | _or(E) 1806 | _jr_z(3) --> skip 1807 | _rl(D) 1808 | _ccf() -- invert carry flag 1809 | -- skip: 1810 | _ld_const(A, 0) 1811 | _ld(D, A) 1812 | _rla() 1813 | _ld(E, A) 1814 | end, 1815 | ['='] = function() 1816 | local lit = erase_literal() 1817 | if lit then 1818 | list_comment("%d =", lit) 1819 | _ex_de_hl() 1820 | _ld_const(BC, -lit) 1821 | _or(A) -- clear carry 1822 | _adc(HL, BC) -- ADD HL, BC can't be used here because it does not update Z flag! 1823 | _ld_const(DE, 0) 1824 | _jr_nz(1) --> skip 1825 | _inc(E) 1826 | -- skip: 1827 | else 1828 | list_comment("=") 1829 | stk_pop_bc() 1830 | _ex_de_hl() 1831 | _or(A) -- clear carry 1832 | _sbc(HL, BC) 1833 | _ld_const(DE, 0) 1834 | _jr_nz(1) --> skip 1835 | _inc(E) 1836 | -- skip: 1837 | end 1838 | end, 1839 | ['c='] = function() 1840 | local lit = erase_literal() 1841 | if lit then 1842 | comp_assert(lit >= 0 and lit <= 255, "Literal outside range for C=") 1843 | list_comment("%d c=", lit) 1844 | _ld(A, E) 1845 | _cp_const(lit) 1846 | _ld_const(DE, 0) 1847 | _jr_nz(1) --> skip 1848 | _inc(E) 1849 | -- skip: 1850 | else 1851 | list_comment("c=") 1852 | _ld(A, E) 1853 | stk_pop_de() -- preserves A 1854 | _sub(E) 1855 | _ld_const(DE, 0) 1856 | _jr_nz(1) --> skip 1857 | _inc(E) 1858 | -- skip: 1859 | end 1860 | end, 1861 | ['>'] = function() 1862 | call_mcode("__gt") 1863 | end, 1864 | ['c>'] = function() 1865 | local lit = erase_literal() 1866 | if lit then lit = lit & 0xff end 1867 | 1868 | if lit and lit == 255 then 1869 | list_comment("255 c>") 1870 | _ld_const(DE, 0) 1871 | elseif lit then 1872 | list_comment("%d c>", lit) 1873 | _ld(A, E) 1874 | _ld_const(DE, 0) 1875 | _cp_const(lit + 1) 1876 | _jr_c(1) 1877 | _inc(E) 1878 | else 1879 | list_comment("c>") 1880 | _ld(A, E) 1881 | stk_pop_de() -- preserves A 1882 | _sub(E) 1883 | _ld_const(DE, 0) 1884 | _jr_nc(1) --> skip 1885 | _inc(E) 1886 | -- skip: 1887 | end 1888 | end, 1889 | ['<'] = function() 1890 | call_mcode("__lt") 1891 | end, 1892 | ['c<'] = function() 1893 | local lit = erase_literal() 1894 | if lit then lit = lit & 0xff end 1895 | 1896 | if lit and lit == 0 then 1897 | list_comment("0 c<") 1898 | _ld_const(DE, 0) 1899 | elseif lit then 1900 | list_comment("%d c<", lit) 1901 | _ld(A, E) 1902 | _ld_const(DE, 0) 1903 | _cp_const(lit) 1904 | _jr_nc(1) 1905 | _inc(E) 1906 | else 1907 | list_comment("c<") 1908 | _ld(A, E) 1909 | stk_pop_de() -- preserves A 1910 | _scf() 1911 | _sbc(A, E) 1912 | _ld_const(DE, 0) 1913 | _jr_c(1) --> skip 1914 | _inc(E) 1915 | -- skip: 1916 | end 1917 | end, 1918 | ['!'] = function() 1919 | -- ( n addr -- ) 1920 | local addr = erase_literal() 1921 | if addr then 1922 | list_comment("%04x !", addr) 1923 | _ld_store(addr, DE) 1924 | stk_pop_de() 1925 | else 1926 | list_comment("!") 1927 | stk_pop_bc() 1928 | _ex_de_hl() 1929 | _ld(HL_INDIRECT, C) 1930 | _inc(HL) 1931 | _ld(HL_INDIRECT, B) 1932 | stk_pop_de() 1933 | end 1934 | end, 1935 | ['@'] = function() 1936 | -- ( addr -- n ) 1937 | local addr = erase_literal() 1938 | if addr then 1939 | list_comment("%04x @", addr) 1940 | stk_push_de() 1941 | _ld_fetch(DE, addr) 1942 | else 1943 | list_comment("@") 1944 | _ex_de_hl() 1945 | _ld(E, HL_INDIRECT) 1946 | _inc(HL) 1947 | _ld(D, HL_INDIRECT) 1948 | end 1949 | end, 1950 | ['c!'] = function() 1951 | -- ( n addr -- ) 1952 | local addr = erase_literal() 1953 | if addr then 1954 | list_comment("%04x c!", addr) 1955 | _ld(A, E) 1956 | _ld_store(addr, A) 1957 | stk_pop_de() 1958 | else 1959 | list_comment("c!") 1960 | stk_pop_bc() 1961 | _ld(A, C) 1962 | _ld(DE_INDIRECT, A) 1963 | stk_pop_de() 1964 | end 1965 | end, 1966 | ['c@'] = function() 1967 | -- ( addr - n ) 1968 | local addr = erase_literal() 1969 | if addr then 1970 | list_comment("%04x c@", addr) 1971 | stk_push_de() 1972 | _ld_fetch(A, addr) 1973 | _ld(E, A) 1974 | _ld_const(D, 0) 1975 | else 1976 | list_comment("c@") 1977 | _ld(A, DE_INDIRECT) 1978 | _ld(E, A) 1979 | _ld_const(D, 0) 1980 | end 1981 | end, 1982 | inc = function() 1983 | -- ( addr - ) 1984 | local addr = erase_literal() 1985 | if addr then 1986 | list_comment("%04x inc", addr) 1987 | _ld_const(HL, addr) 1988 | _inc(HL_INDIRECT) 1989 | else 1990 | list_comment("inc") 1991 | _ex_de_hl() 1992 | _inc(HL_INDIRECT) 1993 | stk_pop_de() 1994 | end 1995 | end, 1996 | dec = function() 1997 | -- ( addr - ) 1998 | local addr = erase_literal() 1999 | if addr then 2000 | list_comment("%04x dec", addr) 2001 | _ld_const(HL, addr) 2002 | _dec(HL_INDIRECT) 2003 | else 2004 | list_comment("dec") 2005 | _ex_de_hl() 2006 | _dec(HL_INDIRECT) 2007 | stk_pop_de() 2008 | end 2009 | end, 2010 | ascii = function() 2011 | (compile_dict.ascii or compile_dict.ASCII)() 2012 | end, 2013 | ['[hex]'] = function() 2014 | (compile_dict['[hex]'] or compile_dict['[HEX]'])() 2015 | end, 2016 | emit = function() 2017 | list_comment("emit") 2018 | _ld(A, E) 2019 | _rst(8) 2020 | stk_pop_de() 2021 | end, 2022 | cr = function() 2023 | list_comment("cr") 2024 | _ld_const(A, 0x0d) 2025 | _rst(8) 2026 | end, 2027 | space = function() 2028 | list_comment("space") 2029 | _ld_const(A, 0x20) 2030 | _rst(8) 2031 | end, 2032 | spaces = function() 2033 | call_mcode("__spaces") 2034 | end, 2035 | at = function() 2036 | call_mcode("__at") 2037 | end, 2038 | type = function() 2039 | -- ( addr count -- ) 2040 | call_mcode("__type") 2041 | end, 2042 | base = function() 2043 | list_comment("base") 2044 | stk_push_de() 2045 | _ld_const(DE, 0x3c3f) 2046 | end, 2047 | hex = function() 2048 | list_comment("hex") 2049 | _ld_store_offset_const(IX, 0x3f, 0x10) 2050 | end, 2051 | decimal = function() 2052 | list_comment("decimal") 2053 | _ld_store_offset_const(IX, 0x3f, 0x0a) 2054 | end, 2055 | out = function() 2056 | -- ( n port -- ) 2057 | local port = erase_literal() 2058 | if port then 2059 | list_comment("$%04x out", port) 2060 | _ld(A, E) 2061 | _out_const(port & 0xff, A) 2062 | stk_pop_de() 2063 | else 2064 | list_comment("out") -- C = port 2065 | _ld(C, E) 2066 | stk_pop_de() -- E = value to output (stk_pop_de does not trash C) 2067 | _out(C, E) 2068 | stk_pop_de() 2069 | end 2070 | end, 2071 | ['in'] = function() 2072 | -- ( port -- n ) 2073 | local port = erase_literal() 2074 | if port then 2075 | list_comment("$%04x in", port) 2076 | stk_push_de() 2077 | --_ld_const(A, port >> 8) -- place hi byte to address bus when reading keyboard (untested) 2078 | _in_const(A, port & 0xff) 2079 | _ld(E, A) 2080 | _ld_const(D, 0) 2081 | else 2082 | list_comment("in") -- C = port 2083 | _ld(C, E) 2084 | _ld_const(D, 0) 2085 | _in(E, C) 2086 | end 2087 | end, 2088 | inkey = function() 2089 | -- ( -- n ) 2090 | list_comment("inkey") 2091 | stk_push_de() 2092 | _call(0x0336) -- call keyscan routine 2093 | _ld(E, A) 2094 | _ld_const(D, 0) 2095 | end, 2096 | ['if'] = function() 2097 | list_comment("if") 2098 | _ld(A, D) 2099 | _or(E) 2100 | stk_pop_de() 2101 | local ppos = parse_pos() 2102 | cf_push(ppos) 2103 | cf_push(here()) 2104 | cf_push('if') 2105 | -- emit conditional branch with placeholder jump to address 2106 | -- use relative branch unless short jump is blacklisted (see ELSE) 2107 | if opts.short_branches and not long_jumps[ppos] then 2108 | _jr_z(0) 2109 | else 2110 | _jp_z(0) 2111 | end 2112 | end, 2113 | ['else'] = function() 2114 | comp_assert(cf_pop() == 'if', "ELSE without matching IF") 2115 | local where = cf_pop() 2116 | local if_ppos = cf_pop() 2117 | local ppos = parse_pos() 2118 | cf_push(ppos) 2119 | cf_push(here()) 2120 | cf_push('if') 2121 | -- emit unconditional branch to jump to THEN with placeholder jump to address 2122 | -- use relative branch unless short jump is blacklisted 2123 | list_comment("else") 2124 | if opts.short_branches and not long_jumps[ppos] then 2125 | _jr(0) 2126 | else 2127 | _jp(0) 2128 | end 2129 | -- patch jump target at previous IF 2130 | if not patch_jump(where, here()) then 2131 | -- branch too long, blacklist it 2132 | assert(opts.short_branches) 2133 | record_long_jump(if_ppos) 2134 | end 2135 | end, 2136 | ['then'] = function() 2137 | comp_assert(cf_pop() == 'if', "THEN without matching IF") 2138 | local where = cf_pop() 2139 | local ppos = cf_pop() 2140 | -- patch jump target at previous IF or ELSE 2141 | if not patch_jump(where, here()) then 2142 | -- branch too long, blacklist it 2143 | assert(opts.short_branches) 2144 | record_long_jump(ppos) 2145 | end 2146 | end, 2147 | label = function() 2148 | local label = next_symbol() 2149 | labels[label] = here() 2150 | end, 2151 | ['goto'] = function() 2152 | local label = next_symbol() 2153 | 2154 | if labels[label] then 2155 | -- label found -> this is a backward jump 2156 | -- emit the jump immediately 2157 | list_comment("goto %s", label) 2158 | jump(labels[label]) 2159 | else 2160 | -- label not found -> this is a forward jump 2161 | -- emit placeholder jump and resolve jump address in ; 2162 | gotos[here()] = label 2163 | list_comment("goto %s", label) 2164 | _jp(0) 2165 | end 2166 | end, 2167 | begin = function() 2168 | cf_push(here()) 2169 | cf_push('begin') 2170 | end, 2171 | again = function() 2172 | comp_assert(cf_pop() == 'begin', "AGAIN without matching BEGIN") 2173 | local target = cf_pop() 2174 | list_comment("again") 2175 | jump(target) 2176 | end, 2177 | ['until'] = function() 2178 | comp_assert(cf_pop() == 'begin', "UNTIL without matching BEGIN") 2179 | local target = cf_pop() 2180 | list_comment("until") 2181 | _ld(A, D) 2182 | _or(E) 2183 | _ex_af_af() -- store Z flag 2184 | stk_pop_de() 2185 | _ex_af_af() -- restore Z flag 2186 | jump_z(target) 2187 | end, 2188 | ['do'] = function() 2189 | -- ( limit counter -- ) 2190 | 2191 | -- record limit and counter if they are literals 2192 | local limit = false 2193 | local counter = false 2194 | if literal_pos == here() and literal_pos2 == here() - 4 then 2195 | limit = read_short(literal_pos2 - 2) 2196 | counter = read_short(literal_pos - 2) 2197 | end 2198 | 2199 | if limit and counter then 2200 | assert(erase_literal() == counter) 2201 | assert(erase_literal() == limit) 2202 | list_comment("%d %d do", limit, counter) 2203 | _ld_const(BC, limit) 2204 | _push(BC) -- push limit to return stack 2205 | _ld_const(BC, counter) 2206 | _push(BC) -- push counter to return stack 2207 | elseif counter then 2208 | assert(erase_literal() == counter) 2209 | list_comment("%d do", counter) -- push limit to return stack 2210 | _push(DE) 2211 | _ld_const(DE, counter) 2212 | _push(DE) -- push counter to return stack 2213 | stk_pop_de() 2214 | else 2215 | list_comment("do") -- pop limit 2216 | stk_pop_bc(); 2217 | _push(BC) -- push limit to return stack 2218 | _push(DE) -- push counter to return stack 2219 | stk_pop_de() 2220 | end 2221 | 2222 | cf_push(counter) 2223 | cf_push(limit) 2224 | cf_push(here()) 2225 | cf_push('do') 2226 | end, 2227 | loop = function() 2228 | comp_assert(cf_pop() == 'do', "LOOP without matching DO") 2229 | local target = cf_pop() 2230 | local limit = cf_pop() 2231 | local counter = cf_pop() 2232 | 2233 | if limit and counter and limit >= 0 and limit <= 255 and counter >= 0 and counter <= 255 then 2234 | -- specialization for unsigned 8-bit loop with known limit 2235 | list_comment("loop (8-bit)") -- pop counter 2236 | _pop(BC) 2237 | _inc(C) 2238 | _push(BC) -- push counter 2239 | _ld(A, C) 2240 | _cp_const(limit) 2241 | jump_c(target) 2242 | _pop(BC) -- end of loop -> pop limit & counter from stack 2243 | _pop(BC) 2244 | elseif limit then 2245 | -- specialization for 16-bit loop with known limit 2246 | list_comment("loop (16-bit)") -- pop counter 2247 | _pop(BC) 2248 | _inc(BC) 2249 | _push(BC) -- push counter 2250 | _scf() -- set carry 2251 | _ld_const(HL, limit) 2252 | _sbc(HL, BC) -- HL = limit - counter 2253 | _jp_p(target) 2254 | _pop(BC) -- end of loop -> pop limit & counter from stack 2255 | _pop(BC) 2256 | else 2257 | -- limit unknown 2258 | list_comment("loop (generic)") -- pop counter 2259 | _pop(BC) 2260 | _pop(HL) -- pop limit 2261 | _push(HL) -- push limit 2262 | _inc(BC) 2263 | _push(BC) -- push counter 2264 | _scf() -- set carry 2265 | _sbc(HL, BC) -- HL = limit - counter 2266 | _jp_p(target) 2267 | _pop(BC) -- end of loop -> pop limit & counter from stack 2268 | _pop(BC) 2269 | end 2270 | end, 2271 | ['+loop'] = function() 2272 | comp_assert(cf_pop() == 'do', "+LOOP without matching DO") 2273 | local target = cf_pop() 2274 | local limit = cf_pop() 2275 | local counter = cf_pop() 2276 | 2277 | local step = erase_literal() 2278 | 2279 | if step and step >= 0 and step < 32768 then 2280 | -- specialization for counting up 2281 | list_comment("%d +loop (count up)", step) -- pop counter 2282 | _pop(HL) 2283 | _ld_const(BC, step) 2284 | _add(HL, BC) -- HL = counter + step 2285 | _pop(BC) -- pop limit 2286 | _push(BC) -- push limit 2287 | _push(HL) -- push counter 2288 | _or(A) 2289 | _sbc(HL, BC) -- HL = counter - limit 2290 | _jp_m(target) -- loop back 2291 | _pop(BC) -- end of loop -> pop limit & counter from stack 2292 | _pop(BC) 2293 | elseif step and step >= 32768 then 2294 | -- specialization for counting down 2295 | step = step - 65536 2296 | list_comment("%d +loop (count down)", step) -- pop counter 2297 | _pop(HL) 2298 | _ld_const(BC, step) 2299 | _add(HL, BC) -- HL = counter + step 2300 | _pop(BC) -- pop limit 2301 | _push(BC) -- push limit 2302 | _push(HL) -- push counter 2303 | _scf() 2304 | _sbc(HL, BC) -- HL = counter - limit 2305 | _jp_p(target) -- there is no jr m, instruction on Z80! 2306 | _pop(BC) -- end of loop -> pop limit & counter from stack 2307 | _pop(BC) 2308 | else 2309 | -- counting direction unknown! 2310 | warn("+LOOP with non-literal step produces bad code!") 2311 | -- lots of code but this should be very rare 2312 | list_comment("+loop") -- pop counter 2313 | _pop(HL) 2314 | _add(HL, DE) -- increment loop counter 2315 | _ld(B, D) -- B contains sign of step 2316 | _ex_de_hl() -- DE = new counter value 2317 | _pop(HL) -- pop limit 2318 | _push(HL) -- push limit 2319 | _push(DE) -- push counter 2320 | -- counting up or down? 2321 | _bit(7, B) 2322 | _jr_nz(9) --> jump to 'down' if step is negative 2323 | -- counting up 2324 | _scf() 2325 | _sbc(HL, DE) -- HL = limit - counter 2326 | stk_pop_de() -- does not trash flags or BC 2327 | _jp_p(target) 2328 | _jr(7) --> continue 2329 | -- counting down 2330 | _or(A) -- clear carry 2331 | _sbc(HL, DE) -- HL = limit - counter 2332 | stk_pop_de() -- does not trash flags or BC 2333 | _jp_m(target) -- there is no jr m, instruction on Z80! 2334 | -- continue: 2335 | _pop(BC) -- end of loop -> pop limit & counter from stack 2336 | _pop(BC) 2337 | end 2338 | end, 2339 | ['repeat'] = function() 2340 | comp_error("mcode word REPEAT not yet implemented") 2341 | end, 2342 | ['while'] = function() 2343 | comp_error("mcode word WHILE not yet implemented") 2344 | end, 2345 | i = function() 2346 | list_comment("i") 2347 | stk_push_de() 2348 | _pop(DE) 2349 | _push(DE) 2350 | end, 2351 | ['i\''] = function() 2352 | list_comment("i'") 2353 | stk_push_de() 2354 | _pop(BC) 2355 | _pop(DE) 2356 | _push(DE) 2357 | _push(BC) 2358 | end, 2359 | j = function() 2360 | list_comment("j") 2361 | stk_push_de() 2362 | _ld_const(HL, 4) 2363 | _add(HL, SP) 2364 | _ld(E, HL_INDIRECT) 2365 | _inc(HL) 2366 | _ld(D, HL_INDIRECT) 2367 | end, 2368 | leave = function() 2369 | list_comment("leave") -- pop counter 2370 | _pop(HL) 2371 | _pop(HL) -- pop limit 2372 | _push(HL) -- push limit 2373 | _push(HL) -- push limit as new counter 2374 | end, 2375 | exit = function() 2376 | list_comment("exit") 2377 | ret_or_tail_call() 2378 | set_word_flag(last_word_name(), F_HAS_SIDE_EXITS) 2379 | end, 2380 | ['['] = function() 2381 | compile_dict['[']() 2382 | end, 2383 | lit = function() 2384 | (compile_dict.lit or compile_dict.LIT)() 2385 | end, 2386 | ['."'] = function() 2387 | local str = next_symbol_with_delimiter('"') 2388 | call_mcode("__print") 2389 | list_comment('"%s"', str) 2390 | emit_short(#str) 2391 | emit_string(str) 2392 | end, 2393 | di = function() 2394 | list_comment("di") 2395 | _di() 2396 | end, 2397 | ei = function() 2398 | list_comment("ei") 2399 | _ei() 2400 | end, 2401 | here = function() 2402 | list_comment("here") 2403 | stk_push_de() 2404 | _ld_fetch(DE, STKBOT) 2405 | end, 2406 | } 2407 | 2408 | -- The following words do not have fast machine code implementation 2409 | local interpreted_words = { 2410 | "ufloat", "int", "fnegate", "f/", "f*", "f+", "f-", "f.", 2411 | "d+", "dnegate", "u/mod", "*/", "mod", "*/mod", "/mod", "u*", "d<", "u<", 2412 | "#", "#s", "u.", ".", "#>", "<#", "sign", "hold", 2413 | "cls", "slow", "fast", "invis", "vis", "abort", "quit", 2414 | "line", "word", "number", "convert", "retype", "query", 2415 | "plot", "beep", "execute", "call" 2416 | } 2417 | 2418 | for _, name in ipairs(interpreted_words) do 2419 | dict[name] = function() 2420 | call_forth(name) 2421 | end 2422 | end 2423 | 2424 | local function get_dict() 2425 | local t = {} 2426 | for k, v in pairs(dict) do 2427 | t[k] = v 2428 | end 2429 | return t 2430 | end 2431 | 2432 | return { 2433 | get_dict = get_dict, 2434 | emit_subroutines = emit_subroutines, 2435 | emit_literal = emit_literal, 2436 | call_forth = call_forth, 2437 | call_code = call_code, 2438 | call_mcode = call_mcode, 2439 | } --------------------------------------------------------------------------------