├── LICENSE ├── README.md ├── forth.asm ├── htcheck.lua ├── r216-forth.cps └── screenshot.png /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2019 Siraphob (Ben) Phipathananunth 2 | 3 | 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: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | 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. 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A Forth for the R216 computer 2 | 3 | ![Screenshot](screenshot.png) 4 | 5 | ## What? 6 | This project aims to implement the Forth programming language on the 7 | [R216 computer by LBPHacker](https://trigraph.net/powdertoy/R216/manual.md). The 8 | computer is implemented completely in the video game [Powder 9 | Toy](https://powdertoy.co.uk/), so this Forth will be one of the few 10 | systems out there that target a fictional computer. Since Forth is 11 | extremely easy to port, it only takes a couple of primitive routines 12 | to get started writing the whole thing again. 13 | 14 | This is the first system I know of in Powder Toy that allows 15 | interactive programming within Powder Toy itself (i.e. without needing 16 | an assembler), and the first non-assembly language to be ported to a 17 | Powder Toy computer. 18 | 19 | The default program `forth.asm` reads up to 128 characters of input, 20 | then starts the interpreter up, which performs the standard Forth loops 21 | until a `NUL` byte is read. The interpreter echos back what it's 22 | reading for debugging purposes, according to the following table. 23 | 24 | | Color | Meaning | 25 | | :-: | :-: | 26 | | Green | Interpreted | 27 | | Red | Compiled | 28 | | Yellow | Interpreted (immediate) | 29 | | Blue | Compiled number | 30 | | Cyan | Interpreted number | 31 | 32 | Here are some example programs that you can type at the REPL. 33 | ```forth 34 | ." hello, world!" 35 | \ => hello, world ok 36 | 37 | : stars 0 do star loop ; 38 | 10 stars 39 | \ => ********** ok 40 | 41 | : factorial dup 0= if drop 1 else dup 1- recurse * then ; 42 | 5 factorial . 43 | \ => 120 ok 44 | ``` 45 | 46 | Here is a list of words defined in the system. 47 | ``` 48 | s0 sp@ depth .s decimal hex latest base xor and find allot here c@ c! 49 | @ ! , +! -! >r r> /mod nip mod div space create immed ?immed hide [ 50 | ] : ; constant value to . d. u. ?dup < > = 0<> 0= <> dup 2dup drop 51 | 2drop swap over rot + - * um* 1- 1+ 2- 2+ number max min word /mod 52 | origin page emit >dfa >cfa execute recurse puts lit tell s" ." halt 53 | (') ' if else then begin until again while j i repeat do loop +loop 54 | star 55 | ``` 56 | 57 | ## Features 58 | - The first Forth system for a TPT computer; 75 words and counting 59 | - An extensible, lightweight, interactive, introspective language. 60 | - Harnesses the 16-bit power of the R216 computer, with features such 61 | as 62 | - 16-bit multiplication (16 * 16 -> 16 bit or 16 * 16 -> 32 bit) 63 | - Terminal output/input (can be generalized to other peripherals) 64 | - Adapts to memory layout, can be flashed on the 4K or 8K variant of 65 | the R216 66 | 67 | ### Quirks 68 | - Only the first three characters and length are checked when 69 | traversing the dictionary (this was actually the case in older Forth 70 | systems such as the one used in _Starting Forth_) 71 | - **Runs slowly**: increase the frame rate by running `tpt.setfpscap(2)` 72 | unless you're prepared to wait minutes for simple programs 73 | 74 | ## Why? 75 | Fictional computers are great. One can learn a lot from both 76 | implementing and playing around with them. But when was the last time 77 | you saw a Forth REPL in fictional computer? What about a Forth REPL 78 | in a fictional computer implemented in a powder simulation game? 79 | Well, now you have! From the relative success of my [previous 80 | project](https://github.com/siraben/zkeme80), a Forth-based operating 81 | system for TI-84+ calculators, I thought it would be fun to write 82 | another one. From initially knowing nothing about the architecture, 83 | Within two days I got a REPL working with compile/interpret states, 84 | and now it's just a matter of porting all the other Forth words we 85 | know and love. 86 | 87 | ## Building and running R216 Forth 88 | Ensure you have a recent version of Powder Toy (tested on version 89 | 94.1). 90 | 91 | Clone [the assembler](https://github.com/LBPHacker/R216) and this 92 | repository using Git. Open the file `r216-forth.cps` in Powder Toy, you'll 93 | see a computer, screen and keyboard. Open the Lua console by pressing 94 | ~ and type the following: 95 | 96 | ```lua 97 | r2asm = loadfile("/r2asm.lua") 98 | ``` 99 | 100 | Where `` is the absolute path to the cloned assembler. 101 | Then, type in 102 | 103 | ```lua 104 | a = "/forth.asm" 105 | ``` 106 | 107 | To define a variable `a` to shorten lines (Powder Toy truncates long 108 | commands). Finally, you can assemble `forth.asm` by running: 109 | 110 | ```lua 111 | r2asm(a, 0xDEAD, "") 112 | ``` 113 | 114 | Where `` is the path to a log file which you can open 115 | to see if the assembling worked. Close the console by pressing ~, and 116 | click on the sign to begin using R216 Forth! 117 | 118 | ## Future plans 119 | - [x] Add ability to read numbers 120 | - [x] Relies on multiplication routine 121 | - [x] Add string words `."`, `s"` 122 | - [x] Add exceptions, `catch`, `throw` 123 | - [ ] Add `?do`, fix `leave` 124 | - [ ] Requires rewriting implementation of `do`, `loop` and `+loop` 125 | 126 | -------------------------------------------------------------------------------- /forth.asm: -------------------------------------------------------------------------------- 1 | ;;; Register allocations 2 | ;;; r0: Top of stack (TOS) 3 | ;;; r1: Forth instruction pointer (IP) 4 | ;;; r2: Return stack pointer (RSP) 5 | ;;; r3: User pointer (HERE) 6 | 7 | ;;; r10: Terminal port 8 | ;;; sp: Parameter stack pointer (PSP) 9 | 10 | ;;; r4 - r9: unassigned 11 | ;;; r11 - r13: unassigned 12 | 13 | ;;; Hidden flag is 64 14 | ;;; Immediate flag is 128 15 | ;;; Length mask is 31 16 | 17 | ;;; word header: 18 | ;;; 0: previous entry 19 | ;;; 1: length + flags 20 | ;;; 2-4: first three characters of name 21 | ;;; 5 onwards: data 22 | 23 | %include "common" 24 | 25 | start: 26 | ;; Check if this is a reboot. 27 | cmp [rebooted], 0 28 | jne did_reboot 29 | didnt_reboot: 30 | ;; If not, let's set up the HERE pointer. 31 | ;; otherwise our word definitions get clobbered. 32 | mov r3, here_start 33 | mov [var_here], r3 34 | jmp main_asm 35 | did_reboot: 36 | 37 | jmp main_asm 38 | main_asm: 39 | mov [var_state], 0 40 | 41 | mov r0, 0x2000 42 | mov [0x1FFF], r0 43 | mov r0, 0x1000 44 | mov [0x0FFF], r0 45 | mov r0, 0x0800 46 | mov [0x07FF], r0 47 | 48 | mov r0, 0xFFFF 49 | 50 | ;; Regardless of whether or not we rebooted, we do the 51 | ;; following. 52 | ;; Set up stack pointer (adjusts automatically to memory space) 53 | mov sp, [r0] 54 | mov [stack_zero_prog], sp 55 | ;; User stack zero 56 | push 0 57 | 58 | mov [stack_zero], sp 59 | ;; Allocate 64 stack items before placing return stack. 60 | mov r2, sp 61 | mov r4, 64 62 | sub r2, r4 63 | 64 | ;; Set here_end 65 | mov r4, 64 66 | mov r0, r2 67 | sub r0, r4 68 | mov [var_here_end], r0 69 | 70 | ;; In case we call EXIT from the top level. 71 | sub r2, 1 72 | mov [r2], interpret_done 73 | 74 | mov r10, 0 75 | bump r10 76 | send r10, 0x200F 77 | 78 | mov r1, main 79 | jmp next 80 | 81 | main: 82 | dw lit, rebooted, fetch 83 | dw lit, 1, lit, rebooted, store 84 | dw zjump, main_cont 85 | clear_reboot: 86 | ;; dw lit, str_buffer, lit, 128, erase 87 | dw page 88 | main_cont: 89 | dw welcome_proc 90 | dw lit, 0x200F, term_send 91 | dw lit, 0x1020, term_send 92 | 93 | dw lit, inputdata_prompt, puts 94 | 95 | dw lit, str_buffer, lit, 128, lit, 0x1022, getline 96 | dw lit, str_buffer, lit, input_ptr, store 97 | dw page 98 | interpret_loop: 99 | dw colorize_state 100 | dw check_underflow 101 | dw word, qdup, zjump, interpret_done 102 | dw find, qdup, zjump, maybe_number 103 | dw state, fetch, zjump, interpret_word 104 | compiling_word: 105 | dw dup, qimmed, zjump, compile_word 106 | ;; Word is immediate, special yellow color 107 | dw lit, 0x200E, term_send 108 | interpret_word: 109 | dw lit, word_buffer, puts, space 110 | dw to_cfa, execute 111 | dw jump, interpret_loop 112 | compile_word: 113 | dw lit, word_buffer, puts, space 114 | dw to_cfa, comma, jump, interpret_loop 115 | 116 | maybe_number: 117 | dw lit, word_buffer, number 118 | dw lit, num_status, fetch, zjump, not_found 119 | dw state, fetch, zjump, interpret_number 120 | compile_number: 121 | dw lit, lit, comma, comma 122 | dw lit, 0x2009, term_send 123 | dw lit, word_buffer, puts, space 124 | dw jump, interpret_loop 125 | interpret_number: 126 | dw lit, 0x200B, term_send 127 | dw lit, word_buffer, puts, space 128 | dw jump, interpret_loop 129 | 130 | colorize_state: 131 | call docol 132 | dw state, fetch, zjump, colorize_interp 133 | ;; red for compiling 134 | dw lit, 0x200C, term_send 135 | dw exit 136 | colorize_interp: 137 | ;; green for interpreting 138 | dw lit, 0x200A, term_send 139 | dw exit 140 | 141 | ;; (IP) -> W 142 | ;; IP + 1 -> IP 143 | ;; JP (W) 144 | next: 145 | mov r4, [r1] 146 | add r1, 1 147 | jmp r4 148 | 149 | ;; PUSH_IP_RS 150 | ;; POP IP 151 | ;; JP NEXT 152 | docol: 153 | sub r2, 1 154 | mov [r2], r1 155 | pop r1 156 | jmp next 157 | 158 | ;; POP_IP_RS 159 | ;; JP NEXT 160 | exit: 161 | mov r1, [r2] 162 | add r2, 1 163 | jmp next 164 | 165 | done_msg: 166 | dw 0x200F, " ok", 0 167 | 168 | interpret_done: 169 | dw here, lit, var_here, store 170 | dw lit, done_msg, puts 171 | ;; dw lit, str_buffer, lit, 128, erase 172 | dw key, drop, main_asm 173 | 174 | sz_link: 175 | dw fetch_byte_link 176 | dw 2, "s0 " 177 | ;; CODE 178 | sz: 179 | push r0 180 | mov r0, [stack_zero] 181 | jmp next 182 | 183 | sp_fetch_link: 184 | dw here_link 185 | dw 3, "sp@" 186 | sp_fetch: 187 | push r0 188 | mov r0, sp 189 | jmp next 190 | 191 | sp_store_link: 192 | dw rp_fetch_link 193 | dw 3, "sp!" 194 | sp_store: 195 | mov sp, r0 196 | pop r0 197 | jmp next 198 | 199 | depth_link: 200 | dw store_link 201 | dw 5, "dep" 202 | depth: 203 | call docol 204 | dw sz, sp_fetch, minus, two_minus, exit 205 | 206 | print_stack_link: 207 | dw allot_link 208 | dw 2, ".s " 209 | print_stack: 210 | call docol 211 | dw lit, '<', emit, depth, u_dot_, lit, '>', emit, space 212 | dw sp_fetch 213 | print_stack_loop: 214 | dw dup, sz, one_minus, less_than 215 | dw zjump, print_stack_done 216 | 217 | dw dup, fetch, u_dot, one_plus 218 | dw jump, print_stack_loop 219 | print_stack_done: 220 | dw drop, exit 221 | 222 | not_found: 223 | dw lit, word_buffer, puts 224 | dw lit, not_found_msg, puts, halt 225 | 226 | check_underflow: 227 | cmp sp, [stack_zero_prog] 228 | je report_underflow 229 | jmp next 230 | report_underflow: 231 | mov r0, stack_underflow_msg 232 | call write_string 233 | hlt 234 | jmp start 235 | 236 | stack_underflow_msg: 237 | dw 0x1000, 0x200C, "Stack underflow.", 0 238 | 239 | welcome_msg: 240 | dw 0x1000, 0x200E, "---R216 Forth---", 0 241 | 242 | bytes_free_msg: 243 | dw 0x200E, "cells left", 0 244 | 245 | ;; Word to be run on boot 246 | welcome_proc: 247 | call docol 248 | dw lit, welcome_msg, puts 249 | dw lit, 0x1010, term_send 250 | dw lit, 0x200A, term_send 251 | 252 | dw unused, d_dot, lit, bytes_free_msg, puts 253 | dw exit 254 | 255 | inputdata_prompt: 256 | dw 0x1020, 0x200F, "> ", 0 257 | dw 0 258 | 259 | ;; DATA 260 | var_base: 261 | dw 10 262 | 263 | decimal_link: 264 | dw qdup_link 265 | dw 7, "dec" 266 | decimal: 267 | mov [var_base], 10 268 | jmp next 269 | 270 | hex_link: 271 | dw rbrac_link 272 | dw 3, "hex" 273 | hex: 274 | mov r4, 16 275 | mov [var_base], r4 276 | jmp next 277 | 278 | 279 | latest_link: 280 | dw puts_link 281 | dw 6, "lat" 282 | ;; CODE 283 | latest: 284 | push r0 285 | mov r0, var_latest 286 | jmp next 287 | 288 | base_link: 289 | dw 0 290 | dw 4, "bas" 291 | ;; CODE 292 | base: 293 | push r0 294 | mov r0, var_base 295 | jmp next 296 | 297 | bool_xor_link: 298 | dw drop_link 299 | dw 3, "xor" 300 | bool_xor: 301 | pop r4 302 | xor r0, r4 303 | jmp next 304 | 305 | bool_and_link: 306 | dw if_link 307 | dw 3, "and" 308 | ;; CODE 309 | bool_and: 310 | pop r4 311 | and r0, r4 312 | jmp next 313 | 314 | ;; strcmp: 315 | ;; pop r4 316 | ;; mov r5, [r0 + 0] 317 | ;; cmp r5, [r4 + 0] 318 | ;; jnz false 319 | ;; mov r5, [r0 + 1] 320 | ;; cmp r5, [r4 + 1] 321 | ;; jnz false 322 | ;; mov r5, [r0 + 2] 323 | ;; cmp r5, [r4 + 2] 324 | ;; jnz false 325 | ;; jmp true 326 | 327 | ;;; When adding words, append them to the linked list starting at .b00, then follow the advice of htcheck.lua: 328 | ;;; 329 | ;;; $ path/to/tptasm/main.lua model=R2... target=prog.bin export_labels=prog.labels prog.asm 330 | ;;; $ path/to/htcheck.lua prog.bin prog.labels 331 | ;;; star_link is in bucket 0x00, should be in bucket 0x16 332 | ;;; 333 | ;;; which would mean that star_link would have to be unlinked from .b00 and appended to .b16. 334 | find_hashtable: 335 | .b00: dw base_link 336 | .b01: dw latest_link 337 | .b02: dw plus_store_link 338 | .b03: dw qimmed_link 339 | .b04: dw fetch_link 340 | .b05: dw depth_link 341 | .b06: dw min_link 342 | .b07: dw bool_and_link 343 | .b08: dw comma_link 344 | .b09: dw bool_xor_link 345 | .b0A: dw store_byte_link 346 | .b0B: dw sz_link 347 | .b0C: dw create_link 348 | .b0D: dw dup_link 349 | .b0E: dw loop_index_two_link 350 | .b0F: dw sp_fetch_link 351 | .b10: dw rdrop_link 352 | .b11: dw find_link 353 | .b12: dw one_plus_link 354 | .b13: dw to_link 355 | .b14: dw one_minus_link 356 | .b15: dw print_stack_link 357 | .b16: dw unused_link 358 | .b17: dw div_link 359 | .b18: dw less_than_link 360 | .b19: dw hex_link 361 | .b1A: dw r_fetch_link 362 | .b1B: dw nip_link 363 | .b1C: dw do_loop_link 364 | .b1D: dw div_mod_link 365 | .b1E: dw decimal_link 366 | .b1F: dw lbrac_link 367 | 368 | ;; Find a word 369 | ;; ( str_addr len -- xt | 0 ) 370 | ;; CODE 371 | find_link: 372 | dw two_plus_link 373 | dw 4, "fin" 374 | find: 375 | ;; String length 376 | mov r9, r0 377 | pop r11 378 | 379 | mov r4, r9 380 | shl r4, 2 381 | mov r5, .compare_0 382 | sub r5, r9 383 | cmp r9, 3 384 | jb r5 385 | xor r4, [r11 + 2] 386 | xor r4, [r11 + 1] 387 | xor r4, [r11 + 0] 388 | ;; the jb r5 jumps here or to one of the three xors above 389 | ;; or nowhere at all if r9 >= 3, thereby executing all three xors 390 | .compare_0: 391 | and r4, 0x1F 392 | ;; r4 points to the entry we're searching 393 | ;; Get the address of the latest word and skip the link 394 | ;; pointer. 395 | mov r4, [r4+find_hashtable] 396 | jz false 397 | find_restart: 398 | mov r5, r4 399 | add r5, 1 400 | mov r5, [r5] 401 | ;; Check if hidden. 402 | ands r5, 64 403 | ;; Yes, skip it and continue traversing the linked list. 404 | jnz find_loop 405 | ;; No, check length. 406 | ;; Remove flag data except for length. 407 | and r5, 31 408 | ;; Same length? 409 | cmp r5, r9 410 | ;; Yes, compare strings. 411 | je find_cmp_string 412 | ;; No, continue searching. 413 | jmp find_loop 414 | find_cmp_string: 415 | mov r7, r11 416 | mov r6, r4 417 | add r6, 2 418 | ;; r6 now points at the beginning of the name field 419 | mov r8, [r6 + 0] 420 | cmp r8, [r7 + 0] 421 | jne find_loop 422 | cmp r9, 1 423 | je find_succ 424 | 425 | mov r8, [r6 + 1] 426 | cmp r8, [r7 + 1] 427 | jne find_loop 428 | cmp r9, 2 429 | je find_succ 430 | 431 | mov r8, [r6 + 2] 432 | cmp r8, [r7 + 2] 433 | jne find_loop 434 | ;; We found it! 435 | find_succ: 436 | mov r0, r4 437 | jmp next 438 | 439 | find_loop: 440 | ;; Deference the pointer 441 | mov r4, [r4] 442 | ;; Hit null pointer. 443 | jz false 444 | jmp find_restart 445 | 446 | allot_link: 447 | dw swap_link 448 | dw 5, "all" 449 | ;; CODE 450 | allot: 451 | add r3, r0 452 | pop r0 453 | jmp next 454 | 455 | unused_link: 456 | dw space_link 457 | dw 6, "unu" 458 | ;; CODE 459 | unused: 460 | push r0 461 | mov r4, r3 462 | mov r0, [var_here_end] 463 | sub r0, r4 464 | jmp next 465 | 466 | here_link: 467 | dw rp_store_link 468 | dw 4, "her" 469 | ;; CODE 470 | here: 471 | push r0 472 | mov r0, r3 473 | jmp next 474 | 475 | ;;; Aliases, since the R216 has 16-bit cells 476 | fetch_byte_link: 477 | dw to_cfa_link 478 | dw 2, "c@ " 479 | fetch_byte: 480 | jmp fetch 481 | 482 | store_byte_link: 483 | dw mod_link 484 | dw 2, "c! " 485 | store_byte: 486 | jmp store 487 | 488 | fetch_link: 489 | dw minus_store_link 490 | dw 1, "@ " 491 | ;; CODE 492 | fetch: 493 | mov r4, [r0] 494 | mov r0, r4 495 | jmp next 496 | 497 | store_link: 498 | dw zero_equal_link 499 | dw 1, "! " 500 | ;; CODE 501 | store: 502 | pop r4 503 | mov [r0], r4 504 | pop r0 505 | jmp next 506 | 507 | comma_link: 508 | dw recurse_link 509 | dw 1, ", " 510 | comma: 511 | mov [r3], r0 512 | pop r0 513 | add r3, 1 514 | jmp next 515 | 516 | plus_store_link: 517 | dw qhidden_link 518 | dw 2, "+! " 519 | ;; CODE 520 | plus_store: 521 | pop r4 522 | add [r0], r4 523 | pop r0 524 | jmp next 525 | 526 | minus_store_link: 527 | dw to_r_link 528 | dw 2, "-! " 529 | ;; CODE 530 | minus_store: 531 | pop r4 532 | sub [r0], r4 533 | pop r0 534 | jmp next 535 | 536 | ;; unsigned divide r4 by r5 (doesn't handle division by 0) 537 | ;; quotient is r4, remainder is r6; clobbers r7 and r8 538 | ;; CODE 539 | udiv1616: 540 | mov r6, 0 541 | mov r7, 0 542 | mov r8, 16 543 | .loop: 544 | shl r7, 1 545 | add r4, r4 546 | adc r6, r6 547 | jc .subtract_due_to_carry 548 | cmp r6, r5 549 | jnae .no_subtract 550 | .subtract_due_to_carry: 551 | sub r6, r5 552 | or r7, 1 553 | .no_subtract: 554 | sub r8, 1 555 | jnz .loop 556 | mov r4, r7 557 | ret 558 | 559 | to_r_link: 560 | dw r_from_link 561 | dw 2, ">r " 562 | to_r: 563 | sub r2, 1 564 | mov [r2], r0 565 | pop r0 566 | jmp next 567 | 568 | r_from_link: 569 | dw execute_link 570 | dw 2, "r> " 571 | r_from: 572 | push r0 573 | mov r0, [r2] 574 | add r2, 1 575 | jmp next 576 | 577 | rp_store_link: 578 | dw value_link 579 | dw 3, "rp!" 580 | rp_store: 581 | mov r2, r0 582 | pop r0 583 | jmp next 584 | 585 | r_fetch_link: 586 | dw greater_than_link 587 | dw 2, "r@ " 588 | r_fetch: 589 | push r0 590 | mov r0, [r2] 591 | jmp next 592 | 593 | rp_fetch_link: 594 | dw times_link 595 | dw 3, "rp@" 596 | rp_fetch: 597 | push r0 598 | mov r0, r2 599 | jmp next 600 | 601 | div_mod_link: 602 | dw immed_link 603 | dw 4, "/mo" 604 | div_mod: 605 | pop r4 606 | mov r5, r0 607 | call udiv1616 608 | mov r0, r4 609 | push r6 610 | jmp next 611 | 612 | left_shift: 613 | add r0, r0 614 | jmp next 615 | 616 | right_shift: 617 | shr r0, 1 618 | jmp next 619 | 620 | nip_link: 621 | dw key_link 622 | dw 3, "nip" 623 | nip: 624 | pop r4 625 | jmp next 626 | 627 | mod_link: 628 | dw dot_link 629 | dw 3, "mod" 630 | mod: 631 | call docol 632 | dw div_mod, drop, exit 633 | 634 | div_link: 635 | dw two_minus_link 636 | dw 3, "div" 637 | div: 638 | call docol 639 | dw div_mod, nip, exit 640 | 641 | space_link: 642 | dw star_link 643 | dw 5, "spa" 644 | space: 645 | send r10, 32 646 | jmp next 647 | 648 | u_dot_: 649 | call docol 650 | dw base, fetch, div_mod, qdup, zbranch, 2, u_dot_ 651 | dw dup, lit, 10, less_than, zbranch, 5, lit, '0' 652 | dw branch, 6, lit, 10, minus, lit, 'A', plus 653 | dw emit 654 | dw exit 655 | 656 | uwidth: 657 | call docol 658 | dw base, fetch, div, qdup, zbranch, 5, uwidth, one_plus 659 | dw branch, 3, lit, 1, exit 660 | 661 | ;;; Writing instructions means that we have to access the full 29 bits 662 | ;;; Diagram of the situation: 663 | ;;; SWM (set write mask) takes the least 13 significant bits from the 664 | ;;; operand and sets the write mask to that 665 | 666 | ;;; SWM xxxnnnnnnnnnnnnn 667 | ;;; \-----------/ 668 | ;;; | 669 | ;;; +-- [ part that gets written into the write mask ] 670 | 671 | ;;; Let's say DOCOL's address is 593 in base 10, then. 672 | ;;; The bits of the cell that corresponds to CALL DOCOL should look 673 | ;;; like this: 674 | ;;; 111110001000000010010100010000 675 | ;;; \------------/\--------------/ 676 | ;;; | | 677 | ;;; [CALL opcode] +- [ address of DOCOL left shifted by 4 ] 678 | 679 | ;;; But here's the challenge: we can only write to the first 16 bits! 680 | ;;; 681 | 682 | ;;; 683 | ;;; [ the part SWM can write to ] 684 | ;;; | 685 | ;;; | +--- [ the part we can write to ] 686 | ;;; | | 687 | ;;; | | 688 | ;;; | | 689 | ;;; /------------\/--------------\ 690 | ;;; 111110001000000010010100010000 691 | ;;; \------------/\--------------/ 692 | ;;; | | 693 | ;;; [CALL opcode] +----- [ address of DOCOL ] 694 | 695 | ;;; If DOCOL's address is high enough we'll need to handle that, as 696 | ;;; a couple of its significant bits might end up in the SWM region, 697 | ;;; but to keep it simple let's make sure DOCOL is below 2^11 698 | 699 | ;; ( addr length -- ) 700 | ;; Parse the next word and create a definition header for it. 701 | create_asm: 702 | ;; Write the link pointer first 703 | mov r4, [var_latest] 704 | mov [r3], r4 705 | mov [var_latest], r3 706 | mov r4, docol 707 | ;; Main cell content 708 | shl r4, 4 709 | 710 | swm 15904 711 | ;; Write CALL DOCOL at offset 5 712 | mov [r3 + 5], r4 713 | ;; Reset write mask 714 | swm 0 715 | 716 | ;; Write the length 717 | mov [r3 + 1], r0 718 | pop r6 719 | 720 | ;; Write the first three characters of the name 721 | mov r4, r0 722 | shl r4, 2 723 | mov r5, .write_0 724 | sub r5, r0 725 | sub r5, r0 726 | sub r5, r0 727 | cmp r0, 3 728 | jb r5 729 | mov r5, [r6 + 2] 730 | xor r4, r5 731 | mov [r3 + 4], r5 732 | mov r5, [r6 + 1] 733 | xor r4, r5 734 | mov [r3 + 3], r5 735 | mov r5, [r6] 736 | xor r4, r5 737 | mov [r3 + 2], r5 738 | ;; the jb r5 jumps here or to one of the three mov r5, [r6 + k]s above 739 | ;; or nowhere at all if r0 >= 3, thereby executing all three xors and moves 740 | .write_0: 741 | and r4, 0x1F 742 | mov [r4+find_hashtable], r3 743 | 744 | pop r0 745 | add r3, 6 746 | jmp next 747 | 748 | create_link: 749 | dw over_link 750 | dw 6, "cre" 751 | ;; CODE 752 | create: 753 | call docol 754 | dw word 755 | ;; DEBUG PRINT 756 | dw lit, word_buffer, puts, space 757 | dw create_asm, exit 758 | 759 | immed_link: 760 | dw hidden_link 761 | dw 5, "imm" 762 | ;; CODE 763 | immed: 764 | mov r4, r0 765 | mov r5, 128 766 | xor [r4+1], r5 767 | pop r0 768 | jmp next 769 | 770 | mov r4, 128 771 | ands [r0], r4 772 | jnz true 773 | jz false 774 | 775 | qimmed_link: 776 | dw run_tick_link 777 | dw 6, "?im" 778 | ;; CODE 779 | qimmed: 780 | mov r0, [r0+1] 781 | ands r0, 128 782 | jnz true 783 | jz false 784 | 785 | hidden_link: 786 | dw divmod_link 787 | dw 6, "hid" 788 | ;; CODE 789 | hidden: 790 | mov r4, r0 791 | mov r5, 64 792 | xor [r4+1], r5 793 | pop r0 794 | jmp next 795 | 796 | qhidden_link: 797 | dw constant_link 798 | dw 7, "?hi" 799 | ;; CODE 800 | qhidden: 801 | mov r0, [r0+1] 802 | ands r0, 64 803 | jnz true 804 | jz false 805 | 806 | lbrac_link: 807 | dw semicolon_link 808 | dw 129, "[ " 809 | ;; IMMEDIATE CODE 810 | lbrac: 811 | mov [var_state], 0 812 | jmp next 813 | 814 | rbrac_link: 815 | dw equal_link 816 | dw 1, "] " 817 | ;; CODE 818 | rbrac: 819 | mov [var_state], 1 820 | jmp next 821 | 822 | constant_link: 823 | dw d_dot_link 824 | dw 8, "con" 825 | ;; CODE 826 | constant: 827 | jmp value 828 | 829 | value_link: 830 | dw plus_link 831 | dw 5, "val" 832 | ;; WORD 833 | value: 834 | call docol 835 | dw create, tick, lit, comma, comma, tick, exit, comma, exit 836 | 837 | to_link: 838 | dw u_dot_link 839 | dw 130, "to " 840 | ;; IMMEDIATE WORD 841 | to: 842 | call docol 843 | dw word, find, to_dfa, one_plus, state, fetch 844 | dw zbranch, 10, tick, lit, comma, comma 845 | dw tick, store, comma, branch, 2, store, exit 846 | 847 | dot_link: 848 | dw not_equal_link 849 | dw 1, ". " 850 | ;; CODE 851 | dot: 852 | jmp d_dot 853 | 854 | ;;; Much faster than U. but only for base 10. 855 | d_dot_link: 856 | dw erase_link 857 | dw 2, "d. " 858 | ;; CODE 859 | d_dot: 860 | ;;; Written by LBPHacker 861 | ;;; unsigned render r4 into zero-terminated bcd 862 | ;;; r5 is set to point to result (owned by the subroutine, don't write to it) 863 | ;;; clobbers r4, r6, r7 and r8 864 | tozstringu16: 865 | mov r4, r0 866 | test r4, r4 867 | jz .r4_zero 868 | mov r5, 0 869 | mov r6, 0 870 | mov r7, 16 871 | .loop: 872 | shl r4, 1 873 | scl r5, 1 874 | scl r6, 1 875 | sub r7, 1 876 | jz .loop_done 877 | mov r8, r5 878 | ror r5, 1 879 | or r8, r5 880 | ror r5, 1 881 | and r8, r5 882 | ror r5, 1 883 | or r8, r5 884 | rol r5, 3 885 | and r8, 0x1111 886 | add r5, r8 887 | add r5, r8 888 | add r5, r8 889 | jmp .loop 890 | .loop_done: 891 | mov r7, .output_4 892 | mov [r7], r5 893 | and [r7], 15 894 | add [r7], '0' 895 | shr r5, 4 896 | sub r7, 1 897 | mov [r7], r5 898 | and [r7], 15 899 | add [r7], '0' 900 | shr r5, 4 901 | sub r7, 1 902 | mov [r7], r5 903 | and [r7], 15 904 | add [r7], '0' 905 | shr r5, 4 906 | add r5, '0' 907 | sub r7, 1 908 | mov [r7], r5 909 | add r6, '0' 910 | sub r7, 1 911 | mov [r7], r6 912 | mov r5, r7 913 | .find_head: 914 | cmp [r5], '0' 915 | jne .done 916 | add r5, 1 917 | jmp .find_head 918 | .done: 919 | jmp print_d_dot 920 | .r4_zero: 921 | mov r5, .output_0 922 | add r5, 4 923 | mov [r5], '0' 924 | jmp print_d_dot 925 | .output_0: dw 0 926 | .output_1: dw 0 927 | .output_2: dw 0 928 | .output_3: dw 0 929 | .output_4: dw 0 930 | .output_z: dw 0 931 | 932 | print_d_dot: 933 | mov r0, r5 934 | call write_string 935 | ;; Space at the end 936 | send r10, 32 937 | pop r0 938 | jmp next 939 | 940 | u_dot_link: 941 | dw two_dup_link 942 | dw 2, "u. " 943 | ;; WORD 944 | u_dot: 945 | call docol 946 | dw u_dot_, space, exit 947 | 948 | qdup_link: 949 | dw zero_not_equal_link 950 | dw 4, "?du" 951 | ;; CODE 952 | qdup: 953 | cmp r0, 0 954 | je next 955 | push r0 956 | jmp next 957 | 958 | true: 959 | mov r0, 1 960 | jmp next 961 | 962 | false: 963 | mov r0, 0 964 | jmp next 965 | 966 | less_than_link: 967 | dw max_link 968 | dw 1, "< " 969 | ;; CODE 970 | less_than: 971 | pop r4 972 | cmp r4, r0 973 | jl true 974 | jmp false 975 | 976 | greater_than_link: 977 | dw word_link 978 | dw 1, "> " 979 | ;; CODE 980 | greater_than: 981 | pop r4 982 | cmp r4, r0 983 | jg true 984 | jmp false 985 | 986 | equal_link: 987 | dw not_link 988 | dw 1, "= " 989 | ;; CODE 990 | equal: 991 | pop r4 992 | cmp r4, r0 993 | je true 994 | jmp false 995 | 996 | zero_not_equal_link: 997 | dw double_times_link 998 | dw 3, "0<>" 999 | ;; CODE 1000 | zero_not_equal: 1001 | cmp r0, 0 1002 | jne true 1003 | jmp false 1004 | 1005 | zero_equal_link: 1006 | dw rot_link 1007 | dw 2, "0= " 1008 | ;; CODE 1009 | zero_equal: 1010 | cmp r0, 0 1011 | je true 1012 | jmp false 1013 | 1014 | not_equal_link: 1015 | dw pick_link 1016 | dw 2, "<> " 1017 | ;; CODE 1018 | not_equal: 1019 | pop r4 1020 | cmp r4, r0 1021 | jne true 1022 | jmp false 1023 | 1024 | not_link: 1025 | dw s_quote_link 1026 | dw 3, "not" 1027 | ;; CODE 1028 | not: 1029 | mov r4, 65535 1030 | xor r0, r4 1031 | jmp next 1032 | 1033 | dup_link: 1034 | dw tell_link 1035 | dw 3, "dup" 1036 | ;; CODE 1037 | dup: 1038 | push r0 1039 | jmp next 1040 | 1041 | two_dup_link: 1042 | dw again_link 1043 | dw 4, "2du" 1044 | ;; CODE 1045 | two_dup: 1046 | push r0 1047 | push [sp+1] 1048 | jmp next 1049 | 1050 | drop_link: 1051 | dw minus_link 1052 | dw 4, "dro" 1053 | ;; CODE 1054 | drop: 1055 | pop r0 1056 | jmp next 1057 | 1058 | rdrop_link: 1059 | dw two_drop_link 1060 | dw 5, "rdr" 1061 | ;; CODE 1062 | rdrop: 1063 | add r2, 1 1064 | jmp next 1065 | 1066 | two_drop_link: 1067 | dw 0 1068 | dw 5, "2dr" 1069 | ;; CODE 1070 | two_drop: 1071 | pop r0 1072 | pop r0 1073 | jmp next 1074 | 1075 | swap_link: 1076 | dw halt_link 1077 | dw 4, "swa" 1078 | ;; CODE 1079 | swap: 1080 | pop r5 1081 | push r0 1082 | mov r0, r5 1083 | jmp next 1084 | 1085 | pick_link: 1086 | dw tick_link 1087 | dw 4, "pic" 1088 | ;; CODE 1089 | pick: 1090 | mov r0, [sp+r0] 1091 | jmp next 1092 | 1093 | over_link: 1094 | dw origin_link 1095 | dw 4, "ove" 1096 | ;; CODE 1097 | over: 1098 | push r0 1099 | mov r0, [sp+1] 1100 | jmp next 1101 | 1102 | ;; T{ 1 2 3 ROT -> 2 3 1 }T 1103 | rot_link: 1104 | dw 0 1105 | dw 3, "rot" 1106 | ;; CODE 1107 | rot: 1108 | pop r4 1109 | pop r5 1110 | push r4 1111 | push r0 1112 | mov r0, r5 1113 | jmp next 1114 | 1115 | plus_link: 1116 | dw id_dot_link 1117 | dw 1, "+ " 1118 | ;; CODE 1119 | plus: 1120 | pop r4 1121 | add r0, r4 1122 | jmp next 1123 | 1124 | minus_link: 1125 | dw then_link 1126 | dw 1, "- " 1127 | ;; CODE 1128 | minus: 1129 | mov r4, r0 1130 | pop r0 1131 | sub r0, r4 1132 | jmp next 1133 | 1134 | times_link: 1135 | dw number_link 1136 | dw 1, "* " 1137 | ;; CODE 1138 | times: 1139 | ;;; Written by LBPHacker 1140 | ;;; unsigned multiply r4 by r5 1141 | ;;; product is r4; clobbers r5, r6 and r7 1142 | umul1616_16: 1143 | pop r5 1144 | mov [.cache_1l], r0 1145 | mov [.cache_3l], r0 1146 | add r0, r0 1147 | mov [.cache_2l], r0 1148 | add [.cache_3l], r0 1149 | mov r6, 8 1150 | mov r0, 0 1151 | .loop: 1152 | shl r0, 2 1153 | rol r5, 2 1154 | mov r7, r5 1155 | and r7, 3 1156 | add r0, [.cache_0l+r7] 1157 | sub r6, 1 1158 | jnz .loop 1159 | jmp next 1160 | .cache_0l: dw 0 1161 | .cache_1l: dw 0 1162 | .cache_2l: dw 0 1163 | .cache_3l: dw 0 1164 | double_times_link: 1165 | dw colon_link 1166 | dw 3, "um*" 1167 | double_times: 1168 | ;;; Written by LBPHacker 1169 | ;;; unsigned multiply r4 by r5 1170 | ;;; product is r4_32; clobbers r6, r7 and r8 1171 | umul1616: 1172 | mov r4, r0 1173 | pop r5 1174 | mov [.cache_1l], r5 1175 | mov [.cache_3l], r5 1176 | mov [.cache_3h], 0 1177 | mov r6, 0 1178 | add r5, r5 1179 | adc r6, 0 1180 | mov [.cache_2l], r5 1181 | mov [.cache_2h], r6 1182 | add [.cache_3l], r5 1183 | adc [.cache_3h], r6 1184 | mov r7, r4 1185 | mov r6, 8 1186 | mov r5, 0 1187 | mov r4, 0 1188 | .loop: 1189 | shl r4, 2 1190 | scl r5, 2 1191 | rol r7, 2 1192 | mov r8, r7 1193 | and r8, 3 1194 | add r4, [.cache_0l+r8] 1195 | adc r5, [.cache_0h+r8] 1196 | sub r6, 1 1197 | jnz .loop 1198 | push r4 1199 | mov r0, r5 1200 | jmp next 1201 | .cache_0l: dw 0 1202 | .cache_1l: dw 0 1203 | .cache_2l: dw 0 1204 | .cache_3l: dw 0 1205 | .cache_0h: dw 0 1206 | .cache_1h: dw 0 1207 | .cache_2h: dw 0 1208 | .cache_3h: dw 0 1209 | 1210 | one_minus_link: 1211 | dw begin_link 1212 | dw 2, "1- " 1213 | ;; CODE 1214 | one_minus: 1215 | sub r0, 1 1216 | jmp next 1217 | 1218 | one_plus_link: 1219 | dw 0 1220 | dw 2, "1+ " 1221 | ;; CODE 1222 | one_plus: 1223 | add r0, 1 1224 | jmp next 1225 | 1226 | two_minus_link: 1227 | dw 0 1228 | dw 2, "2- " 1229 | ;; CODE 1230 | two_minus: 1231 | sub r0, 2 1232 | jmp next 1233 | 1234 | two_plus_link: 1235 | dw emit_link 1236 | dw 2, "2+ " 1237 | ;; CODE 1238 | two_plus: 1239 | add r0, 2 1240 | jmp next 1241 | 1242 | branch: 1243 | mov r4, [r1] 1244 | add r1, r4 1245 | jmp next 1246 | 1247 | zbranch: 1248 | cmp r0, 0 1249 | je zbranch_succ 1250 | pop r0 1251 | add r1, 1 1252 | jmp next 1253 | 1254 | zbranch_succ: 1255 | pop r0 1256 | mov r4, [r1] 1257 | add r1, r4 1258 | jmp next 1259 | 1260 | jump: 1261 | mov r4, [r1] 1262 | mov r1, r4 1263 | jmp next 1264 | 1265 | zjump: 1266 | cmp r0, 0 1267 | je zjump_succ 1268 | pop r0 1269 | add r1, 1 1270 | jmp next 1271 | 1272 | zjump_succ: 1273 | pop r0 1274 | mov r4, [r1] 1275 | add r1, 1 1276 | mov r1, r4 1277 | jmp next 1278 | 1279 | 1280 | ;; ( addr count cursor -- ) 1281 | getline: 1282 | mov r11, r0 1283 | mov r6, r1 1284 | pop r1 1285 | mov r7, 0x200F 1286 | pop r0 1287 | 1288 | ;; Save r1 1289 | push r6 1290 | call read_string 1291 | ;; Restore r1 1292 | pop r1 1293 | ;; New TOS 1294 | pop r0 1295 | jmp next 1296 | 1297 | ;; GETC to be called via other Forth words 1298 | getc: 1299 | call docol 1300 | dw lit, input_ptr, fetch, fetch 1301 | dw lit, 1, lit, input_ptr, plus_store 1302 | dw exit 1303 | 1304 | ;; GETC to be called by assembly 1305 | ;; Stores result in r5 1306 | ;; Clobbers r9 1307 | getc_asm: 1308 | mov r9, [input_ptr] 1309 | mov r5, [r9] 1310 | add r9, 1 1311 | mov [input_ptr], r9 1312 | ret 1313 | 1314 | 1315 | key_link: 1316 | dw until_link 1317 | dw 3, "key" 1318 | ;; CODE 1319 | key: 1320 | push r0 1321 | call read_character 1322 | jmp next 1323 | 1324 | ;;; 1 is success, 0 is failure 1325 | num_status: 1326 | dw 0 1327 | 1328 | number_link: 1329 | dw 0 1330 | dw 6, "num" 1331 | ;; CODE 1332 | number: 1333 | ;;; Written by LBPHacker 1334 | ;;; unsigned parse zero-terminated bcd pointed to by r4 into r5 1335 | ;;; carry flag is set if something goes wrong, clear otherwise 1336 | ;;; clobbers r4, r6 and r7 1337 | mov r4, r0 1338 | fromzstringu16: 1339 | mov r5, 0 1340 | cmp [r4], 0 1341 | je .err_empty 1342 | .loop: 1343 | mov r6, [r4] 1344 | test r6, r6 1345 | jnz .not_done 1346 | mov r4, 0 1347 | jmp .done 1348 | .not_done: 1349 | add r4, 1 1350 | sub r6, '0' 1351 | jc .err_nondigit 1352 | cmp r6, 9 1353 | ja .err_nondigit 1354 | cmp r5, 6553 1355 | ja .err_overflow 1356 | shl r5, 1 1357 | mov r7, r5 1358 | shl r5, 2 1359 | add r5, r7 1360 | add r5, r6 1361 | jc .err_overflow 1362 | jmp .loop 1363 | .err_empty: 1364 | .err_nondigit: 1365 | .err_overflow: 1366 | mov [num_status], 0 1367 | jmp next 1368 | .done: 1369 | mov [num_status], 1 1370 | add r4, 0xFFFF 1371 | mov r0, r5 1372 | jmp next 1373 | 1374 | max_link: 1375 | dw 0 1376 | dw 3, "max" 1377 | ;; CODE 1378 | max: 1379 | pop r4 1380 | cmp r4, r0 1381 | jl next 1382 | mov r0, r4 1383 | jmp next 1384 | 1385 | min_link: 1386 | dw page_link 1387 | dw 3, "min" 1388 | ;; CODE 1389 | min: 1390 | pop r4 1391 | cmp r4, r0 1392 | jg next 1393 | mov r0, r4 1394 | jmp next 1395 | ; word_ptr: 1396 | ; dw 0 1397 | word_buffer: 1398 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 1399 | word_link: 1400 | dw throw_link 1401 | dw 4, "wor" 1402 | ;; LINK 1403 | word: 1404 | ;; r6: word pointer 1405 | ;; r4: character point 1406 | ;; r5: return from getc_asm 1407 | ;; r7: first indirection of word_ptr 1408 | ;; Used to be a WORD word but has been rewritten in assembly for speed. 1409 | ;; dw lit, word_buffer, lit, word_ptr, store 1410 | mov r7, word_buffer 1411 | mov r4, 0 1412 | skip_space: 1413 | call getc_asm 1414 | ;; dw qdup, zjump, empty_word 1415 | cmp r5, 0 1416 | je empty_word 1417 | ;; dw dup, lit, 32, not_equal 1418 | ;; dw zjump, skip_space 1419 | cmp r5, 32 1420 | je skip_space 1421 | 1422 | ;; Possibly add more space characters to skip 1423 | ;; dw jump, actual_word 1424 | jmp actual_word 1425 | 1426 | actual_word: 1427 | ;; dw lit, word_ptr, fetch, store 1428 | mov [r7], r5 1429 | ;; Increase character count 1430 | add r4, 1 1431 | ;; dw lit, 1, lit, word_ptr, plus_store 1432 | add r7, 1 1433 | 1434 | actual_word_loop: 1435 | ;; dw getc 1436 | call getc_asm 1437 | ;; dw dup, zjump, word_done 1438 | cmp r5, 0 1439 | je word_done 1440 | 1441 | ;; dw dup, lit, 32, not_equal, zjump, word_done 1442 | cmp r5, 32 1443 | je word_done 1444 | ;; dw jump, actual_word 1445 | jmp actual_word 1446 | 1447 | word_done: 1448 | push r0 1449 | push word_buffer 1450 | mov r0, r4 1451 | ;; dw lit, 0, lit, word_ptr, fetch, store 1452 | mov [r7], 0 1453 | jmp next 1454 | 1455 | empty_word: 1456 | mov r0, 0 1457 | jmp next 1458 | 1459 | divmod_link: 1460 | dw lit_link 1461 | dw 4, "/mo" 1462 | ;; CODE 1463 | divmod: 1464 | pop r5 1465 | mov r6, 0 1466 | mov r6, 16 1467 | 1468 | jmp next 1469 | 1470 | origin_link: 1471 | dw to_dfa_link 1472 | dw 6, "ori" 1473 | ;; CODE 1474 | origin: 1475 | send r10, 0x1000 1476 | jmp next 1477 | 1478 | page_link: 1479 | dw 0 1480 | dw 4, "pag" 1481 | ;; CODE 1482 | page: 1483 | send r10, 0x1000 1484 | mov r4, 192 1485 | page_loop: 1486 | send r10, 32 1487 | sub r4, 1 1488 | jnz page_loop 1489 | ;; Reset cursor to origin 1490 | send r10, 0x1000 1491 | jmp next 1492 | 1493 | ;;; Print a character. 1494 | ;;; ( c -- ) 1495 | emit_link: 1496 | dw 0 1497 | dw 4, "emi" 1498 | ;; CODE 1499 | emit: 1500 | send r10, r0 1501 | pop r0 1502 | jmp next 1503 | 1504 | ;; Send a message to the terminal. 1505 | ;; ( n -- ) 1506 | term_send: 1507 | send r10, r0 1508 | pop r0 1509 | jmp next 1510 | 1511 | exec_msg: 1512 | dw 0x200F, "Executing ", 0 1513 | not_found_msg: 1514 | dw 0x200F, " not found! ", 0 1515 | 1516 | to_dfa_link: 1517 | dw 0 1518 | dw 4, ">df" 1519 | ;; CODE 1520 | to_dfa: 1521 | add r0, 6 1522 | jmp next 1523 | 1524 | to_cfa_link: 1525 | dw 0 1526 | dw 4, ">cf" 1527 | ;; CODE 1528 | to_cfa: 1529 | add r0, 5 1530 | jmp next 1531 | 1532 | erase_link: 1533 | dw catch_link 1534 | dw 5, "era" 1535 | ;; CODE 1536 | erase: 1537 | pop r4 1538 | erase_loop: 1539 | cmp r0, 0 1540 | je erase_done 1541 | sub r0, 1 1542 | mov [r4], 0 1543 | add r4, 1 1544 | jmp erase_loop 1545 | 1546 | erase_done: 1547 | pop r0 1548 | jmp next 1549 | 1550 | execute_link: 1551 | dw dot_quote_link 1552 | dw 7, "exe" 1553 | ;; CODE 1554 | execute: 1555 | mov r4, r0 1556 | pop r0 1557 | jmp r4 1558 | 1559 | recurse_link: 1560 | dw 0 1561 | dw 135, "rec" 1562 | ;; IMMEDIATE WORD 1563 | recurse: 1564 | call docol 1565 | dw latest, fetch, to_cfa, comma, exit 1566 | 1567 | 1568 | var_handler: 1569 | dw 0 1570 | handler: 1571 | push r0 1572 | mov r0, var_handler 1573 | jmp next 1574 | 1575 | catch_link: 1576 | dw while_link 1577 | dw 5, "cat" 1578 | ;; WORD 1579 | catch: 1580 | call docol 1581 | dw sp_fetch, to_r, handler, fetch, to_r, rp_fetch 1582 | dw handler, store, execute, r_from, handler, store 1583 | dw r_from, drop, lit, 0, exit 1584 | 1585 | throw_link: 1586 | dw 0 1587 | dw 5, "thr" 1588 | ;; WORD 1589 | throw: 1590 | call docol 1591 | dw qdup, zbranch, 13, handler, fetch, rp_store, r_from 1592 | dw handler, store, r_from, swap, to_r, sp_store, drop 1593 | dw r_from, exit 1594 | 1595 | puts_link: 1596 | dw 0 1597 | dw 4, "put" 1598 | ;; CODE 1599 | puts: 1600 | call write_string 1601 | pop r0 1602 | jmp next 1603 | 1604 | 1605 | id_dot_link: 1606 | dw 0 1607 | dw 3, "id." 1608 | ;; CODE 1609 | id_dot: 1610 | add r0, 2 1611 | send r10, [r0] 1612 | send r10, [r0+1] 1613 | send r10, [r0+2] 1614 | pop r0 1615 | jmp next 1616 | 1617 | lit_link: 1618 | dw 0 1619 | dw 3, "lit" 1620 | ;; CODE 1621 | lit: 1622 | push r0 1623 | mov r0, [r1] 1624 | add r1, 1 1625 | jmp next 1626 | 1627 | litstring: 1628 | push r0 1629 | ;; Push address of string 1630 | ;; Push length of string 1631 | mov r0, [r1] 1632 | add r1, 1 1633 | push r1 1634 | 1635 | add r1, r0 1636 | add r1, 1 1637 | jmp next 1638 | 1639 | tell_link: 1640 | dw loop_index_link 1641 | dw 4, "tel" 1642 | ;; CODE 1643 | tell: 1644 | pop r0 1645 | call write_string 1646 | jmp next 1647 | 1648 | s_quote_link: 1649 | dw 0 1650 | dw 130, "s", 34, " " 1651 | ;; IMMEDIATE WORD 1652 | s_quote: 1653 | call docol 1654 | dw state, fetch, zbranch, 33, tick, litstring, comma, here 1655 | dw lit, 0, comma, getc, dup, lit, 34, not_equal, zbranch, 4 1656 | dw comma, branch, 65527, drop, lit, 0, comma, dup, here, swap 1657 | dw minus, lit, 2, minus, swap, store, branch, 19 1658 | dw here, getc, dup, lit, 34, not_equal, zbranch, 6, over 1659 | dw store, one_plus, branch, 65525 1660 | dw drop, here, minus, here, swap, exit 1661 | 1662 | dot_quote_link: 1663 | dw 0 1664 | dw 130, ".", 34, " " 1665 | ;; IMMEDIATE WORD 1666 | dot_quote: 1667 | call docol 1668 | dw state, fetch, zbranch, 7, s_quote, tick, tell, comma, branch, 13 1669 | dw getc, dup, lit, 34, equal, zbranch, 3, drop, exit, emit 1670 | dw branch, 65525, exit 1671 | 1672 | halt_link: 1673 | dw 0 1674 | dw 4, "hal" 1675 | ;; CODE 1676 | halt: 1677 | hlt 1678 | jmp start 1679 | 1680 | ; * Writes zero-terminated strings to the terminal. 1681 | ; * r0 points to buffer to write from. 1682 | ; * r10 is terminal port address. 1683 | ; * r11 is incremented by the number of characters sent to the terminal (which 1684 | ; doesn't help at all if the string contains colour or cursor codes). 1685 | write_string: 1686 | push r0 1687 | push r1 1688 | mov r5, r0 1689 | .loop: 1690 | mov r1, [r0] 1691 | jz .exit 1692 | add r0, 1 1693 | send r10, r1 1694 | jmp .loop 1695 | .exit: 1696 | add r11, r0 1697 | sub r11, r5 1698 | pop r1 1699 | pop r0 1700 | ret 1701 | 1702 | ; * Sends spaces to the terminal. 1703 | ; * r10 holds the number of spaces to send. 1704 | clear_continuous: 1705 | .loop: 1706 | send r10, 32 1707 | sub r0, 1 1708 | jnz .loop 1709 | ret 1710 | 1711 | 1712 | ; * Reads a single character from the terminal. 1713 | ; * Character code is returned in r0. 1714 | ; * r10 is terminal port address. 1715 | read_character: 1716 | .wait_loop: 1717 | wait r8 ; * Wait for a bump. r3 should be checked but 1718 | ; as in this demo there's no other peripheral, 1719 | ; it's fine this way. 1720 | js .wait_loop 1721 | bump r10 ; * Ask for character code. 1722 | .recv_loop: 1723 | recv r0, r10 ; * Receive character code. 1724 | jnc .recv_loop ; * The carry bit it set if something is received. 1725 | ret 1726 | 1727 | ; * Sends spaces to the terminal. 1728 | ; * r10 holds the number of spaces to send. 1729 | clear_continuous: 1730 | .loop: 1731 | send r10, 32 1732 | sub r0, 1 1733 | jnz .loop 1734 | ret 1735 | 1736 | ; * Reads a single character from the terminal while blinking a cursor. 1737 | ; * r6 is cursor colour. 1738 | ; * r10 is terminal port address. 1739 | ; * r11 is cursor position. 1740 | ; * Character read is returned in r8. 1741 | read_character_blink: 1742 | mov r12, 0x7F ; * r12 holds the current cursor character. 1743 | mov r9, 8 ; * r9 is the counter for the blink loop. 1744 | send r10, r6 1745 | send r10, r11 1746 | send r10, r12 ; * Display cursor. 1747 | .wait_loop: 1748 | wait r8 ; * Wait for a bump. r3 should be checked but 1749 | ; as in this demo there's no other peripheral, 1750 | ; it's fine this way. 1751 | jns .got_bump ; * The sign flag is cleared if a bump arrives. 1752 | sub r9, 1 1753 | jnz .wait_loop ; * Back to waiting if it's not time to blink yet. 1754 | xor r12, 0x5F ; * Turn a 0x20 into a 0x7F or vice versa. 1755 | send r10, r6 ; Those are ' ' and a box, respectively. 1756 | send r10, r11 1757 | send r10, r12 ; * Display cursor. 1758 | mov r9, 8 1759 | jmp .wait_loop ; * Back to waiting, unconditionally this time. 1760 | .got_bump: 1761 | bump r10 ; * Ask for character code. 1762 | .recv_loop: 1763 | recv r8, r10 ; * Receive character code. 1764 | jnc .recv_loop ; * The carry bit it set if something is received. 1765 | ret 1766 | 1767 | 1768 | 1769 | 1770 | ; * Reads zero-terminated strings from the terminal. 1771 | ; * r0 points to buffer to read into and r1 is the size of the buffer, 1772 | ; including the zero that terminates the string. If you have a 15 cell 1773 | ; buffer, do pass 15 in r1, but expect only 14 characters to be read at most. 1774 | ; * r7 is the default cursor colour (the one used when the buffer is not about 1775 | ; to overflow; when it is, the cursor changes to yellow, 0x200E). 1776 | ; * r10 is terminal port address. 1777 | ; * r11 is cursor position. 1778 | read_string: 1779 | bump r10 ; * Drop whatever is in the input buffer. 1780 | mov r5, r1 1781 | sub r5, 1 ; * The size of the buffer includes the 1782 | ; terminating zero, so the character limit 1783 | ; should be one less than this size. 1784 | mov r6, r7 ; * Reset the default cursor colour. 1785 | mov r1, 0 ; * r1 holds the number of characters read. 1786 | .read_character: 1787 | call read_character_blink 1788 | cmp r8, 13 ; * Check for the Return key. 1789 | je .got_return 1790 | cmp r8, 8 ; * Check for the Backspace key. 1791 | je .got_backspace 1792 | cmp r5, r1 ; * Check if whatever else we got fits the buffer. 1793 | je .read_character 1794 | send r10, r11 ; * If it does, display it and add it to the 1795 | send r10, r8 ; buffer. 1796 | add r11, 1 1797 | mov [r0+r1], r8 1798 | add r1, 1 1799 | cmp r5, r1 1800 | ja .read_character ; * Change cursor colour to yellow if the buffer 1801 | mov r6, 0x200E ; is full. 1802 | jmp .read_character ; * Back to waiting. 1803 | .got_backspace: 1804 | cmp r1, 0 ; * Only delete a character if there is at least 1805 | je .read_character ; one to delete. 1806 | mov r6, r7 ; * Reset the default cursor colour. 1807 | send r10, r11 1808 | send r10, 0x20 ; * Clear the previous position of the cursor. 1809 | sub r11, 1 1810 | sub r1, 1 1811 | jmp .read_character ; * Back to waiting. 1812 | .got_return: 1813 | send r10, r11 1814 | send r10, 0x20 ; * Clear the previous position of the cursor. 1815 | mov [r0+r1], 0 ; * Terminate string explicitly. 1816 | mov [input_len], r1 1817 | add r1, 1 1818 | mov [r0+r1], 0 ; * Terminate string explicitly (again for WORD) 1819 | ret 1820 | 1821 | ;; Same code as LIT 1822 | ;; We use TICK to quote words instead of numeric literals. 1823 | tick_link: 1824 | dw else_link 1825 | dw 3, "(')" 1826 | ;; CODE 1827 | tick: 1828 | push r0 1829 | mov r0, [r1] 1830 | add r1, 1 1831 | jmp next 1832 | 1833 | run_tick_link: 1834 | dw do_link 1835 | dw 1, "' " 1836 | ;; WORD 1837 | run_tick: 1838 | call docol 1839 | dw word, find, to_cfa, exit 1840 | 1841 | colon_link: 1842 | dw 0 1843 | dw 1, ": " 1844 | ;; WORD 1845 | colon: 1846 | call docol 1847 | dw create, latest, fetch 1848 | dw hidden, rbrac, exit 1849 | 1850 | semicolon_link: 1851 | dw repeat_link 1852 | dw 129, "; " 1853 | ;; IMMEDIATE WORD 1854 | semicolon: 1855 | call docol 1856 | dw lit, exit, comma 1857 | dw latest, fetch, hidden 1858 | dw lbrac, exit 1859 | 1860 | if_link: 1861 | dw 0 1862 | dw 130, "if " 1863 | ;; IMMEDIATE WORD 1864 | if: 1865 | call docol 1866 | dw tick, zbranch, comma, here, lit, 0, comma, exit 1867 | 1868 | else_link: 1869 | dw 0 1870 | dw 132, "els" 1871 | ;; IMMEDIATE WORD 1872 | else: 1873 | call docol 1874 | dw tick, branch, comma, here, lit, 0, comma 1875 | dw swap, dup, here, swap, minus, swap, store, exit 1876 | 1877 | then_link: 1878 | dw 0 1879 | dw 132, "the" 1880 | ;; IMMEDIATE WORD 1881 | then: 1882 | call docol 1883 | dw dup, here, swap, minus, swap, store, exit 1884 | 1885 | begin_link: 1886 | dw 0 1887 | dw 133, "beg" 1888 | ;; IMMEDIATE WORD 1889 | begin: 1890 | jmp here 1891 | 1892 | until_link: 1893 | dw 0 1894 | dw 133, "unt" 1895 | ;; IMMEDIATE WORD 1896 | until: 1897 | call docol 1898 | dw tick, zbranch, comma, here, minus, comma, exit 1899 | 1900 | again_link: 1901 | dw 0 1902 | dw 133, "aga" 1903 | ;; IMMEDIATE WORD 1904 | again: 1905 | call docol 1906 | dw tick, branch, comma, here, minus, comma, exit 1907 | 1908 | while_link: 1909 | dw 0 1910 | dw 133, "whi" 1911 | ;; IMMEDIATE WORD 1912 | while: 1913 | call docol 1914 | dw tick, zbranch, comma, here, lit, 0, comma, exit 1915 | 1916 | loop_index_two_link: 1917 | dw sp_store_link 1918 | dw 1, "j " 1919 | ;; CODE 1920 | loop_index_loop: 1921 | push r0 1922 | mov r0, [r2+3] 1923 | jmp next 1924 | 1925 | loop_index_link: 1926 | dw 0 1927 | dw 1, "i " 1928 | ;; CODE 1929 | loop_index: 1930 | push r0 1931 | mov r0, [r2+1] 1932 | jmp next 1933 | 1934 | repeat_link: 1935 | dw 0 1936 | dw 134, "rep" 1937 | ;; IMMEDIATE WORD 1938 | repeat: 1939 | call docol 1940 | dw tick, branch, comma, swap, here, minus, comma 1941 | dw dup, here, swap, minus, swap, store, exit 1942 | 1943 | do_link: 1944 | dw 0 1945 | dw 130, "do " 1946 | ;; IMMEDIATE WORD 1947 | do: 1948 | call docol 1949 | dw here, tick, to_r, comma, tick, to_r, comma, exit 1950 | 1951 | do_loop_link: 1952 | dw leave_link 1953 | dw 132, "loo" 1954 | ;; IMMEDIATE WORD 1955 | do_loop: 1956 | call docol 1957 | dw tick, r_from, comma, tick, r_from, comma, tick, one_plus 1958 | dw comma, tick, two_dup, comma 1959 | dw tick, equal, comma, tick, zbranch, comma, here, minus 1960 | dw comma, tick, two_drop, comma, exit 1961 | 1962 | leave_link: 1963 | dw plus_loop_link 1964 | dw 5, "lea" 1965 | ;; WORD 1966 | leave: 1967 | call docol 1968 | dw r_from, rdrop, drop, to_r 1969 | dw exit 1970 | 1971 | plus_loop_link: 1972 | dw 0 1973 | dw 133, "+lo" 1974 | ;; IMMEDIATE WORD 1975 | plus_loop: 1976 | call docol 1977 | dw tick, r_from, comma, tick, r_from, comma, tick, rot 1978 | dw comma, tick, plus, comma, tick, two_dup, comma, tick 1979 | dw equal, comma, tick, zbranch, comma, here, minus 1980 | dw comma, tick, two_drop, comma, exit 1981 | 1982 | star_link: 1983 | dw 0 1984 | dw 4, "sta" 1985 | ;; WORD 1986 | star: 1987 | call docol 1988 | dw lit, 42, emit, exit 1989 | 1990 | state: 1991 | push r0 1992 | mov r0, var_state 1993 | jmp next 1994 | 1995 | var_here: 1996 | dw here_start 1997 | 1998 | var_here_end: 1999 | dw 0 2000 | 2001 | var_state: 2002 | dw 0 2003 | ;; Latest word to be defined 2004 | var_latest: 2005 | dw star_link 2006 | ;; Length of latest input 2007 | input_len: 2008 | dw 0 2009 | 2010 | input_ptr: 2011 | dw str_buffer 2012 | 2013 | rebooted: 2014 | dw 0 2015 | 2016 | ;; Our "stack zero" to protect against underflow. 2017 | stack_zero_prog: 2018 | dw 0 2019 | 2020 | stack_zero: 2021 | dw 0 2022 | 2023 | ;; Global string buffer. 2024 | ;; 64 characters. 2025 | str_buffer: 2026 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2027 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2028 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2029 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2030 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2031 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2032 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2033 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2034 | 2035 | 2036 | here_start: 2037 | ;; The rest of the memory is free space. 2038 | dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 2039 | -------------------------------------------------------------------------------- /htcheck.lua: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env luajit 2 | 3 | local image_path, labels_path = ... 4 | 5 | local label_to_addr = {} 6 | local addr_to_label = {} 7 | do 8 | local labels_handle = assert(io.open(labels_path, "rb")) 9 | for line in assert(labels_handle:read("*a")):gmatch("[^\r\n]+") do 10 | local label, addr = line:match("^([^ ]+) ([^ ]+)$") 11 | addr = tonumber(addr) 12 | label_to_addr[label] = addr 13 | addr_to_label[addr] = label 14 | end 15 | assert(labels_handle:close()) 16 | end 17 | 18 | local get_data 19 | do 20 | local image_handle = assert(io.open(image_path, "rb")) 21 | function get_data(addr) 22 | assert(image_handle:seek("set", addr * 4)) 23 | local bytes = assert(image_handle:read(4)) 24 | local a0, a1, a2, a3 = string.byte(bytes, 1, 4) 25 | return a0 + a1 * 0x100 26 | end 27 | end 28 | 29 | local function hash_for_link(ptr) 30 | local length = get_data(ptr + 1) 31 | local hash = length * 4 32 | for index = 1, math.min(3, length) do 33 | hash = bit.bxor(hash, get_data(ptr + 1 + index)) 34 | end 35 | hash = bit.band(hash, 0x1F) 36 | return hash 37 | end 38 | 39 | local found = 0 40 | local links = {} 41 | for entry = 0, 31 do 42 | local ptr = get_data(label_to_addr["find_hashtable"] + entry) 43 | while ptr ~= 0 do 44 | found = found + 1 45 | local hash = hash_for_link(ptr) 46 | if hash ~= entry then 47 | print(("%s is in bucket 0x%02X, should be in bucket 0x%02X"):format(addr_to_label[ptr], entry, hash)) 48 | os.exit(1) 49 | end 50 | ptr = get_data(ptr) 51 | end 52 | end 53 | print(("all %i links are good"):format(found)) 54 | -------------------------------------------------------------------------------- /r216-forth.cps: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/r216-forth/3155654ad429e2437d2e8e2bad7ab0c431f7ab7e/r216-forth.cps -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/r216-forth/3155654ad429e2437d2e8e2bad7ab0c431f7ab7e/screenshot.png --------------------------------------------------------------------------------