├── .envrc ├── .github └── workflows │ └── build.yml ├── .gitignore ├── 0A.key ├── LICENSE ├── Makefile ├── PULL_REQUEST_TEMPLATE.md ├── README.md ├── build.scm ├── coverage.org ├── default.nix ├── demo.gif ├── demos └── menu.gif ├── docs ├── design.md ├── ideas.md └── shell.md ├── flake.lock ├── flake.nix ├── key.dot ├── key.png ├── screenshot.png ├── src ├── Makefile ├── assembler.scm ├── boot.fs ├── boot.scm ├── bootstrap-flash1.fs ├── bootstrap-flash2.fs ├── bootstrap-flash3.fs ├── bootstrap-flash4.fs ├── bootstrap-flash5.fs ├── display.scm ├── flash.scm ├── font.scm ├── forth.scm ├── header.scm ├── interrupt.scm ├── keyboard.scm ├── macros.scm ├── math.scm ├── text.scm ├── util.scm └── zkeme80.scm ├── words ├── backtracking.fs ├── coroutines.fs ├── cursor.fs ├── editor.fs ├── see.fs ├── test-suite.fs └── tests.fs └── z80data.tab /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2.3.1 10 | - uses: cachix/install-nix-action@v12 11 | with: 12 | nix_path: nixpkgs=channel:nixos-unstable 13 | - name: Build 14 | run: nix-build 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.bin 3 | *.rom 4 | .direnv 5 | result 6 | -------------------------------------------------------------------------------- /0A.key: -------------------------------------------------------------------------------- 1 | 40B11C71D4EA2C13C9AB2E501C6085FEC87FF3B88BFD783EAC43351E1B10F65AD31C79C1268F75051DC8FC008EBF593AE5912E8B653975C13127E2B60A0BEF5FEF 2 | 204DD5B4E544CACBC4EF869CDA30A6908FF7D1BDDB92B1ADE1E1C93CC614904894 3 | 21F5E2DFBCA3D5C86F4815DC69452E4FC7D122D650374E880B62294279F21A439D01 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2018 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | cd src && make build && cp zkeme80.rom ../ 3 | 4 | all: 5 | cd src && make build && cp zkeme80.rom ../ 6 | tilem2 -r zkeme80.rom 7 | 8 | upgrade: 9 | cd src && make build 10 | mktiupgrade -k 0A.key --device TI-84+ zkeme80.rom zkeme80.8xu 00 01 02 03 3C 11 | cp zkeme80.8xu ../ 12 | -------------------------------------------------------------------------------- /PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | ### Motivation for this change 2 | 3 | 4 | ### Things done 5 | 6 | 7 | 8 | - Built on platform(s) 9 | - [ ] NixOS 10 | - [ ] macOS 11 | - [ ] other Linux distributions 12 | - [ ] The ROM boots 13 | - [ ] All tests in the test suite pass 14 | - If implementing an ANS CORE word 15 | - [ ] An ANS-conforming test case was added 16 | - [ ] The ANS-conforming test passed 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # zkeme80 - a Forth-based OS for the TI-84+ calculator 2 | ![Build Status](https://github.com/siraben/zkeme80/workflows/Build/badge.svg) 3 | 4 | ![OS screenshot](screenshot.png) 5 | ![OS animation](demo.gif) 6 | 7 | **TLDR:** `assembler.scm` is the assembler, `zkeme80.scm` is the OS. 8 | To build the rom, run `make build`. There are no dependencies apart 9 | from a recent version of Guile, supporting the modules `bytevectors` 10 | and `srfi-9` records. Other Scheme implementations have not been 11 | tested. 12 | 13 | Alternatively, if you're using the Nix package manager on macOS or 14 | Linux, running `nix-build && ./result/bin/runit` in the root of this repository 15 | builds the OS and emulator, then runs it. 16 | 17 | ## Why another OS for the TI-84+? 18 | The TI tinkering community has long loathed the proprietary nature of 19 | the default TI-OS. Few projects have attempted to create a viable 20 | alternative, fewer have matured to a usable state, and none are 21 | currently able to actually let you use the calculator *as a 22 | calculator*. 23 | 24 | If you've been looking at operating systems for the TI-84+, chances 25 | are you've come across **KnightOS**. It's well developed and has 26 | plenty of Unix-like features such as filesystems and tasks, and even a 27 | C compiler. But maybe that's not what you want. You want a minimal 28 | operating system that allows you to extend it in any way you wish, 29 | bonus points if you don't need to know Z80 assembly to do so. 30 | 31 | **zkeme80** is that operating system, a minimal core with a mostly 32 | [ANS standard](https://forth-standard.org/standard/words) conforming 33 | Forth interpreter/compiler. From words covering sprites and graphics, 34 | to text and memory access, everything you need to make the next hit 35 | Snake clone or RPN-based math layer is already there. **zkeme80** 36 | lowers the barrier of entry for customizing an operating system and 37 | enable rapid development cycles. Below the Forth layer, you'll find 38 | two lowest level and highest level languages, Z80 assembly and Scheme. 39 | The best assembler is an extensible one, where writing macros should 40 | be a joy, not a pain, and Scheme has that macro system. 41 | 42 | On my MacBook Pro 11,1 running NixOS it takes around 13.5 seconds 43 | (real time) to compile the operating system for the first time with 44 | `make build`, and subsequent builds involving only changes to `.fs` 45 | files take around 0.5 seconds (real time). 46 | 47 | ## Why Forth? 48 | OS development is hard, doubly so if you're using assembly. Keep 49 | track of calling conventions, or which routines preserve which 50 | registers is a tedious and error-prone task. Nested loops and 51 | `switch` statements are out of the window. And most importantly, it 52 | isn't easy to allow the user to extend the operating system. Forth 53 | changes that. It's just as low level as assembly, but it can be as 54 | high level as you want. Want exceptions? They're already there! 55 | Want garbage collection and memory safety? Roll your own! See 56 | `forth.scm` for more than 200 examples of Forth words. If you're not 57 | familiar with Forth, I highly recommend *Starting Forth* by Leo 58 | Brodie. Get it [here](https://www.forth.com/starting-forth/). 59 | 60 | ### Notes on standard-compliance 61 | Some words are not standard. This is because I copied them from my 62 | other [Forth/Z80 project](https://github.com/siraben/ti84-forth), 63 | which itself is based on jonesforth. However, I did consult the ANS 64 | standard to incorporate some of their good ideas. For instance, the 65 | test suite currently found in `bootstrap-flash4.fs` is only a very 66 | slight (sans the floating point stuff) adaptation of the [offical test 67 | suite](www.forth200x.org/tests/ttester.fs). The current version of 68 | the operating system runs a series of tests to check the correctness 69 | of the word environment. As time goes on I may consider making more 70 | words standard-conforming. 71 | 72 | ### Did you write all of this? 73 | Most of the assembly code outside of `forth.scm` was taken from 74 | [SmileyOS](https://www.ticalc.org/archives/files/fileinfo/442/44227.html), 75 | which itself is based on an older version of the [KnightOS 76 | Kernel](https://github.com/knightos/kernel). I chose SmileyOS because 77 | it was the most "minimal" needed to get nasty stuff such as 78 | locking/unlocking flash, display routines, key routines etc. out of 79 | the way. Code here that doesn't exist in SmileyOS was taken from 80 | public sources, including the current version of KnightOS. The rest 81 | of the operating system is of my own design. 82 | 83 | 84 | ## Building and running the operating system 85 | ### Using the Makefile 86 | Running `make build` should make generate a file called `zkeme80.rom` 87 | in the same directory. Simply pass that file to an emulator such as 88 | [jsTIfied](https://www.cemetech.net/projects/jstified/) (works in the 89 | browser) and start playing around! 90 | 91 | Running just `make` builds and runs the project, but assumes that you 92 | have already properly built `tilem` and can run it with `tilem2` on 93 | the shell, and have Guile installed. Be warned, though, `tilem` is 94 | tricky to build and you have to enable all sorts of flags and install 95 | dependencies. If anyone knows a good emulator for macOS, please let 96 | me know. 97 | 98 | ### Using the Nix package manager (macOS or Linux) 99 | If you're using the Nix package manager, just clone the repository and 100 | run the following to compile and build the assembler, operating 101 | system, and emulator. It will automatically run the ROM when done. 102 | Props to `clever` on `#nixos` for figuring out how to build `tilem`. 103 | 104 | ```shell 105 | # With flakes 106 | $ nix run 107 | # Without flakes 108 | $ nix-build && ./result/bin/runit 109 | ``` 110 | 111 | ## Files included 112 | 113 | * `assembler.scm` assembles s-exp style assembly code into binary. Simply 114 | run `(load "assembler.scm")` into your Scheme REPL and 115 | run`(assemble-prog sample-prog)` to see the binary data. Run 116 | `(assemble-to-file sample-prog "out.bin")` to write a binary file. 117 | * `zkeme80.scm` is the Forth-based operating system. Load 118 | `zkeme80.scm` then run `(make-rom "zkeme80.rom")` to output binary 119 | to a file `zkeme80.rom`. 120 | 121 | ## Design of the assembler 122 | The assembler's core uses pattern matching. The program counter is 123 | implemented as a mutable Scheme object `*pc*`. Labels are kept in a 124 | global alist `*labels*`. To allow for the use of jumps that refer to 125 | labels declared after it, we use multiple passes. The assembler is 126 | designed to be extensible from various levels; the source code of the 127 | assembler, pass 1 and pass 2. Each layer can be extended using the 128 | full power of Scheme. 129 | 130 | The extensible nature of the assembler means that users can add 131 | whatever features they desire that were not built in already, for 132 | instance, re-targeting the assembler or adding missing instructions. 133 | 134 | ### Structure of assembly programs 135 | Assembly programs consist of a list of elements that are either 136 | expressions or procedures. 137 | 138 | ### Pass 1 139 | #### Handling expressions 140 | Each expression of a program is passed to `assemble-expr` (which also 141 | checks if they're well-formed). `assemble-expr` returns a record 142 | type that has the following fields (for a normal instruction): 143 | 144 | | Record entry | Type | Description | 145 | | :-: | :-: | :-: | 146 | | `length` | `integer` | The length of the instruction, in bytes. | 147 | | `gen-instr` | `lambda` | Thunk that computes the actual instruction bytes. | 148 | 149 | The use of converting expressions into record types like this allows 150 | us to compute the length of the program (and resolve look ahead 151 | labels). 152 | 153 | #### Handling procedures 154 | Procedures (Scheme objects that satisfy the predicate `procedure?`) 155 | that are embedded in a program must be able to be run without any 156 | arguments, and return either `()` or an instruction record. This is 157 | the main extension mechanism for the assembler. For instance, in 158 | `macros.scm` there is a procedure called `fill-until-end` which 159 | creates a list of bytes so that the total binary is `#x100000` bytes 160 | long. 161 | 162 | ### Pass 2 163 | Once the program makes it through Pass 1, we perform code generation 164 | and label resolution. All instruction records are required to have a 165 | `length` property that tells in advance how many bytes will be 166 | generated from the thunk. Consistency between this number and what 167 | the thunk outputs is checked. Each instruction record is also checked 168 | that it generates only unsigned 8-bit integers. The result is 169 | flattened into a list of unsigned numbers, which can be manipulated as 170 | the user wishes. 171 | 172 | ## Debugging 173 | The debugging process is pretty simple. One just has to write a valid 174 | Z80 assembly program in my s-exp format and run it through a 175 | disassembler then compare the output. If you're feeling particularly 176 | brave you may skip this step and try your program out on a Z80 chip. 177 | 178 | ## Assembler Limitations 179 | There is currently no instruction encoding (like the `z80data.tab` 180 | file) that the assembler accepts, so to add new instructions the 181 | current workflow is to look at relevant portions of the Z80 data sheet 182 | and write new cases in the pattern matcher. Adding such an encoding 183 | would allow the assembler to be retargeted. 184 | -------------------------------------------------------------------------------- /build.scm: -------------------------------------------------------------------------------- 1 | (add-to-load-path "src") 2 | (load (%search-load-path "zkeme80.scm")) 3 | (make-rom "zkeme80.rom") 4 | -------------------------------------------------------------------------------- /coverage.org: -------------------------------------------------------------------------------- 1 | * Test Coverage [120/151] 2 | Excludes words with special semantics and used in the forth.scm 3 | stage only (0BRANCH BRANCH, 0JUMP, JUMP), and interpreter 4 | words (QUIT, INTERPRET). If a WORD word (e.g. CATCH, THROW) 5 | works correctly according to the standard using other CORE words, then 6 | all of its constituent word are considered correct as well. 7 | 8 | I/O words (key input, sprite drawing, etc.) and variables and 9 | constants are omitted. 10 | 11 | ** DONE < 12 | ** DONE <= 13 | ** DONE <> 14 | ** DONE = 15 | ** DONE >= 16 | ** DONE > 17 | ** DONE - 18 | ** DONE -! 19 | ** DONE , 20 | ** DONE ; 21 | ** DONE : 22 | ** DONE ! 23 | ** DONE / 24 | ** DONE ' 25 | ** DONE [ 26 | ** DONE ] 27 | ** DONE { 28 | ** DONE } 29 | ** DONE @ 30 | ** DONE * 31 | ** DONE \ 32 | ** DONE + 33 | ** DONE +! 34 | ** DONE 0= 35 | ** DONE 1- 36 | ** DONE 1+ 37 | ** DONE 2- 38 | ** DONE 2! 39 | ** DONE 2/ 40 | ** DONE 2@ 41 | ** DONE 2* 42 | ** DONE 2+ 43 | ** DONE 2DROP 44 | ** DONE 2DUP 45 | ** DONE 2OVER 46 | ** DONE 2>R 47 | ** DONE 2R> 48 | ** DONE 2RDROP 49 | ** DONE 2SWAP 50 | ** TODO ABORT 51 | ** TODO AGAIN 52 | ** DONE ALLOT 53 | ** DONE AND 54 | ** DONE AT 55 | ** DONE BASE 56 | ** DONE BEGIN 57 | ** DONE BEGIN-STRUCTURE 58 | ** DONE C, 59 | ** DONE C! 60 | ** DONE C@ 61 | ** DONE CASE 62 | ** DONE CATCH 63 | ** TODO C@C! 64 | ** DONE CELL 65 | ** DONE CELL+ 66 | ** DONE CELLS 67 | ** TODO >CFA 68 | ** TODO CFA> 69 | ** DONE CHAR 70 | ** DONE CHAR+ 71 | ** DONE CHARS 72 | ** TODO CMOVE 73 | ** TODO CMOVE> 74 | ** TODO CMOVE-FLASH 75 | ** DONE CONSTANT 76 | ** DONE COUNT 77 | ** TODO CREATE 78 | ** DONE DECIMAL 79 | ** DONE DEPTH 80 | ** TODO >DFA 81 | ** TODO DISABLE-INTERRUPTS 82 | ** DONE DO 83 | ** TODO (DOES>) 84 | ** TODO DOES> 85 | ** DONE DROP 86 | ** DONE ?DUP 87 | ** DONE DUP 88 | ** DONE ELSE 89 | ** TODO ENABLE-INTERRUPTS 90 | ** DONE ENDCASE 91 | ** DONE ENDOF 92 | ** DONE END-STRUCTURE 93 | ** TODO ERASE-SECTOR 94 | ** DONE EXECUTE 95 | ** DONE EXIT 96 | ** DONE FALSE 97 | ** DONE FIELD: 98 | ** TODO FIND 99 | ** TODO FORGET 100 | ** TODO GETC 101 | ** DONE HERE 102 | ** DONE HEX 103 | ** TODO ?HIDDEN 104 | ** TODO HIDDEN 105 | ** DONE I 106 | ** DONE IF 107 | ** TODO ?IMMEDIATE 108 | ** DONE IMMEDIATE 109 | ** DONE INVERT 110 | ** DONE J 111 | ** DONE LEAVE 112 | ** TODO LITSTRING 113 | ** DONE +LOOP 114 | ** DONE LOOP 115 | ** DONE LSHIFT 116 | ** DONE /MOD 117 | ** DONE MOD 118 | ** DONE NIP 119 | ** TODO NOT 120 | ** TODO NUM? 121 | ** DONE NUMBER 122 | ** DONE OF 123 | ** DONE OR 124 | ** DONE OVER 125 | ** TODO PARSE-NUMBER 126 | ** DONE PICK 127 | ** DONE POSTPONE 128 | ** DONE >R 129 | ** DONE R> 130 | ** DONE R@ 131 | ** DONE RDROP 132 | ** TODO RECURSE 133 | ** TODO REFILL 134 | ** DONE REPEAT 135 | ** DONE -ROT 136 | ** DONE ROT 137 | ** DONE RP! 138 | ** DONE RP@ 139 | ** TODO SET-INTERRUPT 140 | ** DONE RSHIFT 141 | ** TODO SET-RAM-MEMA 142 | ** DONE SP! 143 | ** DONE SP@ 144 | ** DONE STORE 145 | ** DONE SWAP 146 | ** DONE }T 147 | ** DONE T{ 148 | ** DONE THEN 149 | ** DONE THROW 150 | ** TODO TO-ASCII 151 | ** DONE TRUE 152 | ** DONE TUCK 153 | ** TODO UNGETC 154 | ** DONE UNLOOP 155 | ** DONE UNTIL 156 | ** TODO UWIDTH 157 | ** DONE VALUE 158 | ** DONE VARIABLE 159 | ** DONE WHILE 160 | ** DONE WITHIN 161 | ** DONE WORD 162 | ** DONE XOR 163 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import 2 | ( 3 | let 4 | lock = builtins.fromJSON (builtins.readFile ./flake.lock); 5 | nodeName = lock.nodes.root.inputs.flake-compat; 6 | in 7 | fetchTarball { 8 | url = lock.nodes.${nodeName}.locked.url or "https://github.com/edolstra/flake-compat/archive/${lock.nodes.${nodeName}.locked.rev}.tar.gz"; 9 | sha256 = lock.nodes.${nodeName}.locked.narHash; 10 | } 11 | ) 12 | { src = ./.; } 13 | ).defaultNix 14 | -------------------------------------------------------------------------------- /demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/zkeme80/97992c2e1d0a7f672b211abfb58e95099b210084/demo.gif -------------------------------------------------------------------------------- /demos/menu.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/zkeme80/97992c2e1d0a7f672b211abfb58e95099b210084/demos/menu.gif -------------------------------------------------------------------------------- /docs/design.md: -------------------------------------------------------------------------------- 1 | # The design and philosophy of zkeme80 2 | 3 | zkeme80 is designed to be a *very* sharp-edged tool. Extremely 4 | powerful in the hands of an experienced user, but easily misused in 5 | the hands of a novice. Nevertheless, we outline some important design 6 | decisions. 7 | 8 | ## RAM is volatile 9 | It is likely that the user will crash the operating system at any 10 | point. This is Forth, after all, and a single hanging `ELSE` in a 11 | word definition or an infinite loop can leave the system stuck. For 12 | this reason, RAM must be treated as something volatile. More 13 | permanent data should be stored in flash. 14 | 15 | ## Expose enough words 16 | One knee-jerk reaction when writing a Forth-based operating system is 17 | to "Forthify" as much as possible, wrapping all the various 18 | subroutines into Forth words. However you'll notice that only a 19 | fraction of the subroutines are directly accessible from the Forth 20 | interpreter. This almost gives a userspace/kernelspace separation, 21 | where system calls are words. This also protects the user from 22 | accessing words that have specific calling conventions, for instance 23 | `unlock-ram`, which must be followed by an assembly call to 24 | `lock-ram`. 25 | 26 | ## Defining words in assembly or Forth 27 | Many Forth implementations go the way of defining most of it in 28 | itself, compromising speed for portability. This doesn't make much 29 | sense on the Z80 which is much slower than modern chips, so generally 30 | if one is debating whether to make a word a CODE word or a WORD word, 31 | write it in whatever it faster. However, we also don't want to spend 32 | more development time on words that are easily writable in Forth, and 33 | where speed isn't completely essential so a balance must be striken. 34 | So when doubt, write it in the language that more succinctly expresses 35 | the behavior of the word. 36 | 37 | ## No files 38 | This Forth implementation will implement a block-based system, where 39 | each block is 1024 bytes. This keeps things simple. The user can 40 | specify exactly when to save their work and which block to load. 41 | Furthermore, this allows the ability for the user to extend the 42 | system. Searching within blocks can be implemented, and it would be 43 | trivial to enumerate the list of blocks. Block names can be aliased 44 | via constants as well, so the initial block might serve as the block 45 | that allows the user to choose which block to load next, and so on. 46 | 47 | This also allows for relatively easy facilities later on to backup and 48 | restore state, single the only mutable state will be in the blocks. 49 | 50 | ## No security 51 | Security is hard. So let's not have any. It is unlikely that the 52 | calculator will be used for cryptographic applications (it is slow, 53 | after all), or run external code via network/link connections. But of 54 | course if the user desires, extra protection may be implemented, 55 | perhaps a password being asked on boot, and so on. 56 | 57 | ## Standardize words when possible 58 | There is considerable debate among Forth programmers whether or not to 59 | make words ANS standard-conforming. Here's my take on it: standards 60 | exist for a reason. I should be able to copy and paste code written 61 | with only CORE words with the expectation that it will work 62 | flawlessly. The programmer should not need to care whether the Forth 63 | system is little endian or big endian (but *should* worry about the 64 | max unsigned integer size, etc.), and should not write code with 65 | environmental dependencies if portability is in mind. 66 | -------------------------------------------------------------------------------- /docs/ideas.md: -------------------------------------------------------------------------------- 1 | # Ideas for the assembler and zkeme80 2 | 3 | ## Be compatible with existing ASM formats 4 | It's very time consuming and error-prone to transcribe existing Z80 5 | ASM code into 6 | -------------------------------------------------------------------------------- /docs/shell.md: -------------------------------------------------------------------------------- 1 | # Designing a good shell 2 | 3 | A good shell is the heart of an operating system. Let's make 4 | something that's easy to use and is inspired by the TI operating 5 | system (TI-OS). What does TI-OS do well? I think it comes down to 6 | the following things. 7 | 8 | - Cursor movement 9 | - Ability to see cursor and scroll back and forth using left/right 10 | arrow keys. 11 | - Fast cursor movement. 12 | - Go to the beginning of the line with `2ND <-`. 13 | - Go to the end of the line with `2ND ->`. 14 | - `ALPHA` locking (by pressing `2ND ALPHA`). 15 | - Modal editing 16 | - Pressing `CLEAR` clears the current input line. 17 | - User can switch between `ALPHA`, `2ND` and normal key input 18 | modes. 19 | - Overwrite mode by default. 20 | - Can go into insert mode through `2ND DEL`, in which the cursor 21 | changes to an underscore and point (an Emacs terminology) is 22 | placed just before it. 23 | - On input, the field shifts to the right by 1. 24 | - Pressing `DEL` shifts the field to the left by 1 and deletes the 25 | character just after point. 26 | - Command history 27 | - Pressing the up/down arrow keys allows you to scroll back to 28 | previous history entries results. 29 | - Pressing `ENTER` allows you to paste into the current input the 30 | currently highlighted expression, either entry or result. 31 | 32 | But what can we do better? Let's imagine that instead of switching 33 | input modes by pressing `2ND or ALPHA`, these keys are modifier keys 34 | instead. For instance, we can detect the pressing of `2ND-(` and 35 | translate it to the character `K` directly. Or, we may make 36 | alphabetic input the default input mode and simultaneously holding 37 | `2ND` would allow us to access the numbers. 38 | 39 | What to do with the keys that aren't mapped to a printable character? 40 | The five keys just below the display, and keys like `X,T,θ,n`, `STAT` 41 | , `MODE` or `CLEAR`? We should assign them special bindings, or maybe 42 | even act as an additional modifier. 43 | 44 | One of the tricky challenges ever single I started working on zkeme80 45 | was the lack of a screen scroll. To scroll the screen, we must detect 46 | that `CUR-COL` and `CUR-ROW` have both exceeded the limit, and this 47 | involves checking its value after every `EMIT` or `PLOT-STRING`. Of 48 | course, we don't always want to scroll automatically, for instance if 49 | we are drawing an editor using ASCII characters. An alternative 50 | approach would be to use vectored execution. So when a call to EMIT 51 | is made, scrolling is automatically handled for us based on what word 52 | is being used. 53 | 54 | Actually, could we take it one step further and allow any word to be 55 | used? This would truly make `EMIT` a generic output device. In this 56 | way, we could perform automated logging, or storing things in RAM to 57 | be pulled out later by screenshots, and so on. 58 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "locked": { 5 | "lastModified": 1733328505, 6 | "narHash": "sha256-NeCCThCEP3eCl2l/+27kNNK7QrwZB1IJCrXfrbv5oqU=", 7 | "rev": "ff81ac966bb2cae68946d5ed5fc4994f96d0ffec", 8 | "revCount": 69, 9 | "type": "tarball", 10 | "url": "https://api.flakehub.com/f/pinned/edolstra/flake-compat/1.1.0/01948eb7-9cba-704f-bbf3-3fa956735b52/source.tar.gz" 11 | }, 12 | "original": { 13 | "type": "tarball", 14 | "url": "https://flakehub.com/f/edolstra/flake-compat/1.tar.gz" 15 | } 16 | }, 17 | "nixpkgs": { 18 | "locked": { 19 | "lastModified": 1746904237, 20 | "narHash": "sha256-3e+AVBczosP5dCLQmMoMEogM57gmZ2qrVSrmq9aResQ=", 21 | "owner": "NixOS", 22 | "repo": "nixpkgs", 23 | "rev": "d89fc19e405cb2d55ce7cc114356846a0ee5e956", 24 | "type": "github" 25 | }, 26 | "original": { 27 | "owner": "NixOS", 28 | "ref": "nixos-unstable", 29 | "repo": "nixpkgs", 30 | "type": "github" 31 | } 32 | }, 33 | "root": { 34 | "inputs": { 35 | "flake-compat": "flake-compat", 36 | "nixpkgs": "nixpkgs", 37 | "utils": "utils" 38 | } 39 | }, 40 | "systems": { 41 | "locked": { 42 | "lastModified": 1681028828, 43 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 44 | "owner": "nix-systems", 45 | "repo": "default", 46 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 47 | "type": "github" 48 | }, 49 | "original": { 50 | "owner": "nix-systems", 51 | "repo": "default", 52 | "type": "github" 53 | } 54 | }, 55 | "utils": { 56 | "inputs": { 57 | "systems": "systems" 58 | }, 59 | "locked": { 60 | "lastModified": 1731533236, 61 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 62 | "owner": "numtide", 63 | "repo": "flake-utils", 64 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 65 | "type": "github" 66 | }, 67 | "original": { 68 | "owner": "numtide", 69 | "repo": "flake-utils", 70 | "type": "github" 71 | } 72 | } 73 | }, 74 | "root": "root", 75 | "version": 7 76 | } 77 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "zkeme80"; 3 | inputs = { 4 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 5 | utils.url = "github:numtide/flake-utils"; 6 | flake-compat.url = "https://flakehub.com/f/edolstra/flake-compat/1.tar.gz"; 7 | }; 8 | outputs = { self, nixpkgs, utils, flake-compat }: 9 | utils.lib.eachDefaultSystem (system: 10 | with import nixpkgs { inherit system; }; rec { 11 | packages = rec { 12 | default = pkgs.writeShellScriptBin "runit" '' 13 | exec ${pkgs.tilem}/bin/tilem2 -r ${zkeme80}/zkeme80.rom 14 | ''; 15 | zkeme80 = runCommand "zkeme80.rom" { buildInputs = [ guile ]; } '' 16 | cp -r ${./.}/src/* . 17 | chmod -R +w . 18 | echo '(begin (load "zkeme80.scm") (make-rom "zkeme80.rom"))' | guile 19 | mkdir $out 20 | cp zkeme80.rom $out/ 21 | ''; 22 | }; 23 | defaultPackage = self.packages.${system}.default; 24 | } 25 | ); 26 | 27 | } 28 | -------------------------------------------------------------------------------- /key.dot: -------------------------------------------------------------------------------- 1 | digraph { 2 | dpi = 192 3 | // title 4 | labelloc="t"; 5 | label="Keyboard state transition diagram in TI-OS\nPressing \"Clear\" transitions to normal from any state\n\nGreen lines represent pressing ALPHA\nBlue lines represent pressing 2nd\nBlack lines represent other keys\n\n"; 6 | 7 | pad=0.5 8 | node [margin=0, style=bold, width=2, shape=box, fillcolor=white, style="filled, rounded"] 9 | "normal" [fillcolor=gray] 10 | "2nd" [fillcolor = deepskyblue] 11 | alpha [fillcolor = chartreuse2] 12 | "alpha lock" [fillcolor = chartreuse2] 13 | "alpha 2nd" [fillcolor = deepskyblue] 14 | "alpha lock 2nd" [fillcolor = deepskyblue] 15 | 16 | "normal" -> "2nd" [color=blue]; 17 | "2nd" -> "normal" [color=blue]; 18 | alpha -> "alpha 2nd" [color=blue]; 19 | "alpha 2nd" -> alpha [color=blue]; 20 | "alpha lock" -> "alpha lock 2nd" [color=blue]; 21 | "alpha lock 2nd" -> "alpha lock" [color=blue]; 22 | 23 | "normal" -> alpha [color=green]; 24 | alpha -> "normal" [color=green]; 25 | "2nd" -> "alpha lock" [color=green]; 26 | "alpha lock" -> "normal" [color=green]; 27 | "alpha 2nd" -> "alpha lock" [color=green]; 28 | "alpha lock 2nd" -> "alpha lock" [color=green]; 29 | 30 | // "normal" -> "normal" [label="clear",color=brown1]; 31 | // "alpha lock" -> "normal" [label="clear",color=brown1]; 32 | // alpha -> "normal" [label="clear",color=brown1]; 33 | // "2nd" -> "normal" [label="clear",color=brown1]; 34 | // "alpha 2nd" -> "normal" [label="clear",color=brown1]; 35 | // "alpha lock 2nd" -> "normal" [label="clear",color=brown1]; 36 | 37 | "normal" -> "normal" 38 | alpha -> "normal" 39 | "alpha 2nd" -> alpha 40 | "2nd" -> "normal" 41 | "alpha lock" -> "alpha lock" 42 | "alpha lock 2nd" -> "alpha lock" 43 | } 44 | -------------------------------------------------------------------------------- /key.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/zkeme80/97992c2e1d0a7f672b211abfb58e95099b210084/key.png -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/zkeme80/97992c2e1d0a7f672b211abfb58e95099b210084/screenshot.png -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | echo '(begin (load "zkeme80.scm") (make-rom "zkeme80.rom"))' | guile 3 | tilem2 -r zkeme80.rom 4 | 5 | build: 6 | echo '(begin (load "zkeme80.scm") (make-rom "zkeme80.rom"))' | guile 7 | 8 | upgrade: 9 | echo '(begin (load "zkeme80.scm") (make-rom "zkeme80.rom"))' | guile 10 | mktiupgrade -k 0A.key --device TI-84+ zkeme80.rom zkeme80.8xu 00 01 02 03 3C 11 | -------------------------------------------------------------------------------- /src/assembler.scm: -------------------------------------------------------------------------------- 1 | (use-modules (ice-9 match) (rnrs io ports) (rnrs bytevectors) (srfi srfi-9)) 2 | 3 | ;; set! this to #t to see debugging information. Note that `lookup` 4 | ;; will complain a lot but generally it's fine. 5 | (define verbose? #f) 6 | 7 | ;; Turns out these things care called "register groups", bit-fields 8 | ;; for each register in various instructions. Will be revised as I 9 | ;; implement more of the Z80 instruction set. 10 | (define 16-bit-regs 11 | '((af . #b11) 12 | (bc . #b00) 13 | (de . #b01) 14 | (hl . #b10) 15 | (sp . #b11))) 16 | 17 | (define push-pop-index-regs 18 | '((ix . #b11011101) 19 | (iy . #b11111101))) 20 | 21 | (define ld-regs 22 | '((a . #b111) 23 | (b . #b000) 24 | (c . #b001) 25 | (d . #b010) 26 | (e . #b011) 27 | (h . #b100) 28 | (l . #b101) 29 | ((hl) . #b110))) 30 | 31 | (define ir-regs 32 | '((i . 0) 33 | (r . 1))) 34 | 35 | (define condition-codes 36 | '((nz . #b000) 37 | (z . #b001) 38 | (nc . #b010) 39 | (c . #b011) 40 | (po . #b100) 41 | (pe . #b101) 42 | (p . #b110) 43 | (m . #b111))) 44 | 45 | (define jr-condition-codes 46 | '((nz . #b00) 47 | (z . #b01) 48 | (nc . #b10) 49 | (c . #b11))) 50 | 51 | (define (lookup key alist) 52 | (let ((match (assoc key alist))) 53 | (if match 54 | (cdr match) 55 | (begin 56 | ;; Verbose 57 | (if verbose? (format #t "Failed to lookup: ~a\n" key)) 58 | #f)))) 59 | 60 | (define (index-reg? reg) 61 | (member reg '(ix iy))) 62 | 63 | ;; We often see in the data sheet opcodes like this: 64 | ;; PUSH reg16 -> 11[reg16]0101 65 | ;; ((bc . #b00) (de . #b01) (hl . #b10) (af . #b11)) 66 | 67 | ;; This means we can generate the opcode for that instruction by 68 | ;; offsetting a "register code" by some number of bits and performing 69 | ;; logical or on the result with the "template" opcode. 70 | (define (make-opcode reg-code offset opcode) 71 | (logior (ash reg-code 72 | offset) 73 | opcode)) 74 | 75 | (define-record-type 76 | (make-inst-rec length generator) 77 | inst? 78 | (length inst-length) 79 | (generator inst-generator)) 80 | 81 | (define-syntax make-inst 82 | (syntax-rules () 83 | ((_ length generator) 84 | (make-inst-rec length (delay generator))))) 85 | 86 | (define (gen-inst inst) 87 | (force (inst-generator inst))) 88 | 89 | (define (assemble-push reg) 90 | (if (index-reg? reg) 91 | (make-inst 2 `(,(lookup reg push-pop-index-regs) #b11100101)) 92 | (make-inst 1 `(,(make-opcode (lookup reg 16-bit-regs) 4 #b11000101))))) 93 | 94 | (define (assemble-pop reg) 95 | (if (index-reg? reg) 96 | (make-inst 2 `(,(lookup reg push-pop-index-regs) #b11100001)) 97 | (make-inst 1 `(,(make-opcode (lookup reg 16-bit-regs) 4 #b11000001))))) 98 | 99 | (define (unsigned-nat? x) (and (integer? x) (>= x 0))) 100 | (define (num->binary n) (format #f "~8,'0b" n)) 101 | (define (num->hex n) (format #f "~2,'0x" n)) 102 | (define (16-bit-reg? x) (lookup x 16-bit-regs)) 103 | (define (8-bit-reg? x) (member x '(a b c d e f h l i r (hl)))) 104 | (define (ir-reg? x) (lookup x ir-regs)) 105 | (define (reg? x) (or (16-bit-reg? x) (8-bit-reg? x))) 106 | 107 | (define (8-bit-imm? x) 108 | (and (unsigned-nat? x) 109 | (> (ash 1 8) x))) 110 | 111 | (define (16-bit-imm-or-label? x) 112 | (or (symbol? x) 113 | (and (unsigned-nat? x) 114 | (> (ash 1 16) x)))) 115 | 116 | (define (16-bit-imm? x) 117 | (and (unsigned-nat? x) 118 | (> (ash 1 16) x))) 119 | 120 | 121 | (define (assemble-ld-reg8-reg8 dest src) 122 | (make-inst 1 123 | `(,(make-opcode (lookup src ld-regs) 124 | 0 125 | (make-opcode (lookup dest ld-regs) 126 | 3 127 | #b01000000))))) 128 | 129 | (define (assemble-ld-reg8-imm8 reg8 imm8) 130 | (make-inst 2 131 | `(,(make-opcode (lookup reg8 ld-regs) 3 #b00000110) ,imm8))) 132 | 133 | (define (assemble-ld-hl-iimm16 iimm16) 134 | (make-inst 3 135 | (let ((iimm16 (resolve-label iimm16))) 136 | `(#b00101010 137 | ,(lsb iimm16) 138 | ,(msb iimm16))))) 139 | 140 | (define ld-iregs '((bc . #b0) (de . #b1))) 141 | 142 | (define (assemble-ld-a-ireg16 reg) 143 | (make-inst 1 `(,(make-opcode (lookup reg ld-iregs) 4 #b00001010)))) 144 | 145 | ;; Least significant byte. 146 | (define (lsb n) (logand n 255)) 147 | 148 | ;; Most significant byte. 149 | (define (msb n) (ash n -8)) 150 | 151 | (define (resolve-label label-or-imm16) 152 | (if (16-bit-imm? label-or-imm16) 153 | label-or-imm16 154 | (or (lookup label-or-imm16 *labels*) 155 | (error (format #f "Label not found: ~a" label-or-imm16))))) 156 | 157 | (define (assemble-ld-reg16-imm16 reg16 imm16) 158 | (make-inst 3 (let ((imm16 (resolve-label imm16))) 159 | `(,(make-opcode (lookup reg16 16-bit-regs) 4 #b00000001) 160 | ,(lsb imm16) 161 | ,(msb imm16))))) 162 | 163 | 164 | (define (assemble-ld-reg16-iimm16 reg16 imm16) 165 | (make-inst 4 (let ((imm16 (resolve-label imm16))) 166 | `(#b11101101 167 | ,(make-opcode (lookup reg16 16-bit-regs) 4 #b01001011) 168 | ,(lsb imm16) 169 | ,(msb imm16))))) 170 | 171 | (define (assemble-ld-ireg16-a reg16) 172 | (make-inst 1 `(,(make-opcode (lookup reg16 16-bit-regs) 4 #b00000010)))) 173 | 174 | (define ld-index-imm16-regs 175 | '((ix . #b11011101) 176 | (iy . #b11111101))) 177 | 178 | (define (assemble-ld-index-imm16 ireg imm16) 179 | (make-inst 4 (let ((imm16 (resolve-label imm16))) 180 | `(,(lookup ireg ld-index-imm16-regs) 181 | #b00100001 182 | ,(lsb imm16) 183 | ,(msb imm16))))) 184 | 185 | (define (assemble-ld-ir-reg ir) 186 | (make-inst 2 `(#b11101101 187 | ,(make-opcode (lookup ir ir-regs) 3 #b01010111)))) 188 | 189 | (define (assemble-ld-a-ir ir) 190 | (make-inst 2 `(#b11101101 191 | ,(make-opcode (lookup ir ir-regs) 3 #b01000111)))) 192 | 193 | (define (assemble-ld-iimm16-a addr) 194 | (make-inst 3 (let ((addr (resolve-label addr))) 195 | `(#b00110010 196 | ,(lsb addr) 197 | ,(msb addr))))) 198 | 199 | (define (assemble-ld-a-imm16 addr) 200 | (make-inst 3 (let ((addr (resolve-label addr))) 201 | `(#b00111010 202 | ,(lsb addr) 203 | ,(msb addr))))) 204 | 205 | (define (assemble-ld-sp-hl) 206 | (make-inst 1 `(#b11111001))) 207 | 208 | (define (assemble-ld-reg8-index-offset a b c) 209 | (make-inst 3 `(,(if (eq? b 'ix) #b11011101 #b11111101) 210 | ,(make-opcode (lookup a ld-regs) 3 #b01000110) 211 | ,c))) 212 | 213 | (define (assemble-ld-index-reg8 a b c) 214 | (make-inst 3 `(,(lookup a ld-index-imm16-regs) 215 | ,(make-opcode (lookup c ld-regs) 0 #b01110000) 216 | ,b))) 217 | 218 | (define (assemble-ld-iimm-reg16 a b) 219 | (make-inst 4 (let ((a (resolve-label a))) 220 | `(#b11101101 221 | ,(make-opcode (lookup b 16-bit-regs) 4 #b01000011) 222 | ,(lsb a) 223 | ,(msb a))))) 224 | 225 | (define (assemble-ld args) 226 | (match args 227 | ('(sp hl) (assemble-ld-sp-hl)) 228 | (('a (? ir-reg? b)) (assemble-ld-ir-reg b)) 229 | (((? ir-reg? b) 'a) (assemble-ld-a-ir b)) 230 | (((? 8-bit-reg? a) (? 8-bit-reg? b)) (assemble-ld-reg8-reg8 a b)) 231 | (((? 8-bit-reg? a) ('+ (? index-reg? b) (? 8-bit-imm? c))) (assemble-ld-reg8-index-offset a b c)) 232 | (((? 8-bit-reg? a) ('+ (? 8-bit-imm? c) (? index-reg? b))) (assemble-ld-reg8-index-offset a b c)) 233 | (('a ((? 16-bit-reg? b))) (assemble-ld-a-ireg16 b)) 234 | (('a ((? 16-bit-imm-or-label? b))) (assemble-ld-a-imm16 b)) 235 | ((((? 16-bit-reg? b)) 'a) (assemble-ld-ireg16-a b)) 236 | ((((? 16-bit-imm-or-label? a)) 'a) (assemble-ld-iimm16-a a)) 237 | (((? 8-bit-reg? a) (? 8-bit-imm? b)) (assemble-ld-reg8-imm8 a b)) 238 | (((? 16-bit-reg? a) (? 16-bit-imm-or-label? b)) (assemble-ld-reg16-imm16 a b)) 239 | (((? 16-bit-reg? a) ((? 16-bit-imm-or-label? b))) (assemble-ld-reg16-iimm16 a b)) 240 | (('hl ((? 16-bit-imm-or-label? b))) (assemble-ld-hl-iimm16 b)) 241 | (((? index-reg? a) (? 16-bit-imm-or-label? b)) (assemble-ld-index-imm16 a b)) 242 | ((('+ (? index-reg? a) (? 8-bit-imm? b)) (? 8-bit-reg? c)) (assemble-ld-index-reg8 a b c)) 243 | ((('+ (? 8-bit-imm? b) (? index-reg? a)) (? 8-bit-reg? c)) (assemble-ld-index-reg8 a b c)) 244 | ((((? 16-bit-imm-or-label? a)) (? 16-bit-reg? b)) (assemble-ld-iimm-reg16 a b)) 245 | (_ 246 | (error (format #f "Invalid operands to ld: ~a" args)))) 247 | ) 248 | 249 | (define (simple-op? op) (lookup op simple-ops)) 250 | 251 | ;; Operations that don't receive arguments or have specific ones. 252 | (define simple-ops 253 | '((otdr . (#b11101101 #b10111011)) 254 | (lddr . (#b11101101 #b10111000)) 255 | (otir . (#b11101101 #b10110011)) 256 | (indr . (#b11101101 #b10110010)) 257 | (cpir . (#b11101101 #b10110001)) 258 | (ldir . (#b11101101 #b10110000)) 259 | (outd . (#b11101101 #b10101011)) 260 | (ind . (#b11101101 #b10101010)) 261 | (outi . (#b11101101 #b10100011)) 262 | (ldi . (#b11101101 #b10100000)) 263 | (rld . (#b11101101 #b01101111)) 264 | (rrd . (#b11101101 #b01100111)) 265 | (reti . (#b11101101 #b01001101)) 266 | (retn . (#b11101101 #b01000101)) 267 | (neg . (#b11101101 #b01000100)) 268 | (ei . (#b11111011)) 269 | (di . (#b11110011)) 270 | ((ex de hl) . (#b11101011)) 271 | ((ex (sp) hl) . (#b11100011)) 272 | (exx . (#b11011001)) 273 | (ret . (#b11001001)) 274 | (halt . (#b01110110)) 275 | (ccf . (#b00111111)) 276 | (scf . (#b00110111)) 277 | (cpl . (#b00101111)) 278 | (rra . (#b00011111)) 279 | (rla . (#b00010111)) 280 | (rrca . (#b00001111)) 281 | ((ex af afs) . (#b00001000)) 282 | (rlca . (#b00000111)) 283 | (nop . (#b00000000)) 284 | )) 285 | 286 | (define (assemble-simple a) 287 | (let ((res (lookup a simple-ops))) 288 | (if res 289 | (make-inst (length res) res) 290 | (error (format #f "Operation not found: ~a" a))))) 291 | 292 | (define (add-label! name val) 293 | (if (assv name *labels*) 294 | (error (format #f "Cannot add another label of ~a" name)) 295 | (begin 296 | (if verbose? 297 | (format #t "Adding label ~a with value 0x~4,'0x\n" name val)) 298 | (set! *labels* `((,name . ,val) . ,*labels*))))) 299 | 300 | (define (advance-pc! count) (set! *pc* (+ *pc* count))) 301 | 302 | (define (assemble-label name) 303 | (add-label! name *pc*) 304 | '()) 305 | 306 | (define (assemble-org new-pc) 307 | (set! *pc* new-pc) 308 | '()) 309 | 310 | (define (condition? s) (lookup s condition-codes)) 311 | 312 | (define (assemble-cond-jp cond imm16) 313 | (make-inst 3 (let ((imm16 (resolve-label imm16))) 314 | `(,(make-opcode (lookup cond condition-codes) 3 #b11000010) 315 | ,(lsb imm16) 316 | ,(msb imm16))))) 317 | 318 | (define (assemble-uncond-jp imm16) 319 | (make-inst 3 (let ((imm16 (resolve-label imm16))) 320 | `(#b11000011 321 | ,(lsb imm16) 322 | ,(msb imm16))))) 323 | 324 | (define (assemble-jp args) 325 | (match args 326 | ((('hl)) (make-inst 1 `(#b11101001))) 327 | (((? condition? a) b) (assemble-cond-jp a b)) 328 | (((? 16-bit-imm-or-label? a)) (assemble-uncond-jp a)) 329 | (_ 330 | (error (format #f "Invalid operands to jp: ~a" args))))) 331 | 332 | (define (signed-8-bit-imm? x) 333 | (and (integer? x) (>= 127 (abs x)))) 334 | 335 | (define (jr-simm8-convert x) 336 | (if (negative? x) (+ 256 x) x)) 337 | 338 | (define (resolve-jr-label-or-simm x) 339 | (if (symbol? x) 340 | (let* ((dest (resolve-label x)) 341 | (offset (- dest *pc*))) 342 | ;; (format #t "~a\n" *pc*) 343 | ;; Compute the offset from the current program counter 344 | (if (not (signed-8-bit-imm? offset)) 345 | (error (format #f "Operand to jr ~a not an 8-bit signed integer." offset)) 346 | (jr-simm8-convert offset))) 347 | (and (signed-8-bit-imm? x) 348 | (jr-simm8-convert (- x *pc*))))) 349 | 350 | (define (assemble-cond-jr cond simm8) 351 | (make-inst 2 (let ((simm8 (resolve-jr-label-or-simm simm8))) 352 | `(,(make-opcode (lookup cond condition-codes) 3 #b00100000) 353 | ,simm8)))) 354 | 355 | (define (assemble-uncond-jr simm8) 356 | (make-inst 2 (let ((simm8 (resolve-jr-label-or-simm simm8))) 357 | `(#b00011000 358 | ;; Follwed by a signed byte, -127 to +127 359 | ,simm8)))) 360 | 361 | (define (assemble-jr args) 362 | (match args 363 | (((? condition? a) b) (assemble-cond-jr a b)) 364 | (((? 16-bit-imm-or-label? a)) (assemble-uncond-jr a)) 365 | (_ 366 | (error (format #f "Invalid operands to jr: ~a" args))))) 367 | 368 | (define (assemble-cond-call cond imm16) 369 | (make-inst 3 (let ((imm16 (resolve-label imm16))) 370 | `(,(make-opcode (lookup cond condition-codes) 3 #b11000100) 371 | ,(lsb imm16) 372 | ,(msb imm16))))) 373 | 374 | (define (assemble-uncond-call imm16) 375 | (make-inst 3 (let ((imm16 (resolve-label imm16))) 376 | `(#b11001101 377 | ,(lsb imm16) 378 | ,(msb imm16))))) 379 | 380 | (define (assemble-call args) 381 | (match args 382 | (((? condition? a) (? 16-bit-imm-or-label? b)) (assemble-cond-call a b)) 383 | (((? 16-bit-imm-or-label? a)) (assemble-uncond-call a)) 384 | (_ 385 | (error (format #f "Invalid operands to call: ~a" args))))) 386 | 387 | (define (assemble-dw word-list) 388 | (make-inst (ash (length word-list) 1) 389 | (flatten (map 390 | (lambda (x) 391 | (let ((x (if (symbol? x) (resolve-label x) x))) 392 | (if x 393 | (list (lsb x) (msb x)) 394 | (error (format #f "Invalid word in dw: ~a" x))))) 395 | word-list)))) 396 | 397 | (define (assemble-db byte-list) 398 | (make-inst (length byte-list) 399 | (if (all-sat? 8-bit-imm? byte-list) 400 | byte-list 401 | (error (format #f "Invalid byte in db: ~a" byte-list))))) 402 | 403 | (define (assemble-out-iimm8-a port) 404 | (make-inst 2 `(#b11010011 405 | ,port))) 406 | 407 | (define (assemble-out-c-reg reg) 408 | (make-inst 2 `(#b11101011 409 | ,(make-opcode (lookup reg ld-regs) 3 #b01000001)))) 410 | 411 | (define (assemble-out arg) 412 | (match arg 413 | ((((? 8-bit-imm? p)) 'a) (assemble-out-iimm8-a p)) 414 | (`((c) ,(? 8-bit-reg? r)) (assemble-out-c-reg r)) 415 | (_ (error (format #f "Invalid operands to out: ~a" arg))))) 416 | 417 | (define (assemble-in-a-iimm8 imm8) 418 | (make-inst 2 `(#b11011011 419 | ,imm8))) 420 | 421 | (define (assemble-in-reg8-ic reg) 422 | (make-inst 2 `(#b11101011 423 | ,(make-opcode (lookup reg ld-regs) 3 #b01000000)))) 424 | 425 | (define (assemble-in arg) 426 | (match arg 427 | (('a ((? 8-bit-imm? p))) (assemble-in-a-iimm8 p)) 428 | (((? 8-bit-reg? r) '(c)) (assemble-in-reg8-ic r)) 429 | (_ (error (format #f "Invalid operands to out: ~a" arg))))) 430 | 431 | (define (assemble-xor-8-bit-reg a) 432 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 0 #b10101000)))) 433 | 434 | (define (assemble-xor-8-bit-imm a) 435 | (make-inst 2 `(#b11101110 436 | ,a))) 437 | 438 | (define (assemble-xor arg) 439 | (match arg 440 | ((? 8-bit-reg? a) (assemble-xor-8-bit-reg a)) 441 | ((? 8-bit-imm? a) (assemble-xor-8-bit-imm a)) 442 | (_ 443 | (error (format #f "Invalid operands to xor: ~a" arg))))) 444 | 445 | (define (assemble-dec-8-bit-reg a) 446 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 3 #b00000101)))) 447 | 448 | (define (assemble-dec-16-bit-reg a) 449 | (make-inst 1 `(,(make-opcode (lookup a 16-bit-regs) 4 #b00001011)))) 450 | 451 | (define (assemble-dec-index-reg a) 452 | (make-inst 2 `(,(lookup a ld-index-imm16-regs) 453 | #b00101011))) 454 | 455 | (define (assemble-dec arg) 456 | (match arg 457 | ((? 8-bit-reg? a) (assemble-dec-8-bit-reg a)) 458 | ((? 16-bit-reg? a) (assemble-dec-16-bit-reg a)) 459 | ((? index-reg? a) (assemble-dec-index-reg a)) 460 | (_ 461 | (error (format #f "Invalid operands to dec: ~a" arg))))) 462 | 463 | (define (assemble-inc-8-bit-reg arg) 464 | (make-inst 1 `(,(make-opcode (lookup arg ld-regs) 3 #b00000100)))) 465 | 466 | (define (assemble-inc-16-bit-reg arg) 467 | (make-inst 1 `(,(make-opcode (lookup arg 16-bit-regs) 4 #b00000011)))) 468 | 469 | 470 | (define (assemble-inc-index-reg arg) 471 | (make-inst 2 `(,(lookup arg ld-index-imm16-regs) 472 | #b00100011))) 473 | 474 | (define (assemble-inc arg) 475 | (match arg 476 | ((? 8-bit-reg? a) (assemble-inc-8-bit-reg a)) 477 | ((? 16-bit-reg? a) (assemble-inc-16-bit-reg a)) 478 | ((? index-reg? a) (assemble-inc-index-reg a)) 479 | (_ 480 | (error #f "Invalid operands to inc: ~a" arg)))) 481 | 482 | (define (assemble-bit imm3 reg8) 483 | (make-inst 2 `(#b11001011 484 | ,(make-opcode imm3 485 | 3 486 | (make-opcode (lookup reg8 ld-regs) 0 #b01000000))))) 487 | 488 | (define (assemble-res imm3 reg8) 489 | (make-inst 2 `(#b11001011 490 | ,(make-opcode imm3 491 | 3 492 | (make-opcode (lookup reg8 ld-regs) 0 #b10000000))))) 493 | 494 | (define (assemble-set imm3 reg) 495 | (cond ((8-bit-reg? reg) 496 | (make-inst 2 `(#b11001011 497 | ,(make-opcode imm3 498 | 3 499 | (make-opcode (lookup reg ld-regs) 0 #b11000000))))) 500 | ((index-reg? (car reg)) 501 | (make-inst 4 `(,(lookup (car reg) ld-index-imm16-regs) 502 | #b11001011 503 | ;; No offset for now. 504 | #b00000000 505 | ,(make-opcode imm3 3 #b11000110)))) 506 | (else 507 | (error (format #f "Invalid operands to set: ~a" `(,imm3 ,reg)))))) 508 | 509 | (define (assemble-adc-8-bit-reg reg) 510 | (make-inst 1 `(,(make-opcode (lookup reg ld-regs) 0 #b10001000)))) 511 | 512 | (define (assemble-adc-16-bit-reg reg) 513 | (make-inst 2 `(#b11101101 514 | ,(make-opcode (lookup reg 16-bit-regs) 4 #b01001010)))) 515 | 516 | (define (assemble-adc arg) 517 | (match arg 518 | (`(a ,(? 8-bit-reg? a)) 519 | (assemble-adc-8-bit-reg a)) 520 | (`(hl ,(? 16-bit-reg? a)) 521 | (assemble-adc-16-bit-reg a)) 522 | (_ 523 | (error (format #f "Invalid operands to adc: ~a" arg))))) 524 | 525 | (define (assemble-and-8-bit-reg a) 526 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 0 #b10100000)))) 527 | 528 | (define (assemble-and-8-bit-imm a) 529 | (make-inst 2 `(#b11100110 ,a))) 530 | 531 | (define (assemble-and-index-reg a) 532 | (make-inst 3 `(,(lookup a ld-index-imm16-regs) 533 | #b10100110 534 | ;; No offset for now. 535 | #b00000000))) 536 | 537 | (define (assemble-and arg) 538 | (match arg 539 | ((? 8-bit-reg? a) (assemble-and-8-bit-reg a)) 540 | ((? 8-bit-imm? a) (assemble-and-8-bit-imm a)) 541 | (((? index-reg? a)) (assemble-and-index-reg a)) 542 | (_ 543 | (error (format #f "Invalid operands to and: ~a" arg))))) 544 | 545 | (define (assemble-or-8-bit-reg a) 546 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 0 #b10110000)))) 547 | 548 | (define (assemble-or-8-bit-imm a) 549 | (make-inst 2 `(#b11110110 ,a))) 550 | 551 | (define (assemble-or arg) 552 | (match arg 553 | ((? 8-bit-reg? a) (assemble-or-8-bit-reg a)) 554 | ((? 8-bit-imm? a) (assemble-or-8-bit-imm a)) 555 | (_ 556 | (error (format #f "Invalid operands to or: ~a" arg))))) 557 | 558 | (define (assemble-ret-cond c) 559 | (make-inst 1 `(,(make-opcode (lookup c condition-codes) 3 #b11000000)))) 560 | 561 | (define (assemble-add-hl-reg16 a) 562 | (make-inst 1 `(,(make-opcode (lookup a 16-bit-regs) 4 #b00001001)))) 563 | 564 | (define (assemble-add-reg8 a) 565 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 0 #b10000000)))) 566 | 567 | (define (assemble-add-index-reg16 a b) 568 | (make-inst 2 `(,(if (eq? a 'ix) #b11011101 #b11111101) 569 | ,(make-opcode (lookup b 16-bit-regs) 4 #b00001001)))) 570 | 571 | (define (assemble-add-imm8 a) 572 | (make-inst 2 `(#b11000110 ,a))) 573 | 574 | (define (assemble-add arg) 575 | (match arg 576 | (('hl (? 16-bit-reg? a)) (assemble-add-hl-reg16 a)) 577 | (((? index-reg? a) (? 16-bit-reg? b)) (assemble-add-index-reg16 a b)) 578 | (('a (? 8-bit-reg? a)) (assemble-add-reg8 a)) 579 | (('a (? 8-bit-imm? a)) (assemble-add-imm8 a)) 580 | (_ 581 | (error (format #f "Invalid operands to add: ~a" arg))))) 582 | 583 | (define (assemble-sub-reg8 a) 584 | (make-inst 1 `(,(make-opcode (lookup a ld-regs) 0 #b10010000)))) 585 | 586 | (define (assemble-sub-imm8 a) 587 | (make-inst 2 `(#b11010110 ,a))) 588 | 589 | (define (assemble-sub arg) 590 | (match arg 591 | (((? 8-bit-reg? a)) (assemble-sub-reg8 a)) 592 | (((? 8-bit-imm? a)) (assemble-sub-imm8 a)) 593 | (_ 594 | (error (format #f "Invalid operands to sub: ~a" arg))))) 595 | 596 | (define (assemble-ret arg) 597 | (match arg 598 | ((? condition? a) (assemble-ret-cond a)) 599 | (_ 600 | (error (format #f "Invalid operands to ret: ~a" arg))))) 601 | 602 | (define (assemble-cp-reg8 arg) 603 | (make-inst 1 `(,(make-opcode (lookup arg ld-regs) 0 #b10111000)))) 604 | 605 | (define (assemble-cp-imm8 arg) 606 | (make-inst 2 `(#b11111110 ,arg))) 607 | 608 | 609 | (define (assemble-cp arg) 610 | (match arg 611 | ((? 8-bit-reg? arg) (assemble-cp-reg8 arg)) 612 | ((? 8-bit-imm? arg) (assemble-cp-imm8 arg)) 613 | (_ 614 | (error (format #f "Invalid operands to cp: ~a" arg))))) 615 | 616 | (define (assemble-sbc-hl-reg16 a) 617 | (make-inst 2 `(#b11101101 618 | ,(make-opcode (lookup a 16-bit-regs) 4 #b01000010)))) 619 | 620 | (define (assemble-sbc arg) 621 | (match arg 622 | (('hl (? 16-bit-reg? a)) (assemble-sbc-hl-reg16 a)) 623 | (_ 624 | (error (format #f "Invalid operands to sbc: ~a" arg))))) 625 | 626 | (define (assemble-im arg) 627 | (match arg 628 | (0 (make-inst 2 '(#b11101101 #b01000110))) 629 | (1 (make-inst 2 '(#b11101101 #b01010110))) 630 | (2 (make-inst 2 '(#b11101101 #b01011110))))) 631 | 632 | (define (assemble-sla-reg8 a) 633 | (make-inst 2 `(#b11001011 634 | ,(make-opcode (lookup a ld-regs) 0 #b00100000)))) 635 | 636 | (define (assemble-sla arg) 637 | (match arg 638 | ((? 8-bit-reg? a) (assemble-sla-reg8 a)) 639 | (_ 640 | (error (format #f "Invalid operands to sla: ~a" arg))))) 641 | 642 | (define (assemble-rl-reg8 a) 643 | (make-inst 2 `(#b11001011 644 | ,(make-opcode (lookup a ld-regs) 0 #b00010000)))) 645 | 646 | (define (assemble-rl arg) 647 | (match arg 648 | ((? 8-bit-reg? a) (assemble-rl-reg8 a)) 649 | (_ 650 | (error (format #f "Invalid operands to rl: ~a" arg))))) 651 | 652 | (define (assemble-rr-reg8 a) 653 | (make-inst 2 `(#b11001011 ,(make-opcode (lookup a ld-regs) 0 #b00011000)))) 654 | 655 | (define (assemble-rr arg) 656 | (match arg 657 | ((? 8-bit-reg? a) (assemble-rr-reg8 a)) 658 | (_ 659 | (error (format #f "Invalid operands to rr: ~a" arg))))) 660 | 661 | (define (assemble-djnz simm8) 662 | (make-inst 2 663 | (let ((simm8 (resolve-jr-label-or-simm simm8))) 664 | `(#b00010000 665 | ;; Follwed by a signed byte, -127 to +127 666 | ,simm8)))) 667 | 668 | (define (assemble-srl-reg8 a) 669 | (make-inst 2 670 | `(#b11001011 671 | ,(make-opcode (lookup a ld-regs) 0 #b00111000)))) 672 | 673 | (define (assemble-srl arg) 674 | (match arg 675 | ((? 8-bit-reg? a) (assemble-srl-reg8 a)) 676 | (_ 677 | (error (format #f "Invalid operands to srl: ~a" arg))))) 678 | 679 | (define rst-numbers 680 | '((#x00 . #b000) 681 | (#x08 . #b001) 682 | (#x10 . #b010) 683 | (#x18 . #b011) 684 | (#x20 . #b100) 685 | (#x28 . #b101) 686 | (#x30 . #b110) 687 | (#x38 . #b111))) 688 | 689 | (define (rst-number? a) (lookup a rst-numbers)) 690 | 691 | (define (assemble-rst arg) 692 | (match arg 693 | ((? rst-number? a) 694 | (make-inst 1 695 | `(,(make-opcode (lookup a rst-numbers) 696 | 3 697 | #b11000111)))) 698 | (_ 699 | (error (format #f "Invalid operands to rst: ~a" arg))))) 700 | 701 | (define (assemble-expr expr) 702 | ;; Pattern match EXPR against the valid instructions and dispatch to 703 | ;; the corresponding sub-assembler. 704 | (match expr 705 | (((? simple-op? a)) (assemble-simple a)) 706 | (`(ld ,dest ,src) (assemble-ld `(,dest ,src))) 707 | (`(push ,arg) (assemble-push arg)) 708 | (`(pop ,arg) (assemble-pop arg)) 709 | (`(label ,name) (assemble-label name)) 710 | (`(org ,(? 16-bit-imm? a)) (assemble-org a)) 711 | (`(jp . ,args) (assemble-jp args)) 712 | (`(jr . ,args) (assemble-jr args)) 713 | (`(call . ,args) (assemble-call args)) 714 | (`(add . ,args) (assemble-add args)) 715 | (`(sub . ,args) (assemble-sub args)) 716 | (`(sbc . ,args) (assemble-sbc args)) 717 | (`(adc . ,args) (assemble-adc args)) 718 | (`(bit ,imm3 ,arg) (assemble-bit imm3 arg)) 719 | (`(res ,imm3 ,arg) (assemble-res imm3 arg)) 720 | (`(set ,imm3 ,arg) (assemble-set imm3 arg)) 721 | (`(ret ,arg) (assemble-ret arg)) 722 | (`(db ,arg) (assemble-db arg)) 723 | (`(dw ,arg) (assemble-dw arg)) 724 | (`(out ,dest ,src) (assemble-out `(,dest ,src))) 725 | (`(in ,dest ,src) (assemble-in `(,dest ,src))) 726 | (`(xor ,arg) (assemble-xor arg)) 727 | (`(cp ,arg) (assemble-cp arg)) 728 | (`(or ,arg) (assemble-or arg)) 729 | (`(dec ,arg) (assemble-dec arg)) 730 | (`(inc ,arg) (assemble-inc arg)) 731 | (`(and ,arg) (assemble-and arg)) 732 | (`(im ,arg) (assemble-im arg)) 733 | (`(sla ,arg) (assemble-sla arg)) 734 | (`(rl ,arg) (assemble-rl arg)) 735 | (`(rr ,arg) (assemble-rr arg)) 736 | (`(djnz ,arg) (assemble-djnz arg)) 737 | (`(srl ,arg) (assemble-srl arg)) 738 | (`(rst ,arg) (assemble-rst arg)) 739 | (_ (error (format #f "Unknown expression: ~a" expr)))) 740 | ) 741 | 742 | (define *pc* 0) 743 | (define *labels* 0) 744 | (define (reset-pc!) (set! *pc* 0)) 745 | (define (reset-labels!) (set! *labels* '())) 746 | 747 | (define (write-bytevector-to-file bv fn) 748 | (let ((port (open-output-file fn))) 749 | (put-bytevector port bv) 750 | (close-port port))) 751 | 752 | (define (flatten l) 753 | (if (null? l) 754 | '() 755 | (append (car l) (flatten (cdr l))))) 756 | 757 | (define (all-sat? p l) 758 | (cond ((null? l) #t) 759 | ((p (car l)) (all-sat? p (cdr l))) 760 | (else #f))) 761 | 762 | (define (pass1 exprs) 763 | ;; Check each instruction for correct syntax and produce code 764 | ;; generating thunks. Meanwhile, increment PC accordingly and build 765 | ;; up labels. 766 | (reset-labels!) 767 | (reset-pc!) 768 | (format #t "Pass one...\n") 769 | 770 | ;; Every assembled instruction, or inlined procedure should return a 771 | ;; value. A value of () indicates that it will not be included in 772 | ;; pass 2. 773 | (filter 774 | (lambda (x) (not (null? (car x)))) 775 | ;; Order of SRFI1 map is unspecified, but Guile's map-in-order goes from 776 | ;; left to right. 777 | (map-in-order 778 | (lambda (expr) 779 | (if (procedure? expr) 780 | ;; Evaluate an inlined procedure (could do anything(!)). 781 | (let ((macro-val (expr))) 782 | ;; But that procedure has to return () or an instruction 783 | ;; record. 784 | (if (not (or (null? macro-val) 785 | (inst? macro-val))) 786 | (error (format #f 787 | "Error during pass one: macro did not return an instruction record: instead got ~a. PC: ~a" 788 | macro-val 789 | *pc*)) 790 | (begin (if (inst? macro-val) 791 | ;; This macro generated an instruction 792 | ;; record, so advance the program counter. 793 | (advance-pc! (inst-length macro-val))) 794 | ;; Return a "tagged" result, where the original 795 | ;; expression is preserved for debugging. 796 | (cons macro-val expr)))) 797 | 798 | ;; Assemble a normal instruction. 799 | (let ((res (assemble-expr expr))) 800 | (if (inst? res) 801 | (advance-pc! (inst-length res))) 802 | ;; Return a "tagged" result, where the original expression 803 | ;; is preserved, for debugging.. 804 | (cons res expr)))) 805 | exprs))) 806 | 807 | (define (pass2 insts) 808 | (reset-pc!) 809 | (format #t "Pass two...\n") 810 | ;; Force the code generating thunks. All labels should be resolved by now. 811 | (map-in-order 812 | (lambda (x) 813 | (if (not (inst? (car x))) 814 | (error (format #f "Pass 2: not an instruction record: ~a. PC: ~a." (car x) (num->hex *pc*)))) 815 | (advance-pc! (inst-length (car x))) 816 | (let ((res (gen-inst (car x)))) 817 | (if verbose? (format #t "PC: ~a ~a\n" (num->hex *pc*) (cdr x))) 818 | (cond 819 | ;; Check consistency of declared instruction length and actual 820 | ;; length. 821 | ((not (= (inst-length (car x)) (length res))) 822 | (error (format #f 823 | "Pass 2: Instruction length declared does not match actual: Expected length ~a, got length ~a of expression ~a\n PC: ~a" 824 | (inst-length (car x)) 825 | (length res) 826 | res 827 | *pc*))) 828 | ;; Check that everything is an 8-bit unsigned number. 829 | ((not (all-sat? 8-bit-imm? res)) 830 | (error (format #f "Invalid byte at ~4'0x: ~a" *pc* res))) 831 | (else 832 | ;; We're ok. 833 | res)))) 834 | insts)) 835 | 836 | (define (assemble-prog prog) 837 | (pass2 (pass1 prog))) 838 | 839 | (define (assemble-to-binary prog) 840 | (map num->binary (flatten (assemble-prog prog)))) 841 | 842 | (define (assemble-to-hex prog) 843 | (map num->hex (flatten (assemble-prog prog)))) 844 | 845 | (define (assemble-to-file prog filename) 846 | (write-bytevector-to-file 847 | (u8-list->bytevector (flatten (assemble-prog prog))) 848 | filename)) 849 | 850 | ;; Take n elements from a list. 851 | (define (take n list) 852 | (if (or (zero? n) (null? list)) 853 | '() 854 | (cons (car list) 855 | (take (1- n) (cdr list))))) 856 | 857 | ;; For debugging purposes. Assemble the program and find the 858 | ;; instruction that is at the specified byte address. 859 | (define (assemble-find-instr-byte byte prog context) 860 | (let ((partial-asm (pass1 prog))) 861 | (let loop ((pc 0) (rest-insts partial-asm)) 862 | (cond ((null? rest-insts) (error (format #f "Reached end of program before specified address ~a" byte))) 863 | ((>= pc byte) 864 | (map cdr (take context rest-insts))) 865 | (else 866 | (loop (+ pc (inst-length (caar rest-insts))) 867 | (cdr rest-insts))))))) 868 | -------------------------------------------------------------------------------- /src/boot.fs: -------------------------------------------------------------------------------- 1 | CLEAR-SCREEN ORIGIN 2 | \ This is the first file to be loaded. Just go straight to the first 3 | \ bootstrap file! 4 | : STAGE1 5 | \ Try to set RAM Memory region A to be the first RAM flash page. 6 | 1 SET-RAM-MEMA 7 | IF 8 | \ We set the input pointer to point to memory bank A. 9 | MEMA INPUT-PTR ! 10 | ELSE 11 | \ Something went wrong. Shutdown. 12 | \ Print "ERR" 13 | ." ERR 9999" 14 | PAUSE POWEROFF 15 | THEN 16 | ; 17 | 18 | STAGE1 19 | -------------------------------------------------------------------------------- /src/boot.scm: -------------------------------------------------------------------------------- 1 | (define boot-asm 2 | `((label boot) 3 | (label shutdown) 4 | (di) 5 | (ld a 6) 6 | (out (4) a) 7 | (ld a #x81) 8 | (out (7) a) 9 | (ld sp 0) 10 | (call sleep) 11 | 12 | (label restart) 13 | (label reboot) 14 | (di) 15 | (ld sp 0) 16 | (ld a 6) 17 | (out (4) a) 18 | (ld a #x81) 19 | (out (7) a) 20 | (ld a 3) 21 | (out (#xe) a) 22 | (xor a) 23 | (out (#xf) a) 24 | (call unlock-flash) 25 | (xor a) 26 | (out (#x25) a) 27 | (dec a) 28 | (out (#x26) a) 29 | (out (#x23) a) 30 | (out (#x22) a) 31 | (call lock-flash) 32 | (ld a 1) 33 | (out (#x20) a) 34 | 35 | 36 | (ld a #b0001011) 37 | (out (3) a) 38 | (ld hl #x8000) 39 | (ld (hl) 0) 40 | (ld de #x8001) 41 | (ld bc #x7fff) 42 | (ldir) 43 | 44 | 45 | ;; Arbitrarily complicated macros! 46 | ,@(concat-map (lambda (x) 47 | `((ld a ,x) 48 | ;; (call #x50f) 49 | (call lcd-delay) 50 | (out (#x10) a))) 51 | '(5 1 3 #x17 #xb #xef)) 52 | 53 | ;; "main", after everything has been set up. 54 | ;; Just go straight to the Forth portion! 55 | ,@forth-asm 56 | (jp shutdown))) 57 | -------------------------------------------------------------------------------- /src/bootstrap-flash1.fs: -------------------------------------------------------------------------------- 1 | \ We define the rest of Forth. 2 | 3 | \ Possibly test interrupts later. 4 | \ : BAR FOO 200 SET-INTERRUPT ; 5 | \ BAR 6 | 7 | \ Parse the next word as binary number. 8 | : %B 9 | 0 10 | BEGIN 11 | GETC DUP NUM? NOT 12 | IF 13 | DROP STATE @ IF ' LIT , , THEN EXIT 14 | ELSE 15 | '0' - SWAP 2* + 16 | THEN 17 | AGAIN 18 | ; IMMEDIATE 19 | 20 | 21 | HERE 22 | %B 00000000 C, 23 | %B 00000000 C, 24 | %B 00100100 C, 25 | %B 01000010 C, 26 | %B 01000010 C, 27 | %B 01000010 C, 28 | %B 01000010 C, 29 | %B 00100100 C, 30 | CONSTANT ZKEME80-LOGO-00 31 | 32 | HERE 33 | %B 00000000 C, 34 | %B 00011000 C, 35 | %B 00100100 C, 36 | %B 00100100 C, 37 | %B 00011000 C, 38 | %B 00100100 C, 39 | %B 00100100 C, 40 | %B 00011000 C, 41 | CONSTANT ZKEME80-LOGO-01 42 | 43 | HERE 44 | %B 00000000 C, 45 | %B 00011000 C, 46 | %B 00100100 C, 47 | %B 00100100 C, 48 | %B 00100100 C, 49 | %B 00100100 C, 50 | %B 00011000 C, 51 | %B 00000000 C, 52 | CONSTANT ZKEME80-LOGO-11 53 | 54 | HERE 55 | %B 00000000 C, 56 | %B 00000000 C, 57 | %B 01111100 C, 58 | %B 00001000 C, 59 | %B 00010000 C, 60 | %B 00100000 C, 61 | %B 01111100 C, 62 | %B 00000000 C, 63 | CONSTANT ZKEME80-LOGO-10 64 | 65 | HERE 66 | %B 00000000 C, 67 | %B 00000000 C, 68 | %B 00111100 C, 69 | %B 00111100 C, 70 | %B 00111100 C, 71 | %B 00111100 C, 72 | %B 00000000 C, 73 | %B 00000000 C, 74 | CONSTANT LOADING-DOT 75 | 76 | 38 VALUE ZKEME80-LOGO-STARTX 77 | 27 VALUE ZKEME80-LOGO-STARTY 78 | 79 | 30 VALUE DOT-X 80 | 45 VALUE DOT-Y 81 | 82 | : DRAW-LOGO ( addr x y -- ) 8 -ROT PUT-SPRITE-XOR ; 83 | 84 | : DRAW-LOADING-DOT LOADING-DOT DOT-X DOT-Y DRAW-LOGO 8 +TO DOT-X ; 85 | 86 | : ZKEME80-LOGO 87 | ZKEME80-LOGO-STARTX 5 - ZKEME80-LOGO-STARTY 9 - 88 | AT-XY ." zkeme80" 89 | ZKEME80-LOGO-00 ZKEME80-LOGO-STARTX ZKEME80-LOGO-STARTY DRAW-LOGO 90 | ZKEME80-LOGO-01 ZKEME80-LOGO-STARTX 8 + ZKEME80-LOGO-STARTY DRAW-LOGO 91 | ZKEME80-LOGO-10 ZKEME80-LOGO-STARTX ZKEME80-LOGO-STARTY 8 + DRAW-LOGO 92 | ZKEME80-LOGO-11 ZKEME80-LOGO-STARTX 8 + ZKEME80-LOGO-STARTY 8 + DRAW-LOGO 93 | ZKEME80-LOGO-STARTX ZKEME80-LOGO-STARTY 16 16 94 | RECT-XOR 95 | ; 96 | 97 | ZKEME80-LOGO 98 | DRAW-LOADING-DOT 99 | 100 | : LOAD-TEST-SUITE 101 | 4 SET-RAM-MEMA 102 | IF 103 | MEMA INPUT-PTR ! 104 | ELSE 105 | ." Couldn't load the test 106 | suite. Shutting down." CR 107 | SHUTDOWN 108 | THEN 109 | ; 110 | 111 | : LOAD-SHELL 112 | 5 SET-RAM-MEMA 113 | IF 114 | MEMA INPUT-PTR ! 115 | ELSE 116 | ." Couldn't load the test 117 | suite. Shutting down." CR 118 | SHUTDOWN 119 | THEN 120 | ; 121 | 122 | \ Bit shifts are not fast! 123 | 124 | : RSHIFT ?DUP IF 0 DO 2/ LOOP THEN ; 125 | : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ; 126 | 127 | : TYPE 0 DO DUP C@ EMIT 1+ LOOP DROP ; 128 | 129 | : UNLOOP ( -- , r: i limit -- : remove limit and i from ) 130 | R> ( save our return address ) 131 | RDROP ( pop off i ) 132 | RDROP ( pop off limit ) 133 | >R 134 | ; 135 | 136 | \ This is not correct. It should break out to the words following the 137 | \ DO ... LOOP construct, rather than existing the currently running 138 | \ word entirely. 139 | 140 | : LEAVE ( -- , r: i limit return -- : break out of a do-loop construct ) 141 | UNLOOP 142 | RDROP 143 | ; ( return to the caller's caller routine ) 144 | 145 | 146 | : BEGIN-STRUCTURE \ -- addr 0 ; -- size 147 | CREATE 148 | HERE 0 0 , \ mark stack, lay dummy 149 | DOES> @ \ -- rec-len 150 | ; 151 | 152 | : +FIELD \ n <"name"> -- ; Exec: addr -- 'addr 153 | CREATE OVER , + 154 | DOES> @ + 155 | ; 156 | 157 | : FIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) 158 | 1 CELLS +FIELD 159 | ; 160 | 161 | : END-STRUCTURE \ addr n -- 162 | SWAP ! 163 | ; \ set len 164 | 165 | \ Non-standard for now. 166 | \ Display n defined words. 167 | 168 | : WORDS ( n -- ) 169 | LATEST @ SWAP 0 DO 170 | ?DUP IF 171 | DUP ?HIDDEN NOT IF 172 | DUP ID. SPACE 173 | THEN 174 | @ 175 | ELSE 176 | LEAVE 177 | THEN 178 | LOOP 179 | DROP 180 | ; 181 | 182 | \ Returns the number of words defined. 183 | 184 | : NUMBER-OF-WORDS ( -- n ) 185 | 0 HERE ! LATEST @ 186 | BEGIN 187 | ?DUP 188 | WHILE 189 | DUP ?HIDDEN NOT 190 | IF 1 HERE +! THEN 191 | @ 192 | REPEAT 193 | HERE @ 194 | ; 195 | 196 | : STATUS 197 | DECIMAL UNUSED . 198 | ." bytes available" CR 199 | HEX HERE ." HERE is at " . CR DECIMAL 200 | ." Stack has contents" CR 201 | .S 202 | ; 203 | 204 | 205 | 1 CONSTANT RIGHT 206 | 2 CONSTANT LEFT 207 | 3 CONSTANT UP 208 | 4 CONSTANT DOWN 209 | 210 | DRAW-LOADING-DOT 211 | \ Simple grid menu system demo. 212 | 213 | \ Make a grid of cells. 214 | : GRID ( width height "name" -- ) 215 | CREATE OVER , * CELLS ALLOT 216 | DOES> ( x y -- addr ) DUP CELL+ >R @ * + CELLS R> + 217 | ; 218 | 219 | \ Grid parameters. 220 | 2 CONSTANT ROWS 221 | 2 CONSTANT COLUMNS 222 | 223 | \ The contents of the menu choices should be pointers to menu entry 224 | \ structures. 225 | ROWS COLUMNS GRID MENU-ENTRIES 226 | 227 | \ Menu entry structures contain pointers to routines that draw the 228 | \ selection and deselection updates, and what the menu entry should do 229 | \ when it's clicked through. 230 | BEGIN-STRUCTURE MENU-ENTRY 231 | \ An xt of type ( -- ) that selects the menu entry. 232 | FIELD: MENU-ENTRY.SELECTOR 233 | \ An xt of type ( -- ) that deselects the menu entry. 234 | FIELD: MENU-ENTRY.DESELECTOR 235 | \ An xt of type ( -- ) that is the menu entry's action. 236 | FIELD: MENU-ENTRY.ON-CLICK 237 | END-STRUCTURE 238 | 239 | : NEW-MENU-ENTRY ( x y [parse: "name"] -- ) 240 | MENU-ENTRIES \ addr to write to 241 | HERE DUP MENU-ENTRY ALLOT CREATE 242 | ['] LIT , , ['] EXIT , 243 | SWAP ! 244 | ; 245 | 246 | : STATUS 247 | DECIMAL UNUSED . 248 | ." bytes available" CR 249 | HEX HERE ." HERE is at " . CR DECIMAL 250 | ." Stack has contents" CR 251 | .S 252 | ; 253 | 254 | \ Have we clicked through? 255 | 0 VALUE CLICKED? 256 | VARIABLE XPOS 257 | VARIABLE YPOS 258 | ROWS 1- CONSTANT MENU-MAX-X 259 | COLUMNS 1- CONSTANT MENU-MAX-Y 260 | 261 | : INC! 1 SWAP +! ; 262 | : DEC! 1 SWAP -! ; 263 | 264 | : INC-XPOS XPOS INC! ; 265 | : INC-YPOS YPOS INC! ; 266 | 267 | : DEC-XPOS XPOS @ IF XPOS DEC! THEN ; 268 | : DEC-YPOS YPOS @ IF YPOS DEC! THEN ; 269 | 270 | : NORMALIZE-X XPOS @ MENU-MAX-X MIN XPOS ! ; 271 | : NORMALIZE-Y YPOS @ MENU-MAX-Y MIN YPOS ! ; 272 | : NORMALIZE-POS NORMALIZE-X NORMALIZE-Y ; 273 | 274 | \ Takes and arrow key and updates XPOS and YPOS. 275 | : MAYBE-UPDATE-XY ( arrow-key -- ) 276 | CASE 277 | RIGHT OF INC-XPOS ENDOF 278 | LEFT OF DEC-XPOS ENDOF 279 | UP OF INC-YPOS ENDOF 280 | DOWN OF DEC-YPOS ENDOF 281 | ENDCASE 282 | NORMALIZE-POS 283 | ; 284 | 285 | 0 0 NEW-MENU-ENTRY TOP-LEFT 286 | 1 0 NEW-MENU-ENTRY TOP-RIGHT 287 | 0 1 NEW-MENU-ENTRY BOTTOM-LEFT 288 | 1 1 NEW-MENU-ENTRY BOTTOM-RIGHT 289 | 290 | : DRAW-XOR-SQUARE ( x y size -- ) DUP RECT-XOR ; 291 | 292 | : DRAW-AND-SQUARE ( x y size -- ) DUP RECT-AND ; 293 | 294 | : DRAW-SQUARE ( x y size -- ) DUP RECT-OR ; 295 | 296 | : DRAW-SQUARE-WITH-BORDER ( x y size border -- ) 297 | HERE ! 298 | \ Draw the default box 299 | 0 2OVER 2OVER DROP DRAW-SQUARE DROP 300 | \ Double the border and subtract from the size. 301 | \ ( x y size' ) 302 | HERE @ 2* - ROT HERE @ + ROT HERE @ + ROT DRAW-AND-SQUARE 303 | ; 304 | 305 | DRAW-LOADING-DOT 306 | 307 | HERE 308 | %B 00000000 C, 309 | %B 00110000 C, 310 | %B 00001000 C, 311 | %B 00001000 C, 312 | %B 00010000 C, 313 | %B 00000000 C, 314 | %B 00010000 C, 315 | %B 00000000 C, 316 | CONSTANT INFO-SPRITE 317 | 318 | HERE 319 | %B 00000000 C, 320 | %B 00010000 C, 321 | %B 00010000 C, 322 | %B 01010100 C, 323 | %B 01010100 C, 324 | %B 01000100 C, 325 | %B 00111000 C, 326 | %B 00000000 C, 327 | CONSTANT POWEROFF-SPRITE 328 | 329 | HERE 330 | %B 00000000 C, 331 | %B 00000000 C, 332 | %B 01001000 C, 333 | %B 00100100 C, 334 | %B 00010010 C, 335 | %B 00100100 C, 336 | %B 01001000 C, 337 | %B 00000000 C, 338 | CONSTANT SHELL-SPRITE 339 | 340 | HERE 341 | %B 00000000 C, 342 | %B 00000000 C, 343 | %B 01111100 C, 344 | %B 00010000 C, 345 | %B 00010000 C, 346 | %B 00010000 C, 347 | %B 00010000 C, 348 | %B 00000000 C, 349 | CONSTANT TEST-SPRITE 350 | 351 | 20 CONSTANT BUTTON-SIZE 352 | 1 CONSTANT BORDER-SIZE 353 | 354 | \ Where the menu starts drawing. 355 | 5 CONSTANT MENU-STARTX 356 | 12 CONSTANT MENU-STARTY 357 | 358 | \ Logo offsets 359 | 7 CONSTANT LOGO-OFFSETX 360 | 6 CONSTANT LOGO-OFFSETY 361 | 362 | \ Button spacing 363 | 5 CONSTANT BUTTON-SPACING 364 | 365 | : MENU-START MENU-STARTX MENU-STARTY ; 366 | : DRAW-SELECTED-BUTTON BUTTON-SIZE DRAW-SQUARE ; 367 | : DRAW-DESELECTED-BUTTON BUTTON-SIZE BORDER-SIZE DRAW-SQUARE-WITH-BORDER ; 368 | 369 | \ The number of pixels taken by n buttons. 370 | : BUTTONS ( n -- pixels ) BUTTON-SIZE BUTTON-SPACING + * ; 371 | \ Convert an x/y position of the menu into pixel x/y coordinates. 372 | : BUTTON-COORDS ( x y -- px py ) 373 | BUTTONS MENU-STARTY + SWAP BUTTONS MENU-STARTX + SWAP 374 | ; 375 | 376 | : CLEAR-TITLE 0 0 MAX-COL 5 RECT-AND ; 377 | 378 | VARIABLE CURRENT-TITLE 379 | 380 | : TEST-TITLE ORIGIN ." Run the test suite. " ; 381 | : POWEROFF-TITLE ORIGIN ." Shut down the device. " ; 382 | : INFO-TITLE ORIGIN ." View system information." ; 383 | : SHELL-TITLE ORIGIN ." Start a shell. " ; 384 | 385 | \ Add logo offset x 386 | : +LOX LOGO-OFFSETX + ; 387 | 388 | \ Add logo offset y 389 | : +LOY LOGO-OFFSETY + ; 390 | 391 | \ What's the current menu entry? 392 | : CURRENT-MENU-ENTRY ( -- ) XPOS @ YPOS @ MENU-ENTRIES @ ; 393 | \ Maybe execute something. 394 | : ?EXECUTE ( n -- ) ?DUP IF EXECUTE THEN ; 395 | \ Given a pointer to a menu entry, run its selector xt if it's not null. 396 | : ?RUN-SELECTOR ( menu-entry -- ) ?DUP IF MENU-ENTRY.SELECTOR @ ?EXECUTE THEN ; 397 | \ Given a pointer to a menu entry, run its deselector xt if it's not null. 398 | : ?RUN-DESELECTOR ( menu-entry -- ) ?DUP IF MENU-ENTRY.DESELECTOR @ ?EXECUTE THEN ; 399 | \ Given a pointer to a menu entry, run its on click xt if it's not null. 400 | : ?RUN-ON-CLICK ( menu-entry -- ) ?DUP IF MENU-ENTRY.ON-CLICK @ ?EXECUTE THEN ; 401 | \ Deselect the previous menu entry. 402 | : DESELECT-PREV ( -- ) CURRENT-MENU-ENTRY ?RUN-DESELECTOR ; 403 | \ Deselect the specified entry at (x, y). 404 | : DESELECT-ENTRY ( x y -- ) MENU-ENTRIES @ ?RUN-DESELECTOR ; 405 | \ Run the selector at the current menu choice. 406 | : DRAW-TICK ( -- ) CURRENT-MENU-ENTRY ?RUN-SELECTOR ; 407 | 408 | DRAW-LOADING-DOT 409 | 410 | \ Is n an arrow key? 411 | : ARROW-KEY? ( n -- b ) DUP 1 4 WITHIN SWAP 9 = OR ; 412 | \ Block until an arrow key is read. 413 | : GET-ARROW-KEY ( -- k ) BEGIN KEYC DUP ARROW-KEY? IF EXIT THEN DROP AGAIN ; 414 | \ Set the click flag iff the xt is not null. 415 | : ?DO-CLICK ( xt|0 -- ) DUP MENU-ENTRY.ON-CLICK @ IF 1 TO CLICKED? THEN ; 416 | \ Maybe the key is enter, and act on it. 417 | : MAYBE-ENTER ( n -- ) 9 = IF CURRENT-MENU-ENTRY ?DO-CLICK ?RUN-ON-CLICK THEN ; 418 | \ Act upon a key code. 419 | : MAYBE-ACT ( k -- ) DUP MAYBE-UPDATE-XY MAYBE-ENTER ; 420 | \ One tick of the menu demo. 421 | : MENU-DEMO-TICK ( -- ) GET-ARROW-KEY DESELECT-PREV MAYBE-ACT DRAW-TICK ; 422 | \ Draw the menu deselected. 423 | : DRAW-ENTRIES-DESELECTED ( -- ) ROWS 0 DO COLUMNS 0 DO I J DESELECT-ENTRY LOOP LOOP ; 424 | \ Initialize the current x and y. 425 | : INIT-XY ( -- ) 0 XPOS ! 0 YPOS ! ; 426 | 427 | 66 TO ZKEME80-LOGO-STARTX 428 | 29 TO ZKEME80-LOGO-STARTY 429 | 430 | : MENU-INIT 0 TO CLICKED? PAGE ZKEME80-LOGO DRAW-ENTRIES-DESELECTED INIT-XY DRAW-TICK ; 431 | \ The demo. 432 | : MENU-DEMO ( -- ) MENU-INIT BEGIN CLICKED? NOT WHILE MENU-DEMO-TICK REPEAT ; 433 | 434 | 435 | 0 0 BUTTON-COORDS CONSTANT TLY CONSTANT TLX 436 | 437 | : TL-LOGO POWEROFF-SPRITE TLX +LOX TLY +LOY DRAW-LOGO ; 438 | : TL-TITLE CLEAR-TITLE POWEROFF-TITLE ; 439 | : TOP-LEFT-SELECT TLX TLY DRAW-SELECTED-BUTTON TL-LOGO TL-TITLE ; 440 | : TOP-LEFT-DESELECT TLX TLY DRAW-DESELECTED-BUTTON TL-LOGO ; 441 | 442 | 443 | 0 1 BUTTON-COORDS CONSTANT BLY CONSTANT BLX 444 | 445 | : BL-LOGO INFO-SPRITE BLX +LOX BLY +LOY DRAW-LOGO ; 446 | : BL-TITLE CLEAR-TITLE INFO-TITLE ; 447 | : BOTTOM-LEFT-SELECT BLX BLY DRAW-SELECTED-BUTTON BL-LOGO BL-TITLE ; 448 | : BOTTOM-LEFT-DESELECT BLX BLY DRAW-DESELECTED-BUTTON BL-LOGO ; 449 | : BOTTOM-LEFT-ON-CLICK 450 | PAGE STATUS CR 451 | ." This system has " NUMBER-OF-WORDS . CR 452 | ." words defined." 453 | PAUSE MENU-INIT 454 | ; 455 | 456 | 1 0 BUTTON-COORDS CONSTANT TRY CONSTANT TRX 457 | 458 | : TR-LOGO SHELL-SPRITE TRX +LOX TRY +LOY DRAW-LOGO ; 459 | : TR-TITLE CLEAR-TITLE SHELL-TITLE ; 460 | : TOP-RIGHT-SELECT TRX TRY DRAW-SELECTED-BUTTON TR-LOGO TR-TITLE ; 461 | : TOP-RIGHT-DESELECT TRX TRY DRAW-DESELECTED-BUTTON TR-LOGO ; 462 | : TOP-RIGHT-ON-CLICK LOAD-SHELL ; 463 | 464 | 1 1 BUTTON-COORDS CONSTANT BRY CONSTANT BRX 465 | 466 | : BR-LOGO TEST-SPRITE BRX +LOX BRY +LOY DRAW-LOGO ; 467 | : BR-TITLE CLEAR-TITLE TEST-TITLE ; 468 | : BOTTOM-RIGHT-SELECT BRX BRY DRAW-SELECTED-BUTTON BR-LOGO BR-TITLE ; 469 | : BOTTOM-RIGHT-DESELECT BRX BRY DRAW-DESELECTED-BUTTON BR-LOGO ; 470 | : BOTTOM-RIGHT-ON-CLICK PAGE LOAD-TEST-SUITE ; 471 | 472 | : SET-MENU-ENTRY-SELECTOR MENU-ENTRY.SELECTOR ' SWAP ! ; 473 | : SET-MENU-ENTRY-DESELECTOR MENU-ENTRY.DESELECTOR ' SWAP ! ; 474 | : SET-MENU-ENTRY-ON-CLICK MENU-ENTRY.ON-CLICK ' SWAP ! ; 475 | 476 | TOP-LEFT SET-MENU-ENTRY-SELECTOR TOP-LEFT-SELECT 477 | TOP-LEFT SET-MENU-ENTRY-DESELECTOR TOP-LEFT-DESELECT 478 | TOP-LEFT SET-MENU-ENTRY-ON-CLICK POWEROFF 479 | 480 | BOTTOM-LEFT SET-MENU-ENTRY-SELECTOR BOTTOM-LEFT-SELECT 481 | BOTTOM-LEFT SET-MENU-ENTRY-DESELECTOR BOTTOM-LEFT-DESELECT 482 | BOTTOM-LEFT SET-MENU-ENTRY-ON-CLICK BOTTOM-LEFT-ON-CLICK 483 | 484 | TOP-RIGHT SET-MENU-ENTRY-SELECTOR TOP-RIGHT-SELECT 485 | TOP-RIGHT SET-MENU-ENTRY-DESELECTOR TOP-RIGHT-DESELECT 486 | TOP-RIGHT SET-MENU-ENTRY-ON-CLICK TOP-RIGHT-ON-CLICK 487 | 488 | BOTTOM-RIGHT SET-MENU-ENTRY-SELECTOR BOTTOM-RIGHT-SELECT 489 | BOTTOM-RIGHT SET-MENU-ENTRY-DESELECTOR BOTTOM-RIGHT-DESELECT 490 | BOTTOM-RIGHT SET-MENU-ENTRY-ON-CLICK BOTTOM-RIGHT-ON-CLICK 491 | 492 | MENU-DEMO 493 | -------------------------------------------------------------------------------- /src/bootstrap-flash2.fs: -------------------------------------------------------------------------------- 1 | : LOAD-STAGE3 2 | 3 SET-RAM-MEMA 3 | IF 4 | MEMA INPUT-PTR ! PAGE 5 | ELSE 6 | ." Couldn't load stage 4. Shutting down." CR 7 | PAUSE POWEROFF 8 | THEN 9 | ; 10 | 11 | : STAGE2-LOADED ." Bootstrap stage 2 loaded" ; 12 | : STAGE2-END ." End of stage 2." ; 13 | 14 | : STAGE2-MAIN 15 | PAGE 16 | STAGE2-LOADED CR 17 | STAGE2-END PAUSE 18 | LOAD-STAGE3 19 | ; 20 | 21 | STAGE2-MAIN 22 | -------------------------------------------------------------------------------- /src/bootstrap-flash3.fs: -------------------------------------------------------------------------------- 1 | : STAGE4-START 2 | ." Stage 4 loaded." CR 3 | ." A menu demo is loading." CR 4 | ; 5 | 6 | : STAGE4-END 7 | STATUS 8 | ." The system is going 9 | to shutdown!" 10 | SHUTDOWN 11 | ; 12 | STAGE4-START 13 | 14 | STAGE4-END 15 | -------------------------------------------------------------------------------- /src/bootstrap-flash4.fs: -------------------------------------------------------------------------------- 1 | : TEST-SUITE-START 2 | ." The test suite is 3 | running, please wait..." CR 4 | ; 5 | 6 | : GREETING 7 | ." Welcome to the test 8 | suite" 9 | ; 10 | 11 | : PRESS-TO-CONTINUE 12 | ." Press any key to 13 | continue..." PAUSE CR 14 | ; 15 | 16 | \ end of bootstrap definitions 17 | 18 | PAGE GREETING CR CR TEST-SUITE-START PAGE 19 | 20 | \ Any word defined from this point on to the end of this stage. will 21 | \ be forgotten. 22 | HERE 32 CELLS ALLOT CONSTANT ACTUAL-RESULTS 23 | 24 | VARIABLE ACTUAL-DEPTH \ stack record 25 | 26 | VARIABLE START-DEPTH 27 | 28 | VARIABLE XCURSOR \ for ...}T 29 | 30 | VARIABLE ERROR-XT 31 | 32 | : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting 33 | 34 | 35 | : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. 36 | DEPTH START-DEPTH @ < IF 37 | DEPTH START-DEPTH @ SWAP DO 0 LOOP 38 | THEN 39 | DEPTH START-DEPTH @ > IF 40 | DEPTH START-DEPTH @ DO DROP LOOP 41 | THEN 42 | ; 43 | 44 | 45 | : SEEK-NEWLINE-BACK 46 | \ Need this, why? 47 | 2- 48 | BEGIN 49 | DUP C@ 10 = 50 | IF 51 | 1+ EXIT 52 | ELSE 53 | 1- 54 | THEN 55 | AGAIN 56 | ; 57 | 58 | : EMIT-UNTIL-NEWLINE 59 | BEGIN 60 | DUP C@ 10 = 61 | IF 62 | DROP EXIT 63 | ELSE 64 | DUP C@ EMIT 1+ 65 | THEN 66 | AGAIN 67 | ; 68 | 69 | 70 | : ERROR1 \ ( c-addr u -- ) display an error message 71 | \ followed by the line that had the error. 72 | TYPE CR INPUT-PTR @ SEEK-NEWLINE-BACK EMIT-UNTIL-NEWLINE CR 73 | \ display line corresponding to error 74 | EMPTY-STACK \ throw away everything else 75 | ; 76 | 77 | 78 | ' ERROR1 ERROR-XT ! 79 | 80 | VARIABLE TEST-COUNT 81 | 0 TEST-COUNT ! 82 | VARIABLE SUCCESS-TEST-COUNT 83 | 0 SUCCESS-TEST-COUNT ! 84 | : ADD-TEST 1 TEST-COUNT +! ; 85 | : ADD-SUCCESS-TEST 1 SUCCESS-TEST-COUNT +! ; 86 | 87 | : REPORT-TESTS PAGE SUCCESS-TEST-COUNT @ . ." / " TEST-COUNT @ . ; 88 | 89 | : T{ \ ( -- ) syntactic sugar. 90 | ADD-TEST DEPTH START-DEPTH ! 0 XCURSOR ! 91 | ; 92 | 93 | : -> \ ( ... -- ) record depth and contents of stack. 94 | DEPTH DUP ACTUAL-DEPTH ! \ record depth 95 | START-DEPTH @ > IF \ if there is something on the stack 96 | DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them 97 | THEN 98 | ; 99 | : CLEAR-TITLE 0 0 MAX-COL 5 RECT-AND ; 100 | 101 | : UPDATE-TEST-STATUS ORIGIN CLEAR-TITLE REPORT-TESTS ; 102 | 103 | : }T \ ( ... -- ) compare stack (expected) contents with saved 104 | \ (actual) contents. 105 | DEPTH ACTUAL-DEPTH @ = IF \ if depths match 106 | DEPTH START-DEPTH @ > IF \ if there is something on the stack 107 | DEPTH START-DEPTH @ - 0 DO \ for each stack item 108 | ACTUAL-RESULTS I CELLS + @ \ compare actual with expected 109 | <> IF S" INCORRECT RESULT: " ERROR UPDATE-TEST-STATUS LEAVE THEN 110 | LOOP 111 | THEN 112 | ELSE \ depth mismatch 113 | S" WRONG NUMBER OF RESULTS: " ERROR UPDATE-TEST-STATUS EXIT 114 | THEN 115 | \ The test was good. 116 | ADD-SUCCESS-TEST UPDATE-TEST-STATUS 117 | ; 118 | 119 | 120 | : ...}T ( -- ) 121 | XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 122 | S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 123 | ELSE DEPTH START-DEPTH @ = 0= IF 124 | S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 125 | THEN THEN 126 | ; 127 | 128 | 129 | \ start with clean slate 130 | T{ -> }T 131 | ( test if any bits are set; answer in base 1 ) 132 | T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T 133 | T{ 0 BITSSET? -> 0 }T ( zero is all bits clear ) 134 | T{ 1 BITSSET? -> 0 0 }T ( other number have at least one bit ) 135 | 136 | T{ 0 INVERT 1 AND -> 1 }T 137 | T{ 1 INVERT 1 AND -> 0 }T 138 | 139 | 0 CONSTANT 0S 140 | 0 INVERT CONSTANT 1S 141 | 142 | T{ 0S INVERT -> 1S }T 143 | T{ 1S INVERT -> 0S }T 144 | 145 | T{ 0S 0S AND -> 0S }T 146 | T{ 0S 1S AND -> 0S }T 147 | T{ 1S 0S AND -> 0S }T 148 | T{ 1S 1S AND -> 1S }T 149 | 150 | T{ 0S 0S OR -> 0S }T 151 | T{ 0S 1S OR -> 1S }T 152 | T{ 1S 0S OR -> 1S }T 153 | T{ 1S 1S OR -> 1S }T 154 | 155 | T{ 0S 0S XOR -> 0S }T 156 | T{ 0S 1S XOR -> 1S }T 157 | T{ 1S 0S XOR -> 1S }T 158 | T{ 1S 1S XOR -> 0S }T 159 | 160 | 0S CONSTANT 161 | 1 CONSTANT 162 | 163 | T{ TRUE -> }T 164 | 165 | : GN2 \ ( -- 16 10 ) 166 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 167 | T{ GN2 -> 16 10 }T 168 | 169 | 170 | ( we trust 1s, invert, and bitsset?; we will confirm rshift later ) 171 | 1S 1 RSHIFT INVERT CONSTANT MSB 172 | T{ MSB BITSSET? -> 0 0 }T 173 | 174 | T{ 0S 2* -> 0S }T 175 | T{ 1 2* -> 2 }T 176 | 177 | T{ 0 0 * -> 0 }T \ Test identities 178 | T{ 0 1 * -> 0 }T 179 | T{ 1 0 * -> 0 }T 180 | T{ 1 2 * -> 2 }T 181 | T{ 2 1 * -> 2 }T 182 | T{ 3 3 * -> 9 }T 183 | 184 | 185 | T{ 5 0 - -> 5 }T 186 | T{ 10 3 - -> 7 }T 187 | 188 | T{ 4000 2* -> 8000 }T 189 | T{ 1S 2* 1 XOR -> 1S }T 190 | T{ MSB 2* -> 0S }T 191 | 192 | T{ 3 1- -> 2 }T 193 | T{ 3 2+ -> 5 }T 194 | T{ 3 2- -> 1 }T 195 | 196 | T{ : GC1 [CHAR] X ; -> }T 197 | T{ : GC2 [CHAR] HELLO ; -> }T 198 | T{ GC1 -> 88 }T 199 | T{ GC2 -> 72 }T 200 | 201 | T{ : GC3 [ GC1 ] LITERAL ; -> }T 202 | T{ GC3 -> 88 }T 203 | 204 | 205 | T{ : GT1 123 ; -> }T 206 | T{ ' GT1 EXECUTE -> 123 }T 207 | 208 | T{ : GT2 ['] GT1 ; IMMEDIATE -> }T 209 | T{ GT2 EXECUTE -> 123 }T 210 | 211 | 212 | : TMOD /MOD DROP ; 213 | : T/ /MOD SWAP DROP ; 214 | 215 | T{ 0 1 / -> 0 1 T/ }T 216 | T{ 1 1 / -> 1 1 T/ }T 217 | T{ 2 1 / -> 2 1 T/ }T 218 | T{ 2 2 / -> 2 2 T/ }T 219 | T{ 7 3 / -> 7 3 T/ }T 220 | 221 | T{ 0 1 MOD -> 0 1 TMOD }T 222 | T{ 1 1 MOD -> 1 1 TMOD }T 223 | T{ 2 1 MOD -> 2 1 TMOD }T 224 | 225 | T{ 0 0= -> 1 }T 226 | T{ 1 0= -> 0 }T 227 | T{ 2 0= -> 0 }T 228 | 229 | T{ 0 0 = -> }T 230 | T{ 0 0 >= -> }T 231 | T{ 0 0 <= -> }T 232 | 233 | T{ 0 1 = -> }T 234 | T{ 0 1 >= -> }T 235 | T{ 0 1 <= -> }T 236 | 237 | T{ 1 0 = -> }T 238 | T{ 1 0 >= -> }T 239 | T{ 1 0 <= -> }T 240 | 241 | T{ 1 1 = -> }T 242 | T{ 1 1 >= -> }T 243 | T{ 1 1 <= -> }T 244 | 245 | T{ 0 1 10 WITHIN -> }T 246 | T{ 1 1 10 WITHIN -> }T 247 | T{ 4 0 10 WITHIN -> }T 248 | T{ 10 0 10 WITHIN -> }T 249 | T{ 11 0 10 WITHIN -> }T 250 | 251 | T{ 0 1 DEPTH -> 0 1 2 }T 252 | T{ 0 DEPTH -> 0 1 }T 253 | T{ DEPTH -> 0 }T 254 | 255 | T{ 0S 2/ -> 0S }T 256 | T{ 1 2/ -> 0 }T 257 | T{ 4000 2/ -> 2000 }T 258 | 259 | T{ 1 0 LSHIFT -> 1 }T 260 | T{ 1 1 LSHIFT -> 2 }T 261 | T{ 1 2 LSHIFT -> 4 }T 262 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 263 | T{ MSB 1 LSHIFT -> 0 }T 264 | 265 | T{ 1 0 RSHIFT -> 1 }T 266 | T{ 1 1 RSHIFT -> 0 }T 267 | T{ 2 1 RSHIFT -> 1 }T 268 | T{ 4 2 RSHIFT -> 1 }T 269 | T{ MSB 1 RSHIFT 2* -> MSB }T 270 | 271 | \ Stack word tests. 272 | T{ 0 ?DUP -> 0 }T 273 | T{ 1 ?DUP -> 1 1 }T 274 | T{ 1 2 2DROP -> }T 275 | T{ 1 2 2DUP -> 1 2 1 2 }T 276 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 277 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 278 | T{ 1 2 3 ROT -> 2 3 1 }T 279 | T{ 2 3 1 -ROT -> 1 2 3 }T 280 | T{ 1 2 SWAP -> 2 1 }T 281 | T{ 1 2 OVER -> 1 2 1 }T 282 | T{ 1 2 0 PICK -> 1 2 DUP }T 283 | T{ 1 2 1 PICK -> 1 2 OVER }T 284 | T{ 1 2 NIP -> 2 }T 285 | T{ 1 2 TUCK -> 2 1 2 }T 286 | 287 | \ Return stack tests. 288 | T{ 1 2 >R >R RDROP R> -> 2 }T 289 | T{ 1 2 3 >R >R >R 2RDROP R> -> 3 }T 290 | 291 | T{ : GD1 DO I LOOP ; -> }T 292 | T{ 4 1 GD1 -> 1 2 3 }T 293 | 294 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 295 | T{ 4 1 GD3 -> 1 2 3 }T 296 | 297 | T{ : GD5 123 SWAP 0 DO 298 | I 4 > IF DROP 234 LEAVE THEN 299 | LOOP ; -> }T 300 | T{ 1 GD5 -> 123 }T 301 | T{ 5 GD5 -> 123 }T 302 | T{ 6 GD5 -> 234 }T 303 | 304 | T{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 305 | 0 SWAP 0 DO 306 | I 1+ 0 DO 307 | I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ 308 | LOOP 309 | LOOP ; -> }T 310 | T{ 1 GD6 -> 1 }T 311 | T{ 2 GD6 -> 3 }T 312 | T{ 3 GD6 -> 4 1 2 }T 313 | 314 | 315 | : CS1 CASE 1 OF 111 ENDOF 316 | 2 OF 222 ENDOF 317 | 3 OF 333 ENDOF 318 | >R 999 R> 319 | ENDCASE 320 | ; 321 | 322 | T{ 1 CS1 -> 111 }T 323 | T{ 2 CS1 -> 222 }T 324 | T{ 3 CS1 -> 333 }T 325 | T{ 4 CS1 -> 999 }T 326 | 327 | : CS2 >R CASE 328 | 1 OF CASE R@ 1 OF 100 ENDOF 329 | 2 OF 200 ENDOF 330 | >R 300 R> 331 | ENDCASE 332 | ENDOF 333 | 2 OF CASE R@ 1 OF 99 ENDOF 334 | >R 199 R> 335 | ENDCASE 336 | ENDOF 337 | >R 299 R> 338 | ENDCASE R> DROP ; 339 | 340 | T{ 1 1 CS2 -> 100 }T 341 | T{ 1 2 CS2 -> 200 }T 342 | T{ 1 3 CS2 -> 300 }T 343 | T{ 2 1 CS2 -> 99 }T 344 | T{ 2 2 CS2 -> 199 }T 345 | T{ 0 2 CS2 -> 299 }T 346 | 347 | T{ : NOP : POSTPONE ; ; -> }T 348 | T{ NOP NOP1 NOP NOP2 -> }T 349 | T{ NOP1 -> }T 350 | T{ NOP2 -> }T 351 | 352 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 353 | T{ GDX -> 123 234 }T 354 | 355 | 356 | T{ : GR1 >R R> ; -> }T 357 | T{ : GR2 >R R@ R> DROP ; -> }T 358 | T{ 123 GR1 -> 123 }T 359 | T{ 123 GR2 -> 123 }T 360 | T{ 1S GR1 -> 1S }T ( Return stack holds cells ) 361 | 362 | \ 2>R is semantically equivalent to SWAP >R >R 363 | T{ 1 2 2>R 2R> -> 1 2 SWAP >R >R R> R> SWAP }T 364 | 365 | 366 | \ This test fails! Maybe this is where being non-standard is better? 367 | \ T{ ( A comment)1234 -> }T 368 | T{ : PC1 ( A comment)1234 ; PC1 -> 1234 }T 369 | 370 | HERE 1 , 371 | HERE 2 , 372 | CONSTANT 2ND 373 | CONSTANT 1ST 374 | 375 | T{ 1ST 2ND < -> 1 }T \ HERE MUST GROW WITH ALLOT 376 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 377 | T{ 1ST 1 CELLS + -> 2ND }T 378 | T{ 1ST @ 2ND @ -> 1 2 }T 379 | T{ 5 1ST ! -> }T 380 | T{ 1ST @ 2ND @ -> 5 2 }T 381 | T{ 6 2ND ! -> }T 382 | T{ 1ST @ 2ND @ -> 5 6 }T 383 | T{ 1ST 2@ -> 6 5 }T 384 | T{ 2 1 1ST 2! -> }T 385 | T{ 1ST 2@ -> 2 1 }T 386 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 387 | 388 | 389 | T{ 390 | BEGIN-STRUCTURE POINT \ -- a-addr 0 ; -- lenp 391 | FIELD: P.X \ -- a-addr cell 392 | FIELD: P.Y \ -- a-addr cell*2 393 | END-STRUCTURE 394 | -> }T 395 | 396 | HERE POINT ALLOT CONSTANT MY-POINT 397 | 398 | T{ 3 MY-POINT P.X ! -> }T 399 | T{ 5 MY-POINT P.Y ! -> }T 400 | 401 | T{ MY-POINT P.X @ -> 3 }T 402 | T{ MY-POINT P.Y @ -> 5 }T 403 | 404 | HERE 1 ALLOT 405 | HERE 406 | CONSTANT 2NDA 407 | CONSTANT 1STA 408 | T{ 1STA 2NDA < -> 1 }T \ HERE MUST GROW WITH ALLOT 409 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 410 | 411 | 412 | HERE 1 C, 413 | HERE 2 C, 414 | CONSTANT 2NDC 415 | CONSTANT 1STC 416 | 417 | T{ 1STC 2NDC < -> 1 }T \ HERE MUST GROW WITH ALLOT 418 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 419 | T{ 1STC 1 CHARS + -> 2NDC }T 420 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 421 | T{ 3 1STC C! -> }T 422 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 423 | T{ 4 2NDC C! -> }T 424 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 425 | 426 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 427 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 428 | T{ 4 GI3 -> 4 5 }T 429 | T{ 5 GI3 -> 5 }T 430 | T{ 6 GI3 -> 6 }T 431 | 432 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 433 | T{ 3 GI4 -> 3 4 5 6 }T 434 | T{ 5 GI4 -> 5 6 }T 435 | T{ 6 GI4 -> 6 7 }T 436 | 437 | 438 | T{ VARIABLE V1 -> }T 439 | T{ 123 V1 ! -> }T 440 | T{ V1 @ -> 123 }T 441 | T{ 111 V1 +! -> }T 442 | T{ V1 @ -> 234 }T 443 | T{ 111 V1 -! -> }T 444 | T{ V1 @ -> 123 }T 445 | 446 | : GS3 WORD DROP COUNT SWAP C@ ; 447 | T{ GS3 HELLO -> 5 CHAR H }T 448 | 449 | \ : OUTPUT-TEST 450 | \ PAGE 451 | \ ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 452 | \ 65 BL DO I EMIT LOOP CR 453 | \ 97 65 DO I EMIT LOOP CR 454 | \ 127 97 DO I EMIT LOOP CR 455 | \ PAGE 456 | \ ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 457 | \ 9 1+ 0 DO I . LOOP CR 458 | \ PAGE 459 | \ ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 460 | \ [ CHAR 9 ] LITERAL 1+ [ CHAR 0 ] LITERAL DO I EMIT LOOP CR 461 | \ PAGE 462 | \ ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 463 | \ [ CHAR G ] LITERAL 1+ [ CHAR A ] LITERAL DO I EMIT SPACE LOOP CR 464 | \ PAGE 465 | \ ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 466 | \ 5 1+ 0 DO I [ CHAR 0 ] LITERAL + EMIT 2 SPACES LOOP CR 467 | \ PAGE 468 | \ ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 469 | \ S" LINE 1" TYPE CR S" LINE 2" TYPE CR 470 | \ PAGE 471 | \ ; 472 | 473 | \ Optional output test, may dizzy the user. 474 | \ T{ OUTPUT-TEST -> }T 475 | 476 | \ Test exceptions. 477 | : T1 9 ; 478 | : C1 1 2 3 ['] T1 CATCH ; 479 | T{ C1 -> 1 2 3 9 0 }T \ no throw executed 480 | 481 | : T2 8 0 THROW ; 482 | : C2 1 2 ['] T2 CATCH ; 483 | T{ C2 -> 1 2 8 0 }T \ 0 throw does nothing 484 | 485 | : T3 7 8 9 99 THROW ; 486 | : C3 1 2 ['] T3 CATCH ; 487 | T{ C3 -> 1 2 99 }T \ restores stack to catch depth 488 | 489 | : T5 2DROP 2DROP 9999 THROW ; 490 | : C5 1 2 3 4 ['] T5 CATCH \ test depth restored correctly 491 | DEPTH >R DROP 2DROP 2DROP R> ; \ after stack has been emptied 492 | T{ C5 -> 5 }T 493 | 494 | REPORT-TESTS CR CR 495 | 496 | PRESS-TO-CONTINUE 497 | 498 | PAGE 499 | 500 | : RC4-TEST-MSG 501 | ." Performing RC4 test 502 | (code taken from 503 | Wikipedia)." CR 504 | 505 | ." Expect this sequence: 506 | F1 38 29 C9 DE" CR 507 | ; 508 | 509 | RC4-TEST-MSG 510 | 511 | 0 VALUE II 0 VALUE JJ 512 | 0 VALUE KEYADDR 0 VALUE KEYLEN 513 | 514 | HERE 256 CELLS ALLOT CONSTANT SARRAY 515 | : KEYARRAY KEYLEN MOD KEYADDR ; 516 | 517 | : GET-BYTE + C@ ; 518 | : SET-BYTE + C! ; 519 | : AS-BYTE 255 AND ; 520 | : RESET-IJ 0 TO II 0 TO JJ ; 521 | : I-UPDATE 1 + AS-BYTE TO II ; 522 | : J-UPDATE II SARRAY GET-BYTE + AS-BYTE TO JJ ; 523 | : SWAP-S-IJ 524 | JJ SARRAY GET-BYTE 525 | II SARRAY GET-BYTE JJ SARRAY SET-BYTE 526 | II SARRAY SET-BYTE 527 | ; 528 | 529 | : RC4-INIT ( keyaddr keylen -- ) 530 | 256 MIN TO KEYLEN TO KEYADDR 531 | 256 0 DO I I SARRAY SET-BYTE LOOP 532 | RESET-IJ 533 | BEGIN 534 | II KEYARRAY GET-BYTE JJ + J-UPDATE 535 | SWAP-S-IJ 536 | II 255 < WHILE 537 | II I-UPDATE 538 | REPEAT 539 | RESET-IJ 540 | ; 541 | 542 | : RC4-BYTE 543 | II I-UPDATE JJ J-UPDATE 544 | SWAP-S-IJ 545 | II SARRAY GET-BYTE JJ SARRAY GET-BYTE + AS-BYTE SARRAY GET-BYTE XOR 546 | ; 547 | 548 | 549 | HEX 550 | HERE 97 C, 138 C, 99 C, 210 C, 251 C, CONSTANT MKEY 551 | : TEST CR 0 DO RC4-BYTE . LOOP CR ; 552 | MKEY 5 RC4-INIT 553 | 44 249 76 238 220 5 TEST 554 | 555 | DECIMAL CR PRESS-TO-CONTINUE PAGE 556 | 557 | ." Unloading test suite 558 | words to save on space" CR CR 559 | USED 560 | 561 | FORGET TEST-SUITE-START 562 | USED - . ." bytes freed." CR 563 | 564 | \ Cannot use PRESS-TO-CONTINUE here because forgotten already 565 | 566 | ." Press any key to 567 | continue..." PAUSE CR 568 | 569 | MENU-DEMO 570 | -------------------------------------------------------------------------------- /src/bootstrap-flash5.fs: -------------------------------------------------------------------------------- 1 | \ This should be the shell. 2 | 3 | \ We should handle modal key input, so that the user can type 0-9, A-Z 4 | \ etc. The state transition diagram for this is shown in the file 5 | \ "key.dot". 6 | 7 | \ Dummy word to mark start of word definitions. 8 | : SHELL-START ; 9 | 10 | 54 CONSTANT 2ND-KEY 11 | 48 CONSTANT ALPHA-KEY 12 | 13 | : SHELL-KEY KEY ; 14 | : SHELL-TITLE 15 | ORIGIN 16 | ." No REPL yet, but here's 17 | a key demo. 18 | 19 | Press ENTER to quit." CR CR 20 | ; 21 | 2 CONSTANT SHELL-ERROR 22 | 1 CONSTANT SHELL-OK 23 | 0 CONSTANT SHELL-EXIT 24 | 25 | 1 VALUE SHELL-STATUS 26 | 27 | : SHELL-OK? SHELL-STATUS 1 = ; 28 | 29 | : ?EXIT-IF-ENTER DUP 9 = IF SHELL-EXIT TO SHELL-STATUS THEN ; 30 | 31 | : SHELL-READ-KEY KEY ?EXIT-IF-ENTER ." You pressed: " . CR CR ." Stack: " .S ; 32 | : SHELL-TICK SHELL-TITLE SHELL-READ-KEY ; 33 | : SHELL-LOOP BEGIN SHELL-OK? WHILE SHELL-TICK REPEAT ; 34 | 35 | PAGE 36 | 37 | SHELL-LOOP 38 | 39 | FORGET SHELL-START 40 | MENU-DEMO 41 | -------------------------------------------------------------------------------- /src/display.scm: -------------------------------------------------------------------------------- 1 | ;; display.asm 2 | (define display-asm 3 | `((label clear-buffer) 4 | ,@(push* '(hl de bc iy)) 5 | (pop hl) 6 | (ld (hl) 0) 7 | (ld d h) 8 | (ld e l) 9 | (inc de) 10 | (ld bc 767) 11 | (ldir) 12 | 13 | ,@(pop* '(bc de hl)) 14 | (ret) 15 | 16 | (label buffer-to-lcd) 17 | (label buf-copy) 18 | (label fast-copy) 19 | (label safe-copy) 20 | ,@(push* '(hl bc af de)) 21 | (ld a i) 22 | (push af) 23 | (di) 24 | (push iy) 25 | (pop hl) 26 | (ld c #x10) 27 | (ld a #x80) 28 | 29 | (label set-row) 30 | (db (#xed #x70)) 31 | (jp m set-row) 32 | (out (#x10) a) 33 | (ld de 12) 34 | (ld a #x20) 35 | 36 | (label col) 37 | ;; (in f (c)) is not in the data sheet, hm. 38 | (db (#xed #x70)) 39 | 40 | (jp m col) 41 | (out (#x10) a) 42 | (push af) 43 | (ld b 64) 44 | 45 | (label row) 46 | (ld a (hl)) 47 | (label row-wait) 48 | (db (#xed #x70)) 49 | 50 | (jp m row-wait) 51 | (out (#x11) a) 52 | (add hl de) 53 | (djnz row) 54 | (pop af) 55 | (dec h) 56 | (dec h) 57 | (dec h) 58 | (inc hl) 59 | (inc a) 60 | (cp #x2c) 61 | (jp nz col) 62 | (pop af) 63 | (jp po local-label17) 64 | (ei) 65 | 66 | (label local-label17) 67 | ,@(pop* '(de af bc hl)) 68 | (ret) 69 | 70 | (label lcd-delay) 71 | (push af) 72 | (label local-label18) 73 | (in a (#x10)) 74 | (rla) 75 | (jr c local-label18) 76 | (pop af) 77 | (ret) 78 | 79 | (label get-pixel) 80 | (ld h 0) 81 | (ld d h) 82 | (ld e l) 83 | (add hl hl) 84 | (add hl de) 85 | (add hl hl) 86 | (add hl hl) 87 | (ld e a) 88 | ,@(make-list 3 '(srl e)) 89 | (add hl de) 90 | (push iy) 91 | (pop de) 92 | (add hl de) 93 | (and 7) 94 | (ld b a) 95 | (ld a #x80) 96 | (ret z) 97 | 98 | (label local-label19) 99 | (rrca) 100 | (djnz local-label19) 101 | (ret) 102 | 103 | (label pixel-on) 104 | (label set-pixel) 105 | ,@(with-regs-preserve (hl de af bc) 106 | (call get-pixel) 107 | (or (hl)) 108 | (ld (hl) a)) 109 | (ret) 110 | 111 | (label pixel-off) 112 | (label reset-pixel) 113 | ,@(with-regs-preserve (hl de af bc) 114 | (call get-pixel) 115 | (cpl) 116 | (and (hl)) 117 | (ld (hl) a)) 118 | (ret) 119 | 120 | (label invert-pixel) 121 | (label pixel-flip) 122 | (label pixel-invert) 123 | (label flip-pixel) 124 | ,@(with-regs-preserve (hl de af bc) 125 | (call get-pixel) 126 | (xor (hl)) 127 | (ld (hl) a)) 128 | (ret) 129 | 130 | (label draw-line) 131 | (label draw-line-or) 132 | ,@(with-regs-preserve (hl de bc af ix iy) 133 | (call draw-line2)) 134 | (ret) 135 | 136 | (label draw-line2) 137 | (ld a h) 138 | (cp d) 139 | (jp nc no-swap-x) 140 | ((ex de hl)) 141 | 142 | (label no-swap-x) 143 | (ld a h) 144 | (sub d) 145 | (jp nc pos-x) 146 | (neg) 147 | 148 | (label pos-x) 149 | (ld b a) 150 | (ld a l ) 151 | (sub e) 152 | (jp nc pos-y) 153 | (neg) 154 | 155 | (label pos-y) 156 | (ld c a) 157 | (ld a l) 158 | (ld hl ,(- (ash 1 16) 12)) 159 | (cp e) 160 | (jp c line-up) 161 | (ld hl 12) 162 | 163 | (label line-up) 164 | (ld ix x-bit) 165 | (ld a b) 166 | (cp c) 167 | (jp nc x-line) 168 | (ld b c) 169 | (ld c a) 170 | (ld ix y-bit) 171 | 172 | (label x-line) 173 | (push hl) 174 | (ld a d) 175 | (ld d 0) 176 | (ld h d) 177 | (sla e) 178 | (sla e) 179 | (ld l e) 180 | (add hl de) 181 | (add hl de) 182 | (ld e a) 183 | (and #b00000111) 184 | (srl e) 185 | (srl e) 186 | (srl e) 187 | (add hl de) 188 | (push iy) 189 | (pop de) 190 | (add hl de) 191 | (add a a) 192 | (ld e a) 193 | (ld d 0) 194 | (add ix de) 195 | (ld e (+ 0 ix)) 196 | (ld d (+ 1 ix)) 197 | (push hl) 198 | (pop ix) 199 | ((ex de hl)) 200 | (pop de) 201 | (push hl) 202 | (ld h b) 203 | (ld l c) 204 | (ld a h) 205 | (srl a) 206 | (inc b) 207 | (ret) 208 | 209 | (label x-bit) 210 | (dw ,(map (lambda (x) 211 | (string->symbol (format #f "draw-x~a" x))) 212 | (iota 8))) 213 | 214 | (label y-bit) 215 | (dw ,(map (lambda (y) 216 | (string->symbol (format #f "draw-y~a" y))) 217 | (iota 8))) 218 | 219 | 220 | ;; Code generation for the win! 221 | ,@(concat-map (lambda (x) 222 | (let* ((curr-label (string->symbol (format #f "draw-x~a" x))) 223 | (next-label (string->symbol (format #f "draw-x~a" (modulo (1+ x) 8)))) 224 | (local-label (string->symbol (format #f "local-draw-x~a" x)))) 225 | `((label ,curr-label) 226 | (set ,(- 7 x) (ix)) 227 | ,@(if (= 7 x) '((inc ix)) '()) 228 | (add a c) 229 | (cp h) 230 | (jp c ,local-label) 231 | (add ix de) 232 | (sub h) 233 | (label ,local-label) 234 | (djnz ,next-label) 235 | (ret)))) 236 | (iota 8)) 237 | 238 | ,@(concat-map (lambda (y) 239 | (let* ((local-label (string->symbol (format #f "local-draw-y~a" y))) 240 | (curr-label (string->symbol (format #f "draw-y~a" y))) 241 | (next-local-label (string->symbol (format #f "local-draw-y~a" (modulo (1+ y) 8))))) 242 | `((label ,local-label) 243 | ,@(if (zero? y) '((inc ix)) '()) 244 | (sub h) 245 | (dec b) 246 | (ret z) 247 | 248 | (label ,curr-label) 249 | (set ,(- 7 y) (ix)) 250 | (add ix de) 251 | (add a l) 252 | (cp h) 253 | (jp nc ,next-local-label) 254 | (djnz ,curr-label) 255 | (ret)))) 256 | (iota 8)) 257 | 258 | (label put-sprite-xor) 259 | ,@(with-regs-preserve (af bc hl de ix) 260 | (push hl) 261 | (pop ix) 262 | (call clip-sprite-xor)) 263 | (ret) 264 | 265 | (label clip-sprite-xor) 266 | (ld a #b11111111) 267 | (ld (#x8000) a) 268 | (ld a e) 269 | (or a) 270 | (jp m clip-top) 271 | (sub 64) 272 | (ret nc) 273 | (neg) 274 | (cp b) 275 | (jr nc vert-clip-done) 276 | (ld b a) 277 | (jr vert-clip-done) 278 | 279 | (label clip-top) 280 | (ld a b) 281 | (neg) 282 | (sub e) 283 | (ret nc) 284 | (push af) 285 | (add a b) 286 | (ld e 0) 287 | (ld b e) 288 | (ld c a) 289 | (add ix bc) 290 | (pop af) 291 | (neg) 292 | (ld b a) 293 | 294 | (label vert-clip-done) 295 | (ld c 0) 296 | (ld a d) 297 | (cp ,(- (ash 1 8) 7)) 298 | (jr nc clip-left) 299 | 300 | (cp 96) 301 | (ret nc) 302 | 303 | (cp 89) 304 | (jr c horiz-clip-done) 305 | 306 | (label clip-right) 307 | (and 7) 308 | (ld c a) 309 | (ld a #b11111111) 310 | 311 | (label find-right-mask) 312 | (add a a) 313 | (dec c) 314 | (jr nz find-right-mask) 315 | (ld (#x8000) a) 316 | (ld a d) 317 | (jr horiz-clip-done) 318 | 319 | (label clip-left) 320 | (and 7) 321 | (ld c a) 322 | (ld a #b11111111) 323 | 324 | (label find-left-mask) 325 | (add a a) 326 | (dec c) 327 | (jr nz find-left-mask) 328 | (cpl) 329 | (ld (#x8000) a) 330 | (ld a d) 331 | (add a 96) 332 | (ld c 12) 333 | 334 | (label horiz-clip-done) 335 | (ld h 0) 336 | (ld d h) 337 | (ld l e) 338 | (add hl hl) 339 | (add hl de) 340 | (add hl hl) 341 | (add hl hl) 342 | 343 | (ld e a) 344 | (srl e) 345 | (srl e) 346 | (srl e) 347 | (add hl de) 348 | 349 | (push iy) 350 | (pop de) 351 | (add hl de) 352 | 353 | (ld d 0) 354 | (ld e c) 355 | (sbc hl de) 356 | 357 | (and 7) 358 | (jr z aligned) 359 | (ld c a) 360 | (ld de 11) 361 | 362 | (label row-loop) 363 | (push bc) 364 | (ld b c) 365 | (ld a (#x8000)) 366 | (and (ix)) 367 | (ld c 0) 368 | 369 | (label shift-loop) 370 | (srl a) 371 | (rr c) 372 | (djnz shift-loop) 373 | (xor (hl)) 374 | (ld (hl) a) 375 | 376 | (inc hl) 377 | (ld a c) 378 | (xor (hl)) 379 | (ld (hl) a) 380 | 381 | (add hl de) 382 | (inc ix) 383 | (pop bc) 384 | (djnz row-loop) 385 | (ret) 386 | 387 | (label aligned) 388 | (ld de 12) 389 | 390 | (label put-loop) 391 | (ld a (+ 0 ix)) 392 | (xor (hl)) 393 | (ld (hl) a) 394 | (inc ix) 395 | (add hl de) 396 | (djnz put-loop) 397 | (ret) 398 | 399 | (label put-sprite-and) 400 | ,@(with-regs-preserve (af bc hl de ix) 401 | (push hl) 402 | (pop ix) 403 | (call clip-sprite-and)) 404 | (ret) 405 | 406 | (label clip-sprite-and) 407 | (ld a #b11111111) 408 | (ld (#x8000) a) 409 | (ld a e) 410 | (or a) 411 | (jp m clip-top2) 412 | (sub 64) 413 | (ret nc) 414 | (neg) 415 | (cp b) 416 | (jr nc vert-clip-done2) 417 | (ld b a) 418 | (jr vert-clip-done2) 419 | 420 | (label clip-top2) 421 | (ld a b) 422 | (neg) 423 | (sub e) 424 | (ret nc) 425 | (push af) 426 | (add a b) 427 | (ld e 0) 428 | (ld b e) 429 | (ld c a) 430 | (add ix bc) 431 | (pop af) 432 | (neg) 433 | (ld b a) 434 | 435 | (label vert-clip-done2) 436 | (ld c 0) 437 | (ld a d) 438 | (cp ,(- (ash 1 8) 7)) 439 | (jr nc clip-left2) 440 | 441 | (cp 96) 442 | (ret nc) 443 | 444 | (cp 89) 445 | (jr c horiz-clip-done2) 446 | 447 | (label clip-right2) 448 | (and 7) 449 | (ld c a) 450 | (ld a #b11111111) 451 | 452 | (label find-right-mask2) 453 | (add a a) 454 | (dec c) 455 | (jr nz find-right-mask2) 456 | (ld (#x8000) a) 457 | (ld a d) 458 | (jr horiz-clip-done2) 459 | 460 | (label clip-left2) 461 | (and 7) 462 | (ld c a) 463 | (ld a #b11111111) 464 | 465 | (label find-left-mask2) 466 | (add a a) 467 | (dec c) 468 | (jr nz find-left-mask2) 469 | (cpl) 470 | (ld (#x8000) a) 471 | (ld a d) 472 | (add a 96) 473 | (ld c 12) 474 | 475 | (label horiz-clip-done2) 476 | (ld h 0) 477 | (ld d h) 478 | (ld l e) 479 | (add hl hl) 480 | (add hl de) 481 | (add hl hl) 482 | (add hl hl) 483 | 484 | (ld e a) 485 | (srl e) 486 | (srl e) 487 | (srl e) 488 | (add hl de) 489 | (push iy) 490 | (pop de) 491 | (add hl de) 492 | (ld d 0) 493 | (ld e c) 494 | (sbc hl de) 495 | 496 | (and 7) 497 | (jr z aligned2) 498 | 499 | (ld c a) 500 | (ld de 11) 501 | 502 | (label row-loop2) 503 | (push bc) 504 | (ld b c) 505 | (ld a (#x8000)) 506 | (and (ix)) 507 | (ld c 0) 508 | 509 | (label shift-loop2) 510 | (srl a) 511 | (rr c) 512 | (djnz shift-loop2) 513 | (cpl) 514 | (and (hl)) 515 | (ld (hl) a) 516 | (inc hl) 517 | (ld a c) 518 | (cpl) 519 | (and (hl)) 520 | (ld (hl) a) 521 | 522 | (add hl de) 523 | (inc ix) 524 | (pop bc) 525 | (djnz row-loop2) 526 | (ret) 527 | 528 | (label aligned2) 529 | (ld de 12) 530 | 531 | (label put-loop2) 532 | (ld a (+ 0 ix)) 533 | (cpl) 534 | (and (hl)) 535 | (ld (hl) a) 536 | (inc ix) 537 | (add hl de) 538 | (djnz put-loop2) 539 | (ret) 540 | 541 | ;; Hmm... I'm getting a pattern here but I can't seem to abstract 542 | ;; it. 543 | (label put-sprite-or) 544 | ,@(with-regs-preserve (af bc hl de ix) 545 | (push hl) 546 | (pop ix) 547 | (call clip-sprite-or)) 548 | (ret) 549 | 550 | (label clip-sprite-or) 551 | (ld a #b11111111) 552 | (ld (#x8000) a) 553 | (ld a e) 554 | (or a) 555 | (jp m clip-top3) 556 | 557 | (sub 64) 558 | (ret nc) 559 | (neg) 560 | (cp b) 561 | (jr nc vert-clip-done3) 562 | 563 | (ld b a) 564 | (jr vert-clip-done3) 565 | 566 | (label clip-top3) 567 | (ld a b) 568 | (neg) 569 | (sub e) 570 | (ret nc) 571 | (push af) 572 | (add a b) 573 | (ld e 0) 574 | (ld b e) 575 | (ld c a) 576 | 577 | (add ix bc) 578 | (pop af) 579 | (neg) 580 | (ld b a) 581 | 582 | (label vert-clip-done3) 583 | (ld c 0) 584 | (ld a d) 585 | 586 | (cp ,(- (ash 1 8) 7)) 587 | (jr nc clip-left3) 588 | 589 | (cp 96) 590 | (ret nc) 591 | 592 | (cp 89) 593 | (jr c horiz-clip-done3) 594 | 595 | (label clip-right3) 596 | (and 7) 597 | (ld c a) 598 | (ld a #b11111111) 599 | 600 | (label find-right-mask3) 601 | (add a a) 602 | (dec c) 603 | (jr nz find-right-mask3) 604 | (ld (#x8000) a) 605 | (ld a d) 606 | (jr horiz-clip-done3) 607 | 608 | (label clip-left3) 609 | (and 7) 610 | (ld c a) 611 | (ld a #b11111111) 612 | 613 | (label find-left-mask3) 614 | (add a a) 615 | (dec c) 616 | (jr nz find-left-mask3) 617 | (cpl) 618 | (ld (#x8000) a) 619 | (ld a d) 620 | (add a 96) 621 | (ld c 12) 622 | 623 | (label horiz-clip-done3) 624 | (ld h 0) 625 | (ld d h) 626 | (ld l e) 627 | (add hl hl) 628 | (add hl de) 629 | (add hl hl) 630 | (add hl hl) 631 | (ld e a) 632 | (srl e) 633 | (srl e) 634 | (srl e) 635 | (add hl de) 636 | (push iy) 637 | (pop de) 638 | (add hl de) 639 | (ld d 0) 640 | (ld e c) 641 | (sbc hl de) 642 | 643 | (and 7) 644 | (jr z aligned3) 645 | (ld c a) 646 | (ld de 11) 647 | 648 | (label row-loop3) 649 | (push bc) 650 | (ld b c) 651 | (ld a (#x8000)) 652 | (and (ix)) 653 | (ld c 0) 654 | 655 | (label shift-loop3) 656 | (srl a) 657 | (rr c) 658 | (djnz shift-loop3) 659 | (or (hl)) 660 | (ld (hl) a) 661 | 662 | (inc hl) 663 | (ld a c) 664 | (or (hl)) 665 | (ld (hl) a) 666 | (add hl de) 667 | (inc ix) 668 | (pop bc) 669 | (djnz row-loop3) 670 | (ret) 671 | 672 | (label aligned3) 673 | (ld de 12) 674 | 675 | (label put-loop3) 676 | (ld a (+ 0 ix)) 677 | (or (hl)) 678 | (ld (hl) a) 679 | (inc ix) 680 | (add hl de) 681 | (djnz put-loop3) 682 | (ret) 683 | 684 | (label rect-xor) 685 | (ld a 96) 686 | (sub e) 687 | (ret c) 688 | (ret z) 689 | (cp c) 690 | (jr nc local-rx1) 691 | (ld c a) 692 | (label local-rx1) 693 | (ld a #x40) 694 | (sub l) 695 | (ret c) 696 | (ret z) 697 | (cp b) 698 | (jr nc local-rx2) 699 | (ld b a) 700 | (label local-rx2) 701 | (xor a) 702 | (cp b) 703 | (ret z) 704 | (cp c) 705 | (ret z) 706 | (ld h a) 707 | (ld d a) 708 | 709 | (push bc) 710 | (push iy) 711 | (pop bc) 712 | (ld a l) 713 | (add a a) 714 | (add a l) 715 | (ld l a) 716 | (add hl hl) 717 | (add hl hl) 718 | (add hl bc) 719 | (ld a e) 720 | (srl e) 721 | (srl e) 722 | (srl e) 723 | (add hl de) 724 | (and #b00000111) 725 | (pop de) 726 | 727 | (ld b a) 728 | (add a e) 729 | (sub 8) 730 | (ld e 0) 731 | (jr c box-inv-skip) 732 | (ld e a) 733 | (xor a) 734 | 735 | (label box-inv-skip) 736 | (label box-inv-shift) 737 | (add a 8) 738 | (sub b) 739 | (ld c 0) 740 | (label box-inv-shift1) 741 | (scf) 742 | (rr c) 743 | (dec a) 744 | (jr nz box-inv-shift1) 745 | (ld a c) 746 | (inc b) 747 | (rlca) 748 | 749 | (label box-inv-shift2) 750 | (rrca) 751 | (djnz box-inv-shift2) 752 | 753 | (label box-inv-loop1) 754 | (push hl) 755 | (ld b d) 756 | (ld c a) 757 | (push de) 758 | (ld de 12) 759 | 760 | (label box-inv-loop2) 761 | (ld a c) 762 | (xor (hl)) 763 | (ld (hl) a) 764 | (add hl de) 765 | (djnz box-inv-loop2) 766 | 767 | (pop de) 768 | (pop hl) 769 | (inc hl) 770 | (ld a e) 771 | (or a ) 772 | (ret z) 773 | (sub 8) 774 | (ld e b) 775 | (jr c box-inv-shift) 776 | (ld e a) 777 | (ld a #b11111111) 778 | (jr box-inv-loop1) 779 | 780 | (label box-inv-end) 781 | (label rect-or) 782 | (ld a 96) 783 | (sub e) 784 | (ret c) 785 | (ret z) 786 | (cp c) 787 | (jr nc local-ro) 788 | (ld c a) 789 | (label local-ro) 790 | (ld a 64) 791 | (sub l) 792 | (ret c) 793 | (ret z) 794 | (cp b) 795 | (jr nc local-ro2) 796 | (ld b a) 797 | (label local-ro2) 798 | (xor a) 799 | (cp b) 800 | (ret z) 801 | (cp c) 802 | (ret z) 803 | (ld h a) 804 | (ld d a) 805 | (push bc) 806 | (push iy) 807 | (pop bc) 808 | (ld a l) 809 | (add a a) 810 | (add a l) 811 | (ld l a) 812 | (add hl hl) 813 | (add hl hl) 814 | (add hl bc) 815 | 816 | (ld a e) 817 | (srl e) 818 | (srl e) 819 | (srl e) 820 | (add hl de) 821 | (and #b00000111) 822 | (pop de) 823 | (ld b a) 824 | (add a e) 825 | (sub 8) 826 | (ld e 0) 827 | (jr c box-or-skip) 828 | (ld e a) 829 | (xor a) 830 | 831 | ;; (db ,(string "hello")) 832 | 833 | (label box-or-skip) 834 | (label box-or-shift) 835 | (add a 8) 836 | (sub b) 837 | (ld c 0) 838 | (label box-or-shift1) 839 | (scf) 840 | (rr c) 841 | (dec a) 842 | (jr nz box-or-shift1) 843 | (ld a c) 844 | (inc b) 845 | (rlca) 846 | 847 | (label box-or-shift2) 848 | (rrca) 849 | (djnz box-or-shift2) 850 | 851 | (label box-or-loop1) 852 | (push hl) 853 | (ld b d) 854 | (ld c a) 855 | (push de) 856 | (ld de 12) 857 | 858 | (label box-or-loop2) 859 | (ld a c) 860 | (or (hl)) 861 | (ld (hl) a) 862 | (add hl de) 863 | (djnz box-or-loop2) 864 | (pop de) 865 | (pop hl) 866 | (inc hl) 867 | (ld a e) 868 | (or a) 869 | (ret z) 870 | (sub 8) 871 | (ld e b) 872 | (jr c box-or-shift) 873 | (ld e a) 874 | (ld a #b11111111) 875 | (jr box-or-loop1) 876 | (label box-or-end) 877 | 878 | (label rect-and) 879 | (ld a 96) 880 | (sub e) 881 | (ret c) 882 | (ret z) 883 | (cp c) 884 | (jr nc local-ra) 885 | (ld c a) 886 | (label local-ra) 887 | (ld a 64) 888 | (sub l) 889 | (ret c) 890 | (ret z) 891 | (cp b) 892 | (jr nc local-ra1) 893 | (ld b a) 894 | (label local-ra1) 895 | (xor a) 896 | (cp b) 897 | (ret z) 898 | (cp c) 899 | (ret z) 900 | (ld h a) 901 | (ld d a) 902 | (push bc) 903 | (push iy) 904 | (pop bc) 905 | (ld a l) 906 | (add a a) 907 | (add a l) 908 | (ld l a) 909 | (add hl hl) 910 | (add hl hl) 911 | (add hl bc) 912 | 913 | (ld a e) 914 | (srl e) 915 | (srl e) 916 | (srl e) 917 | (add hl de) 918 | (and #b00000111) 919 | (pop de) 920 | 921 | (ld b a) 922 | (add a e) 923 | (sub 8) 924 | (ld e 0) 925 | (jr c box-and-skip) 926 | (ld e a) 927 | (xor a) 928 | 929 | (label box-and-skip) 930 | (label box-and-shift) 931 | (add a 8) 932 | (sub b) 933 | (ld c 0) 934 | (label box-and-shift1) 935 | (scf) 936 | (rr c) 937 | (dec a) 938 | (jr nz box-and-shift1) 939 | (ld a c) 940 | (inc b) 941 | (rlca) 942 | (label box-and-shift2) 943 | (rrca) 944 | (djnz box-and-shift2) 945 | 946 | (label box-and-loop1) 947 | (push hl) 948 | (ld b d) 949 | (ld c a) 950 | (push de) 951 | (ld de 12) 952 | 953 | (label box-and-loop2) 954 | (ld a c) 955 | (cpl) 956 | (and (hl)) 957 | (ld (hl) a) 958 | (add hl de) 959 | (djnz box-and-loop2) 960 | (pop de) 961 | (pop hl) 962 | (inc hl) 963 | (ld a e) 964 | (or a) 965 | (ret z) 966 | (sub 8) 967 | (ld e b) 968 | (jr c box-and-shift) 969 | (ld e a) 970 | (ld a #b11111111) 971 | (jr box-and-loop1) 972 | (label box-and-end) 973 | 974 | (label put-sprite16-xor) 975 | ,@(with-regs-preserve (af hl bc de ix) 976 | (push hl) 977 | (pop ix) 978 | (ld a d) 979 | (call put-sprite16-xor2)) 980 | (ret) 981 | 982 | (label put-sprite16-xor2) 983 | (ld h 0) 984 | (ld l e) 985 | (ld d h) 986 | (add hl hl) 987 | (add hl de) 988 | (add hl hl) 989 | (add hl hl) 990 | (push iy) 991 | (pop de) 992 | (add hl de) 993 | (ld e a) 994 | (srl e) 995 | (srl e) 996 | (srl e) 997 | (ld d 0) 998 | (add hl de) 999 | (ld d h) 1000 | (ld e l) 1001 | (and 7) 1002 | (jp z aligned-or) 1003 | (ld c a) 1004 | (ld de 12) 1005 | (label row-loop-or) 1006 | (push bc) 1007 | (ld b c) 1008 | (xor a) 1009 | (ld d (+ ix 0)) 1010 | (ld e (+ ix 1)) 1011 | 1012 | (label shift-loop-or) 1013 | (srl d) 1014 | (rr e) 1015 | (rra) 1016 | (djnz shift-loop-or) 1017 | (inc hl) 1018 | (inc hl) 1019 | (xor (hl)) 1020 | (ld (hl) a) 1021 | (ld a e) 1022 | (dec hl) 1023 | (xor (hl)) 1024 | (ld (hl) a) 1025 | (ld a d) 1026 | (dec hl) 1027 | (xor (hl)) 1028 | (ld (hl) a) 1029 | (pop bc) 1030 | (ld de 12) 1031 | (add hl de) 1032 | (inc ix) 1033 | (inc ix) 1034 | (djnz row-loop-or) 1035 | (ret) 1036 | (label aligned-or) 1037 | (ld de 11) 1038 | 1039 | (label aligned-loop-or) 1040 | (ld a (+ ix 0)) 1041 | (xor (hl)) 1042 | (ld (hl) a) 1043 | (ld a (+ ix 1)) 1044 | (inc hl) 1045 | (xor (hl)) 1046 | (ld (hl) a) 1047 | (add hl de) 1048 | (inc ix) 1049 | (inc ix) 1050 | (djnz aligned-loop-or) 1051 | (ret) 1052 | 1053 | (label put-sprite16-and) 1054 | ,@(with-regs-preserve (af hl bc de ix) 1055 | (push hl) 1056 | (pop ix) 1057 | (ld a d) 1058 | (call put-sprite16-and2)) 1059 | (ret) 1060 | 1061 | (label put-sprite16-and2) 1062 | (ld h 0) 1063 | (ld l e) 1064 | (ld d h) 1065 | (add hl hl) 1066 | (add hl de) 1067 | (add hl hl) 1068 | (add hl hl) 1069 | (push iy) 1070 | (pop de) 1071 | (add hl de) 1072 | ;; (db ,(string "hello")) 1073 | 1074 | (ld e a) 1075 | (srl e) 1076 | (srl e) 1077 | (srl e) 1078 | (ld d 0) 1079 | (add hl de) 1080 | (ld d h) 1081 | (ld e l) 1082 | (and 7) 1083 | (jp z aligned-and) 1084 | (ld c a) 1085 | (ld de 12) 1086 | 1087 | (label row-loop-and) 1088 | (push bc) 1089 | (ld b c) 1090 | (xor a) 1091 | (ld d (+ ix 0)) 1092 | (ld e (+ ix 1)) 1093 | (label shift-loop-and) 1094 | (srl d) 1095 | (rr e) 1096 | (rra) 1097 | (djnz shift-loop-and) 1098 | (inc hl) 1099 | (inc hl) 1100 | (xor (hl)) 1101 | (ld (hl) a) 1102 | (ld a e) 1103 | (dec hl) 1104 | (cpl) 1105 | (and (hl)) 1106 | (ld (hl) a) 1107 | (ld a d) 1108 | (dec hl) 1109 | (cpl) 1110 | (and (hl)) 1111 | (ld (hl) a) 1112 | (pop bc) 1113 | (ld de 12) 1114 | (add hl de) 1115 | (inc ix) 1116 | (inc ix) 1117 | (djnz row-loop-and) 1118 | (ret) 1119 | (label aligned-and) 1120 | (ld de 11) 1121 | (label aligned-loop-and) 1122 | (ld a (+ ix 0)) 1123 | (cpl) 1124 | (and (hl)) 1125 | (ld (hl) a) 1126 | (ld a (+ ix 1)) 1127 | (inc hl) 1128 | (cpl) 1129 | (and (hl)) 1130 | (ld (hl) a) 1131 | (add hl de) 1132 | (inc ix) 1133 | (inc ix) 1134 | (djnz aligned-loop-and) 1135 | (ret))) 1136 | -------------------------------------------------------------------------------- /src/flash.scm: -------------------------------------------------------------------------------- 1 | (define flash-asm 2 | `((label write-flash-byte) 3 | (push bc) 4 | (ld b a) 5 | (push af) 6 | (ld a i) 7 | (push af) 8 | (di) 9 | (ld a b) 10 | ,@(push* '(hl de bc hl de bc)) 11 | 12 | (ld hl write-flash-byte-ram) 13 | (ld de flash-executable-ram) 14 | (ld bc #x1f) 15 | (ldir) 16 | ,@(pop* '(bc de hl)) 17 | (call flash-executable-ram) 18 | ,@(pop* '(bc de hl af)) 19 | (jp po local-label1) 20 | (ei) 21 | (label local-label1) 22 | ,@(pop* '(af bc)) 23 | (ret) 24 | (label write-flash-byte-ram) 25 | (and (hl)) 26 | (ld b a) 27 | (ld a #xaa) 28 | (ld (#xaaa) a) 29 | (ld a #x55) 30 | (ld (#x555) a) 31 | (ld a #xa0) 32 | (ld (#xaaa) a) 33 | (ld (hl) b) 34 | (label local-label2) 35 | (ld a b) 36 | (xor (hl)) 37 | (bit 7 a) 38 | (jr z write-flash-byte-done) 39 | (bit 5 (hl)) 40 | (jr z local-label2) 41 | (label write-flash-byte-done) 42 | (ld (hl) #xf0) 43 | (ret) 44 | 45 | (label write-flash-byte-ram-end) 46 | 47 | (label write-flash-buffer) 48 | (push af) 49 | (ld a i) 50 | (push af) 51 | (di) 52 | ,@(push* '(hl de bc hl de bc)) 53 | (ld hl write-flash-buffer-ram) 54 | (ld de flash-executable-ram) 55 | (ld bc #x2c) 56 | (ldir) 57 | ,@(pop* '(bc de hl)) 58 | (call flash-executable-ram) 59 | ,@(pop* '(bc de hl af)) 60 | (jp po local-label3) 61 | (ei) 62 | (label local-label3) 63 | (pop af) 64 | (ret) 65 | 66 | (label write-flash-buffer-ram) 67 | (label write-flash-buffer-loop) 68 | (ld a #xaa) 69 | (ld (#xaaa) a) 70 | (ld a #x55) 71 | (ld (#x555) a) 72 | (ld a #xa0) 73 | (ld (#xaaa) a) 74 | (ld a (hl)) 75 | (ld (de) a) 76 | (inc de) 77 | (dec bc) 78 | 79 | (label local-label4) 80 | (xor (hl)) 81 | (bit 7 a) 82 | (jr z local-label5) 83 | (bit 5 a) 84 | (jr z local-label4) 85 | (ld a #xf0) 86 | (ld (0) a) 87 | (ret) 88 | (label local-label5) 89 | (inc hl) 90 | (ld a b) 91 | (or a) 92 | (jr nz write-flash-buffer-loop) 93 | (ld a c) 94 | (or a) 95 | (jr nz write-flash-buffer-loop) 96 | (ret) 97 | 98 | (label write-flash-buffer-ram-end) 99 | 100 | (label erase-flash-sector) 101 | (push bc) 102 | (ld b a) 103 | (push af) 104 | (ld a i) 105 | (ld a i) 106 | (push af) 107 | (di) 108 | (ld a b) 109 | ,@(push* '(hl de bc hl de bc)) 110 | (ld hl erase-flash-sector-ram) 111 | (ld de flash-executable-ram) 112 | (ld bc #x30) 113 | (ldir) 114 | ,@(pop* '(bc de hl)) 115 | (call flash-executable-ram) 116 | ,@(pop* '(bc de hl af)) 117 | (jp po local-label6) 118 | (ei) 119 | (label local-label6) 120 | (pop af) 121 | (pop bc) 122 | (ret) 123 | 124 | (label erase-flash-sector-ram) 125 | (out (6) a) 126 | (ld a #xaa) 127 | (ld (#x0aaa) a) 128 | (ld a #x55) 129 | (ld (#x0555) a) 130 | (ld a #x80) 131 | (ld (#x0aaa) a) 132 | (ld a #xaa) 133 | (ld (#x0aaa) a) 134 | (ld a #x55) 135 | (ld (#x0555) a) 136 | (ld a #x30) 137 | (ld (#x4000) a) 138 | (label local-label7) 139 | (ld a (#x4000)) 140 | (bit 7 a) 141 | (ret nz) 142 | (bit 5 a) 143 | (jr z local-label7) 144 | (ld a #xf0) 145 | (ld (#x4000) a) 146 | (ret) 147 | (label erase-flash-sector-ram-end) 148 | 149 | (label erase-flash-page) 150 | ,@(push* '(af bc af)) 151 | (call copy-sector-to-swap) 152 | (pop af) 153 | (push af) 154 | (call erase-flash-sector) 155 | (pop af) 156 | (ld c a) 157 | (and #b11111100) 158 | (ld b ,swap-sector) 159 | (label local-label8) 160 | (cp c) 161 | (jr z local-label9) 162 | (call #x32d) 163 | (label local-label9) 164 | (inc b) 165 | (inc a) 166 | (push af) 167 | (ld a b) 168 | (and #b11111100) 169 | (or a) 170 | (jr z local-label10) 171 | (pop af) 172 | (jr local-label8) 173 | (label local-label10) 174 | ,@(pop* '(af bc af)) 175 | (ret) 176 | 177 | (label erase-flash-page-ram) 178 | (label copy-sector-to-swap) 179 | (push af) 180 | ;; (db (#xff #xff #xff)) 181 | (ld a ,swap-sector) 182 | (call erase-flash-sector) 183 | (pop af) 184 | (push bc) 185 | (ld b a) 186 | (push af) 187 | (ld a i) 188 | (ld a i) 189 | (push af) 190 | (di) 191 | (ld a b) 192 | (and #b11111100) 193 | (push hl) 194 | (push de) 195 | ;; (ld hl copy-sector-to-swap-ram) 196 | (ld hl #x2db) 197 | (push af) 198 | (ld a 1) 199 | (out (5) a) 200 | (ld de #xc000) 201 | (ld bc #x52) 202 | (ldir) 203 | (pop af) 204 | (ld hl #x4000) 205 | (add hl sp) 206 | (ld sp hl) 207 | (call #xc000) 208 | (xor a) 209 | (out (5) a) 210 | (ld hl 0) 211 | (add hl sp) 212 | (ld bc #x4000) 213 | (or a) 214 | (sbc hl bc) 215 | (ld sp hl) 216 | ,@(pop* '(de hl af)) 217 | (jp po local-label11) 218 | (ei) 219 | (label local-label11) 220 | (pop af) 221 | (pop bc) 222 | (ret) 223 | (label copy-sector-to-swap-ram) 224 | (out (7) a) 225 | (ld a ,swap-sector) 226 | (out (6) a) 227 | (label copy-sector-to-swap-preloop) 228 | (ld hl #x8000) 229 | (ld de #x4000) 230 | (ld bc #x4000) 231 | (label copy-sector-to-swap-loop) 232 | (ld a #xaa) 233 | (ld (#xaaa) a) 234 | (ld a #x55) 235 | (ld (#x555) a) 236 | (ld a #xa0) 237 | (ld (#xaaa) a) 238 | (ld a (hl)) 239 | (ld (de) a) 240 | (inc de) 241 | (dec bc) 242 | (label local-label12) 243 | (xor (hl)) 244 | (bit 7 a) 245 | (jr z local-label13) 246 | (bit 5 a) 247 | (jr z local-label12) 248 | (ld a #xf0) 249 | (ld (0) a) 250 | (ld a #x81) 251 | (out (7) a) 252 | (ret) 253 | (label local-label13) 254 | (inc hl) 255 | (ld a b) 256 | (or a) 257 | (jr nz copy-sector-to-swap-loop) 258 | (ld a c) 259 | (or a) 260 | (jr nz copy-sector-to-swap-loop) 261 | (in a (7)) 262 | (inc a) 263 | 264 | (out (7) a) 265 | (in a (6)) 266 | (inc a) 267 | (out (6) a) 268 | (and #b00000011) 269 | (or a) 270 | (jr nz copy-sector-to-swap-preloop) 271 | (ld a #x81) 272 | (out (7) a) 273 | (ret) 274 | 275 | (label copy-flash-page) 276 | (push de) 277 | (ld d a) 278 | (push af) 279 | (ld a i) 280 | (ld a i) 281 | (push af) 282 | (di) 283 | (ld a d) 284 | ,@(push* '(hl de af bc)) 285 | ;; (ld hl copy-flash-page-ram) 286 | (ld hl #x36c) 287 | (ld a 1) 288 | (out (5) a) 289 | (ld de #xc000) 290 | (ld bc #x42) 291 | (ldir) 292 | (pop bc) 293 | (pop af) 294 | (ld hl #x4000) 295 | ;; Forgetting a byte? 296 | (add hl sp) 297 | (ld sp hl) 298 | (call #xc000) 299 | (xor a) 300 | (out (5) a) 301 | (ld hl 0) 302 | (add hl sp) 303 | (ld bc #x4000) 304 | (or a) 305 | (sbc hl bc) 306 | (ld sp hl) 307 | ,@(pop* '(de hl bc af)) 308 | (jp po local-label14) 309 | (ei) 310 | (label local-label14) 311 | (pop af) 312 | (ret) 313 | 314 | (label copy-flash-page-ram) 315 | (out (6) a) 316 | (ld a b) 317 | (out (7) a) 318 | 319 | (label copy-flash-page-preloop) 320 | (ld hl #x8000) 321 | (ld de #x4000) 322 | (ld bc #x4000) 323 | (label copy-flash-page-loop) 324 | (ld a #xaa) 325 | (ld (#xaaa) a) 326 | (ld a #x55) 327 | (ld (#x555) a) 328 | (ld a #xa0) 329 | (ld (#xaaa) a) 330 | (ld a (hl)) 331 | (ld (de) a) 332 | (inc de) 333 | (dec bc) 334 | (label local-label15) 335 | (xor (hl)) 336 | (bit 7 a) 337 | (jr z local-label16) 338 | (bit 5 a) 339 | (jr z local-label15) 340 | (ld a #xf0) 341 | (ld (0) a) 342 | (ld a #x81) 343 | (out (7) a) 344 | (ret) 345 | (label local-label16) 346 | (inc hl) 347 | (ld a b) 348 | (or a) 349 | (jr nz copy-flash-page-loop) 350 | (ld a c) 351 | (or a) 352 | (jr nz copy-flash-page-loop) 353 | (ld a #x81) 354 | (out (7) a) 355 | (ret) 356 | (label copy-flash-page-ram-end) 357 | 358 | )) 359 | -------------------------------------------------------------------------------- /src/header.scm: -------------------------------------------------------------------------------- 1 | (include "macros.scm") 2 | (define header-asm 3 | `((jp boot) 4 | (db ,(map char->integer (string->list "SK"))) 5 | (db (0 0)) 6 | 7 | (dec sp) 8 | (ret) 9 | ,@(repeat 5 `(,@ (repeat 7 '((nop))) 10 | (ret))) 11 | ,@(repeat 7 '((nop))) 12 | ,(lambda () 13 | (format #t "System interrupt at 0x") 14 | (PRINT-PC)) 15 | (jp sys-interrupt) 16 | ,@(repeat 24 '((nop))) 17 | (jp boot) 18 | (db (#xff #xa5 #xff)))) 19 | -------------------------------------------------------------------------------- /src/interrupt.scm: -------------------------------------------------------------------------------- 1 | (define interrupt-asm 2 | `((label sys-interrupt) 3 | (di) 4 | ,@(push* '(af bc de hl ix iy)) 5 | (exx) 6 | ((ex af afs)) 7 | ,@(push* '(af bc de hl)) 8 | (jp usb-interrupt) 9 | (label interrupt-resume) 10 | (in a (4)) 11 | (bit 0 a) 12 | (jr nz int-handle-on) 13 | (bit 1 a) 14 | (jr nz int-handle-timer1) 15 | (bit 2 a) 16 | (jr nz int-handle-timer2) 17 | (bit 4 a) 18 | (jr nz int-handle-link) 19 | (jr sys-interrupt-done) 20 | 21 | (label int-handle-on) 22 | (in a (3)) 23 | (res 0 a) 24 | (out (3) a) 25 | (set 0 a) 26 | (out (3) a) 27 | (jr sys-interrupt-done) 28 | 29 | (label int-handle-timer1) 30 | (in a (3)) 31 | (res 1 a) 32 | (out (3) a) 33 | (set 1 a) 34 | (out (3) a) 35 | (jr sys-interrupt-done) 36 | 37 | (label int-handle-timer2) 38 | (in a (3)) 39 | (res 2 a) 40 | (out (3) a) 41 | (set 2 a) 42 | (out (3) a) 43 | (jr sys-interrupt-done) 44 | 45 | (label int-handle-link) 46 | (in a (3)) 47 | (res 4 a) 48 | (out (3) a) 49 | (set 4 a) 50 | (out (3) a) 51 | 52 | (label sys-interrupt-done) 53 | 54 | ,@(pop* '(hl de bc af)) 55 | (exx) 56 | ((ex af afs)) 57 | ,@(pop* '(iy ix hl de bc af)) 58 | (ei) 59 | (ret) 60 | (label usb-interrupt) 61 | (in a (#x55)) 62 | (bit 0 a) 63 | (jr z usb-unknown-event) 64 | (bit 2 a) 65 | (jr z usb-line-event) 66 | (bit 4 a) 67 | (jr z usb-protocol-event) 68 | (jp interrupt-resume) 69 | (label usb-unknown-event) 70 | (jp interrupt-resume) 71 | (label usb-line-event) 72 | 73 | (in a (#x56)) 74 | (xor #xff) 75 | (out (#x57) a) 76 | (jp interrupt-resume) 77 | 78 | (label usb-protocol-event) 79 | ,@(map (lambda (x) `(in a (,x))) 80 | '(#x82 #x83 #x84 #x85 #x86)) 81 | 82 | (jp interrupt-resume) 83 | )) 84 | -------------------------------------------------------------------------------- /src/keyboard.scm: -------------------------------------------------------------------------------- 1 | (define keyboard-asm 2 | `((label wait-key) 3 | (label local-label20) 4 | (call get-key) 5 | (or a) 6 | (jr z local-label20) 7 | (ret) 8 | 9 | (label flush-keys) 10 | (push af) 11 | (label local-label21) 12 | (call get-key) 13 | (or a) 14 | (jr nz local-label21) 15 | (pop af) 16 | (ret) 17 | 18 | (label get-key) 19 | ,@(push* '(bc de hl)) 20 | (label gs-getk2) 21 | (ld b 7) 22 | (label gs-getk-loop) 23 | (ld a 7) 24 | (sub b) 25 | (ld hl gs-keygroups) 26 | (ld d 0) 27 | (ld e a) 28 | (add hl de) 29 | (ld a (hl)) 30 | (ld c a) 31 | (ld a #xff) 32 | (out (1) a) 33 | (ld a c) 34 | (out (1) a) 35 | (nop) 36 | (nop) 37 | (nop) 38 | (nop) 39 | (in a (1)) 40 | 41 | (ld de 0) 42 | ,@(concat-map (lambda (x) 43 | (let ((dest (string->symbol (format #f "gs-getk-~a" x)))) 44 | `((cp ,x) 45 | (jr z ,dest)))) 46 | '(254 253 251 247 239 223 191 127)) 47 | 48 | (label gs-getk-loopend) 49 | (djnz gs-getk-loop) 50 | (xor a) 51 | (ld (#x8000) a) 52 | (jr gs-getk-end) 53 | 54 | ,@(concat-map (lambda (x) 55 | (let ((dest (string->symbol (format #f "gs-getk-~a" x)))) 56 | `((label ,dest) 57 | (inc e)))) 58 | '(127 191 223 239 247 251 253)) 59 | 60 | (label gs-getk-254) 61 | (push de) 62 | (ld a 7) 63 | (sub b) 64 | (add a a) 65 | (add a a) 66 | (add a a) 67 | (ld d 0) 68 | (ld e a) 69 | (ld hl gs-keygroup1) 70 | (add hl de) 71 | (pop de) 72 | (add hl de) 73 | (ld a (hl)) 74 | (ld d a) 75 | (ld a (flash-executable-ram)) 76 | (cp d) 77 | (jr z gs-getk-end) 78 | (ld a d) 79 | (ld (flash-executable-ram) a) 80 | 81 | (label gs-getk-end) 82 | (pop hl) 83 | (pop de) 84 | (pop bc) 85 | (ret) 86 | 87 | (label gs-keygroups) 88 | (db (#xFE #xFD #xFB #xF7 #xEF #xDF #xBF)) 89 | (label gs-keygroup1) 90 | (db (#x03 #x02 #x01 #x04 #x00 #x00 #x00 #x00)) 91 | (label gs-keygroup2) 92 | (db (#x09 #x0A #x0B #x0C #x0D #x0E #x0F #x00)) 93 | (label gs-keygroup3) 94 | (db (#x11 #x12 #x13 #x14 #x15 #x16 #x17 #x00)) 95 | (label gs-keygroup4) 96 | (db (#x19 #x1A #x1B #x1C #x1D #x1E #x1F #x20)) 97 | (label gs-keygroup5) 98 | (db (#x21 #x22 #x23 #x24 #x25 #x26 #x27 #x28)) 99 | (label gs-keygroup6) 100 | (db (#x00 #x2A #x2B #x2C #x2D #x2E #x2F #x30)) 101 | (label gs-keygroup7) 102 | (db (#x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38)))) 103 | -------------------------------------------------------------------------------- /src/macros.scm: -------------------------------------------------------------------------------- 1 | ;; Convenience functions 2 | (define (string s) 3 | `(,@(map char->integer (string->list s)) 0)) 4 | 5 | ;; At assembly time, print the value of the program counter. 6 | (define PRINT-PC 7 | (lambda () 8 | (format #t "~a\n" (num->hex *pc*)) 9 | ;; Macros need to return () or an instruction record.. 10 | '())) 11 | 12 | (define (make-multi-op op) 13 | (lambda (l) 14 | (map (lambda (x) `(,op ,x)) 15 | l))) 16 | 17 | ;; Multiple operations. 18 | (define push* (make-multi-op 'push)) 19 | (define pop* (make-multi-op 'pop)) 20 | (define call* (make-multi-op 'call)) 21 | 22 | ;; Relative jumps like JR $+3 23 | ;; Write ,(jr-rel 3) instead in the quasi-quoted program. 24 | (define (jr-rel amount) 25 | (lambda () (assemble-expr `(jr ,(+ *pc* amount)))) 26 | ) 27 | 28 | ;; With a flag 29 | (define (jr-rel-f flag amount) 30 | (lambda () (assemble-expr `(jr ,flag ,(+ *pc* amount)))) 31 | ) 32 | 33 | ;; Constant symbols. VAL must be an integer 34 | (define (equ sym val) 35 | (lambda () 36 | (if (not (16-bit-imm? val)) 37 | (error (format #f "Error in equ: Cannot set ~a to ~a." sym val)) 38 | (add-label! sym val)) 39 | '())) 40 | 41 | (define-syntax with-regs-preserve 42 | (syntax-rules () 43 | ((_ (reg reg* ...) body body* ...) 44 | `(,@(push* '(reg reg* ...)) 45 | body body* ... 46 | ,@(pop* (reverse '(reg reg* ...))))))) 47 | 48 | (define (fill-up-to byte addr) 49 | (lambda () 50 | (assemble-expr `(db ,(make-list 51 | (- addr *pc*) 52 | byte))))) 53 | 54 | (define fill-until-end 55 | (lambda () 56 | (assemble-expr 57 | `(db ,(make-list (- #x100000 *pc*) #xff))))) 58 | 59 | (define (concat l) (apply append l)) 60 | 61 | (define (repeat n expr) 62 | (concat (make-list n expr))) 63 | 64 | (define (concat-map f l) 65 | (concat (map f l))) 66 | -------------------------------------------------------------------------------- /src/math.scm: -------------------------------------------------------------------------------- 1 | (define math-asm 2 | `(;; Multiplies DE and BC -> result in DEHL 3 | (label mul-16-by-16) 4 | (ld hl 0) 5 | (ld a 16) 6 | (label mul-16-loop) 7 | (add hl hl) 8 | (rl e) 9 | (rl d) 10 | (jr nc no-mul-16) 11 | (add hl bc) 12 | (jr nc no-mul-16) 13 | (inc de) 14 | (label no-mul-16) 15 | (dec a) 16 | (jr nz mul-16-loop) 17 | (ret) 18 | 19 | ;; 8-bit / 8-bit -> quotient-in-D, remainder-in-A 20 | (label div-8-by-8) 21 | (xor a) 22 | (sla d) 23 | (rla) 24 | (cp e) 25 | ,@(concat-map 26 | (lambda (x) 27 | (let ((local (string->symbol (format #f "d88-local~a" x)))) 28 | `((jr c ,local) 29 | (sub e) (inc d) (sla d) 30 | (label ,local) 31 | (rla) (cp e)))) 32 | (iota 7)) 33 | (jr c d88-local8) 34 | (sub e) (inc d) 35 | (label d88-local8) 36 | (ret) 37 | 38 | ;; 8-bit x 8-bit -> HL (DE preserved) 39 | (label mul-8-by-8) 40 | (push de) 41 | (ld l 0) 42 | (ld d l) 43 | (sla h) 44 | (jr nc mul88-next-local) 45 | (ld l e) 46 | (label mul88-next-local) 47 | ,@(concat-map 48 | (lambda (x) 49 | (let ((iter (string->symbol (format #f "mul88-iter~a" (1+ x))))) 50 | `((add hl hl) 51 | (jr nc ,iter) 52 | (add hl de) 53 | (label ,iter)))) 54 | (iota 7)) 55 | (pop de) 56 | (ret) 57 | 58 | ;; 16-bit ÷ 8-bit -> quotient-in-L, remainder-in-A 59 | (label div-hl-by-c) 60 | (push bc) 61 | (xor a) 62 | (ld b 16) 63 | (label dhc-local) 64 | (add hl hl) 65 | (rla) 66 | (cp c) 67 | (jr c dhc-local2) 68 | (sub c) (inc l) 69 | (label dhc-local2) 70 | (djnz dhc-local) 71 | (pop bc) 72 | (ret))) 73 | -------------------------------------------------------------------------------- /src/text.scm: -------------------------------------------------------------------------------- 1 | ;; Text functions 2 | 3 | (define text-asm 4 | `((label newline) 5 | (push af) 6 | (ld a e) 7 | (add a 6) 8 | (ld e a) 9 | (ld d b) 10 | (pop af) 11 | (ret) 12 | 13 | (label wrap-char) 14 | (push ix) 15 | (db (#xdd)) 16 | (ld l 0) 17 | (call wrap-char-shared) 18 | (pop ix) 19 | (ret) 20 | 21 | (label wrap-char-and) 22 | (push ix) 23 | (db (#xdd)) 24 | (ld l 1) 25 | (call wrap-char-shared) 26 | (pop ix) 27 | (ret) 28 | 29 | (label wrap-char-xor) 30 | (push ix) 31 | (db (#xdd)) 32 | (ld l 2) 33 | (call wrap-char-shared) 34 | (pop ix) 35 | (ret) 36 | 37 | (label draw-char) 38 | (push ix) 39 | (db (#xdd)) 40 | (ld l 0) 41 | (call draw-char-shared) 42 | (pop ix) 43 | (ret) 44 | 45 | (label draw-char-and) 46 | (push ix) 47 | (db (#xdd)) 48 | (ld l 1) 49 | (call draw-char-shared) 50 | (pop ix) 51 | (ret) 52 | 53 | (label draw-char-xor) 54 | (push ix) 55 | (db (#xdd)) 56 | (ld l 2) 57 | (call draw-char-shared) 58 | (pop ix) 59 | (ret) 60 | 61 | (label draw-char-shared) 62 | ,@(push* '(af hl bc)) 63 | (cp ,(char->integer #\newline)) 64 | (jr nz local-labeldcs) 65 | (ld a e) 66 | (add a 6) 67 | (ld e a) 68 | (ld d b) 69 | (jr dcs-exit) 70 | (label local-labeldcs) 71 | 72 | (cp ,(char->integer #\tab)) 73 | (jr nz local-label22) 74 | (ld a d) 75 | (add a 6) 76 | (ld d a) 77 | (jr dcs-exit) 78 | 79 | (label local-label22) 80 | (push de) 81 | (sub #x20) 82 | (ld l a) 83 | (ld h 0) 84 | (add hl hl) 85 | (ld d h) 86 | (ld e l) 87 | (add hl hl) 88 | (add hl de) 89 | ((ex de hl)) 90 | (ld hl kernel-font) 91 | (add hl de) 92 | (ld a (hl)) 93 | (inc hl) 94 | (pop de) 95 | (ld b 5) 96 | (push af) 97 | (ld a d) 98 | (cp 95) 99 | (jr nc local-label23) 100 | (db (#xdd)) 101 | (ld a l) 102 | (or a) 103 | (call z put-sprite-or) 104 | (dec a) 105 | (call z put-sprite-and) 106 | (dec a) 107 | (call z put-sprite-xor) 108 | (pop af) 109 | (add a d) 110 | (ld d a) 111 | 112 | (label dcs-exit) 113 | ,@(pop* '(bc hl af)) 114 | (ret) 115 | (label local-label23) 116 | ,@(pop* '(af bc hl af)) 117 | (ret) 118 | 119 | (label wrap-char-shared) 120 | ,@(push* '(af bc hl)) 121 | (cp ,(char->integer #\newline)) 122 | (jr nz local-label24) 123 | (ld a e) 124 | (add a 6) 125 | (ld e a) 126 | (db (#xdd)) 127 | (ld d h) 128 | (jr wcs-exit) 129 | 130 | (label local-label24) 131 | (cp ,(char->integer #\tab)) 132 | (jr nz local-label25) 133 | (ld a d) 134 | (add a 6) 135 | (ld d a) 136 | (jr wcs-exit) 137 | 138 | (label local-label25) 139 | (push de) 140 | (sub #x20) 141 | (ld l a) 142 | (ld h 0) 143 | (add hl hl) 144 | (ld d h) 145 | (ld e l) 146 | (add hl hl) 147 | (add hl de) 148 | ((ex de hl)) 149 | (ld hl kernel-font) 150 | (add hl de) 151 | (ld a (hl)) 152 | (inc hl) 153 | (pop de) 154 | 155 | (add a d) 156 | (cp b) 157 | (jr c local-label26) 158 | (ld a e) 159 | (add a 6) 160 | (ld e a) 161 | (db (#xdd)) 162 | (ld d h) 163 | 164 | (label local-label26) 165 | (ld a e) 166 | (cp c) 167 | (jr nc local-label27) 168 | (ld b 5) 169 | (db (#xdd)) 170 | (ld a l) 171 | (or a) 172 | (call z put-sprite-or) 173 | (dec a) 174 | (call z put-sprite-and) 175 | (dec a) 176 | (call z put-sprite-xor) 177 | (dec hl) 178 | (ld a (hl)) 179 | (add a d) 180 | (ld d a) 181 | 182 | (label wcs-exit) 183 | ,@(pop* '(hl bc af)) 184 | (ret) 185 | 186 | (label local-label27) 187 | (ld e c) 188 | (jr wcs-exit) 189 | 190 | (label draw-str) 191 | (push ix) 192 | (db (#xdd)) 193 | (ld l 0) 194 | (call draw-str-shared) 195 | (pop ix) 196 | (ret) 197 | 198 | (label draw-str-and) 199 | (push ix) 200 | (db (#xdd)) 201 | (ld l 1) 202 | (call draw-str-shared) 203 | (pop ix) 204 | (ret) 205 | 206 | (label draw-str-xor) 207 | (push ix) 208 | (db (#xdd)) 209 | (ld l 2) 210 | (call draw-str-shared) 211 | (pop ix) 212 | (ret) 213 | 214 | (label draw-str-shared) 215 | (push hl) 216 | (push af) 217 | (label local-label28) 218 | (ld a (hl)) 219 | (or a) 220 | (jr z local-label29) 221 | (call draw-char-shared) 222 | (inc hl) 223 | (jr local-label28) 224 | 225 | (label local-label29) 226 | (pop af) 227 | (pop hl) 228 | (ret) 229 | 230 | (label draw-dec-a) 231 | ,@(push* '(af bc hl)) 232 | (ld c 0) 233 | (push af) 234 | (push de) 235 | (ld e 100) 236 | (ld d a) 237 | (call div-8-by-8) 238 | (ld a d) 239 | (pop de) 240 | (or a) 241 | (jr z no-100) 242 | (inc c) 243 | (ld b a) 244 | (add a ,(char->integer #\0)) 245 | (call draw-char) 246 | (ld a b) 247 | (ld b e) 248 | (ld e a) 249 | (ld h 100) 250 | (call mul-8-by-8) 251 | (ld e b) 252 | (pop af) 253 | (sub l) 254 | (jr done-100) 255 | (label no-100) 256 | (pop af) 257 | 258 | (label done-100) 259 | (push af) 260 | (push de) 261 | (ld e 10) 262 | (ld d a) 263 | (call div-8-by-8) 264 | (ld a d) 265 | (pop de) 266 | (ld b a) 267 | (or a) 268 | (or c) 269 | (ld a b) 270 | (jr z no-10) 271 | (ld b a) 272 | (add a ,(char->integer #\0)) 273 | (call draw-char) 274 | (ld a b) 275 | (ld b e) 276 | (ld e a) 277 | (ld h 10) 278 | (call mul-8-by-8) 279 | (ld e b) 280 | (pop af) 281 | (sub l) 282 | (jr done-10) 283 | (label no-10) 284 | (pop af) 285 | 286 | (label done-10) 287 | (add a ,(char->integer #\0)) 288 | (call draw-char) 289 | (pop hl) 290 | (pop bc) 291 | (pop af) 292 | (ret) 293 | 294 | 295 | (label draw-dec-hl) 296 | (push hl) 297 | (push bc) 298 | (push af) 299 | (ld b 0) 300 | (label dd-hl-loop) 301 | (push de) 302 | (ld de 0) 303 | (call cp-hl-de) 304 | (pop de) 305 | (jr z dd-hl-local) 306 | (ld c 10) 307 | (call div-hl-by-c) 308 | (push af) 309 | (inc b) 310 | (jr dd-hl-loop) 311 | (label dd-hl-local) 312 | (ld a b) 313 | (cp 0) 314 | (call z draw-dec-a) 315 | (label dd-hl-draw) 316 | (ld a b) 317 | (cp 0) 318 | (jr z dd-hl-local2) 319 | (pop af) 320 | (call draw-dec-a) 321 | (dec b) 322 | (jr dd-hl-draw) 323 | 324 | (label dd-hl-local2) 325 | (pop af) 326 | (pop bc) 327 | (pop hl) 328 | (ret) 329 | 330 | (label wrap-str) 331 | (push ix) 332 | (db (#xdd)) 333 | (ld h a) 334 | (db (#xdd)) 335 | (ld l 0) 336 | (call wrap-str-shared) 337 | (pop ix) 338 | (ret) 339 | 340 | (label wrap-str-shared) 341 | (push af) 342 | (label wss-local1) 343 | (ld a (hl)) 344 | (or a) 345 | (jr z wss-local2) 346 | (call wrap-char-shared) 347 | (ld a e) 348 | (cp c) 349 | (jr nc wss-local2) 350 | (inc hl) 351 | (jr wss-local1) 352 | 353 | (label wss-local2) 354 | (pop af) 355 | (ret) 356 | )) 357 | -------------------------------------------------------------------------------- /src/util.scm: -------------------------------------------------------------------------------- 1 | (define util-asm 2 | ;; util.asm 3 | `((label get-battery-level) 4 | (push af) 5 | (ld b 0) 6 | (ld a #b00000110) 7 | (out (6) a) 8 | (in a (2)) 9 | (bit 0 a) 10 | (jr z get-battery-level-done) 11 | 12 | (ld b 1) 13 | (ld a #b01000110) 14 | (out (6) a) 15 | (in a (2)) 16 | (bit 0 a) 17 | (jr z get-battery-level-done) 18 | 19 | (ld b 2) 20 | (ld a #b10000110) 21 | (out (6) a) 22 | (in a (2)) 23 | (bit 0 a) 24 | (jr z get-battery-level-done) 25 | 26 | (ld b 3) 27 | (ld a #b11000110) 28 | (out (6) a) 29 | (in a (2)) 30 | (bit 0 a) 31 | (jr z get-battery-level-done) 32 | (ld b 4) 33 | 34 | (label get-battery-level-done) 35 | (ld a #b110) 36 | (out (6) a) 37 | (pop af) 38 | (ret) 39 | 40 | (label sleep) 41 | (ld a i) 42 | (push af) 43 | (ld a 2) 44 | (out (#x10) a) 45 | (di) 46 | (im 1) 47 | (ei) 48 | (ld a 1) 49 | (out (3) a) 50 | (halt) 51 | (di) 52 | (ld a #xb) 53 | (out (3) a) 54 | (ld a 3) 55 | (out (#x10) a) 56 | (pop af) 57 | (ret po) 58 | (ei) 59 | (ret) 60 | 61 | (label de-mul-a) 62 | (ld hl 0) 63 | (ld b 8) 64 | (label de-mul-loop) 65 | (rrca) 66 | (jr nc de-mul-skip) 67 | (add hl de) 68 | (label de-mul-skip) 69 | (sla e) 70 | (rl d) 71 | (djnz de-mul-loop) 72 | (ret) 73 | 74 | (label unlock-flash) 75 | (push af) 76 | (push bc) 77 | (in a (6)) 78 | (push af) 79 | (ld a #x3c) 80 | (out (6) a) 81 | (ld b 1) 82 | (ld c #x14) 83 | (call #x4001) 84 | (pop af) 85 | (out (6) a) 86 | (pop bc) 87 | (pop af) 88 | (ret) 89 | 90 | (label lock-flash) 91 | (push af) 92 | (push bc) 93 | (in a (6)) 94 | (push af) 95 | (ld a #x3c) 96 | (out (6) a) 97 | (ld b 0) 98 | (ld c #x14) 99 | (call #x4017) 100 | (pop af) 101 | (out (6) a) 102 | (pop bc) 103 | (pop af) 104 | (ret) 105 | 106 | (label unprotect-ram) 107 | (xor a) 108 | (out (25) a) 109 | (dec a) 110 | (out (26) a) 111 | (ret) 112 | 113 | (label cp-hl-de) 114 | (push hl) 115 | (or a) 116 | (sbc hl de) 117 | (pop hl) 118 | (ret) 119 | 120 | (label cp-hl-bc) 121 | (push hl) 122 | (or a) 123 | (sbc hl bc) 124 | (pop hl) 125 | (ret) 126 | 127 | (label cp-bc-de) 128 | (push hl) 129 | (ld h b) 130 | (ld l c) 131 | (or a) 132 | (sbc hl de) 133 | (pop hl) 134 | (ret) 135 | 136 | (label cp-de-bc) 137 | (push hl) 138 | (ld h d) 139 | (ld l e) 140 | (or a) 141 | (sbc hl bc) 142 | (pop hl) 143 | (ret) 144 | 145 | (label compare-strings) 146 | (ld a (de)) 147 | (or a) 148 | (jr z compare-strings-eos) 149 | (cp (hl)) 150 | (ret nz) 151 | (inc hl) 152 | (inc de) 153 | (jr compare-strings) 154 | (label compare-strings-eos) 155 | (ld a (hl)) 156 | (or a) 157 | (ret) 158 | 159 | (label quicksort) 160 | ,@(push* '(hl de bc af)) 161 | (ld hl 0) 162 | (push hl) 163 | (label qs-loop) 164 | (ld h b) 165 | (ld l c) 166 | (or a) 167 | (sbc hl de) 168 | (jp c next1) 169 | (pop bc) 170 | (ld a b) 171 | (or c) 172 | (jr z end-qs) 173 | (pop de) 174 | (jp qs-loop) 175 | 176 | (label next1) 177 | (push de) 178 | (push bc) 179 | (ld a (bc)) 180 | (ld h a) 181 | (dec bc) 182 | (inc de) 183 | 184 | (label fleft) 185 | (inc bc) 186 | (ld a (bc)) 187 | (cp h) 188 | (jp c fleft) 189 | 190 | (label fright) 191 | (dec de) 192 | (ld a (de)) 193 | (ld l a) 194 | (ld a h) 195 | (cp l) 196 | (jp c fright) 197 | (push hl) 198 | (ld h d) 199 | (ld l e) 200 | (or a) 201 | (sbc hl bc) 202 | (jp c next2) 203 | (ld a (bc)) 204 | (ld h a) 205 | (ld a (de)) 206 | (ld (bc) a) 207 | (ld a h) 208 | (ld (de) a) 209 | (pop hl) 210 | (jp fleft) 211 | 212 | (label next2) 213 | (pop hl) 214 | (pop hl) 215 | (push bc) 216 | (ld b h) 217 | (ld c l) 218 | (jp qs-loop) 219 | 220 | (label end-qs) 221 | ,@(pop* '(af bc de hl)) 222 | (ret))) 223 | -------------------------------------------------------------------------------- /src/zkeme80.scm: -------------------------------------------------------------------------------- 1 | (load "assembler.scm") 2 | (load "macros.scm") 3 | 4 | (define swap-sector #x38) 5 | (load "forth.scm") 6 | (load "header.scm") 7 | (load "boot.scm") 8 | (load "interrupt.scm") 9 | (load "flash.scm") 10 | (load "util.scm") 11 | (load "display.scm") 12 | (load "keyboard.scm") 13 | (load "math.scm") 14 | (load "font.scm") 15 | (load "text.scm") 16 | ;; Essential code that modifies sets an interrupt mode of 1 and writes 17 | ;; to port #x14. 18 | (define wtf-prog 19 | `((rst 0) 20 | (ld a i) 21 | (jp pe #x4008) 22 | (ld a i) 23 | (push af) 24 | (di) 25 | (ld a 1) 26 | (nop) 27 | (nop) 28 | (im 1) 29 | (di) 30 | (out (#x14) a) 31 | (pop af) 32 | (ret po) 33 | (ei) 34 | (ret) 35 | (ld a i) 36 | (jp pe #x401e) 37 | (ld a i) 38 | (push af) 39 | (di) 40 | (xor a) 41 | (nop) 42 | (nop) 43 | (im 1) 44 | (di) 45 | (out (#x14) a) 46 | (pop af) 47 | (ret po) 48 | (ei) 49 | (ret) 50 | (nop) 51 | (rst #x38))) 52 | 53 | (define zkeme80 54 | `(,(equ 'flash-executable-ram #x8000) 55 | ,(equ 'flash-executable-ram-size 100) 56 | ,(equ 'screen-buffer #x8100) 57 | ,(equ 'swap-sector #x38) 58 | 59 | ,@header-asm 60 | ,@boot-asm 61 | ,@interrupt-asm 62 | ,@flash-asm 63 | ,@util-asm 64 | ,@display-asm 65 | ,@keyboard-asm 66 | ,@math-asm 67 | ,@font-asm 68 | ,@text-asm 69 | 70 | (label bootstrap-fs) 71 | ,@(include-file-as-bytes "boot.fs") 72 | 73 | (label os-end) 74 | ,(lambda () 75 | (format #t "End of zkeme80 kernel: 0x") 76 | (PRINT-PC) 77 | (format #t "~a bytes left for page 0.\n" (- #x4000 *pc*)) 78 | '()) 79 | ;; Must be less than 0x4000. 80 | 81 | ,(fill-up-to #xff #x4000) 82 | 83 | (label bootstrap-flash1) 84 | ,@(include-file-as-bytes "bootstrap-flash1.fs") 85 | 86 | ,(fill-up-to #xff #x8000) 87 | 88 | (label bootstrap-flash2) 89 | ,@(include-file-as-bytes "bootstrap-flash2.fs") 90 | 91 | 92 | ,(lambda () 93 | (format #t "Start of Forth data: 0x") 94 | (PRINT-PC) 95 | (format #t "~a bytes left for page 2.\n" (- #x8400 *pc*)) 96 | '()) 97 | 98 | 99 | 100 | ,(fill-up-to #xff #x8402) 101 | 102 | ;; We start the Forth data here. 103 | ,@(concat-map (lambda (x) 104 | `((label ,(car x)) 105 | (dw (,(cdr x))))) 106 | (reverse *var-list*)) 107 | 108 | ;; Forth system variables. Put here because it's writable when 109 | ;; loaded into RAM. 110 | 111 | 112 | ;; Transient input buffer. 113 | (label input-buffer) 114 | (db ,(make-list 128 0)) 115 | 116 | ;; Transient word buffer. 117 | (label word-buffer) 118 | (db ,(make-list 32 0)) 119 | (label word-ptr) 120 | (dw (0)) 121 | 122 | ;; Example input device; the Forth word "EXPECT". 123 | ;; See "EXPECT" in forth.scm for the source. 124 | (label expect-ptr-initial) 125 | (dw (0)) 126 | (label expect-ptr) 127 | (dw (0)) 128 | (label expect-count) 129 | (dw (0)) 130 | (label expect-col-save) 131 | (dw (0)) 132 | (label expect-row-save) 133 | (dw (0)) 134 | 135 | (label ddd-data) 136 | (db (0)) 137 | 138 | (label prompt-space) 139 | (db ,(make-list 128 0)) 140 | 141 | ;; This value, when incremented, becomes 0. This causes REFILL to 142 | ;; detect that this "device" no longer has input, and thus will stop. 143 | (label bootstrap-load-bool) 144 | (dw (65535)) 145 | 146 | (dw ,(make-list 128 0)) 147 | (label return-stack-start) 148 | 149 | ;; Free space until #xc000 150 | (label dp-start) 151 | ,(lambda () 152 | (format #t "~a bytes left for HERE.\n" (- #xc000 *pc*)) 153 | '()) 154 | 155 | ,(fill-up-to #x0 #xc000) 156 | 157 | ,@(include-file-as-bytes "bootstrap-flash3.fs") 158 | ,(fill-up-to #xff #x10000) 159 | 160 | ,@(include-file-as-bytes "bootstrap-flash4.fs") 161 | ,(fill-up-to #xff #x14000) 162 | 163 | ,@(include-file-as-bytes "bootstrap-flash5.fs") 164 | 165 | ,(lambda () 166 | (format #t "End of Forth data: 0x") 167 | (PRINT-PC) 168 | (format #t "~a bytes left for page 4.\n" (- #x18000 *pc*)) 169 | '()) 170 | 171 | ,(fill-up-to #xff #xf0000) 172 | 173 | ,@wtf-prog 174 | 175 | ,fill-until-end 176 | 177 | ,(lambda () 178 | (format #t "End of binary: 0x") 179 | (PRINT-PC)) 180 | )) 181 | 182 | (define (make-rom filename) 183 | (assemble-to-file zkeme80 filename)) 184 | 185 | (define (remake filename) 186 | (load "zkeme80.scm") 187 | (make-rom filename)) 188 | -------------------------------------------------------------------------------- /words/backtracking.fs: -------------------------------------------------------------------------------- 1 | \ A collection of little fun backtracking experiments. 2 | ." Backtracking" CR 3 | 4 | \ This example uses the exception system (CATCH and THROW) to 5 | \ implement backtracking. 6 | \ Source: 7 | \ https://web.archive.org/web/20190107141051/https://www.complang.tuwien.ac.at/forth/backtracking-in-ansforth 8 | 9 | : PUSH-RETURN ( ret-stack1 ret-addr -- ret-stack2 ) 10 | HERE 2 CELLS ALLOT 11 | SWAP OVER CELL+ ! 12 | SWAP OVER ! 13 | ; 14 | 15 | : POP-RETURN ( ret-stack1 -- ret-stack2 ret-addr ) 16 | DUP CELL+ @ 17 | SWAP @ 18 | ; 19 | 20 | : CHOICE 21 | \ works like RETURN ( ret-stack1 -- ret-stack2 ), but creates a 22 | \ choicepoint i.e., it catches a failure; exits upon failure with 23 | \ stack effect ( ret-stack -- ) 24 | POP-RETURN CATCH 25 | DUP 1 <> IF \ it's not a failure, but something else 26 | THROW 27 | THEN 28 | DROP 29 | ; 30 | 31 | 32 | : RETURN ( ret-stack1 -- ret-stack2 ) 33 | \ never exits; stack-effect with respect to the word returned to. 34 | POP-RETURN EXECUTE 35 | ; 36 | 37 | 38 | : FAIL \ neither exits nor returns 39 | 1 THROW ; 40 | 41 | : BEGIN-CHOICES ' >R , ; IMMEDIATE 42 | : END-CHOICES ' R> , ' RETURN , ; IMMEDIATE 43 | : MAYBE ' R@ , ' CHOICE , ; IMMEDIATE 44 | 45 | : ONE-TO-FOUR ( RET-STACK1 -- N RET-STACK2 ) 46 | BEGIN-CHOICES 47 | 1 MAYBE 2 MAYBE 3 MAYBE 4 48 | END-CHOICES 49 | ; 50 | 51 | : FOO-PART2 ( ret-stack -- ... ) 52 | \ never exits, never returns we can treat "." as primitive here; it 53 | \ does not do choicepoints, failure etc. 54 | >R . FAIL 55 | ; 56 | 57 | : FOO ( ret-stack -- ... ) \ never exits, never returns 58 | ' FOO-PART2 SWAP PUSH-RETURN ONE-TO-FOUR 59 | ; 60 | 61 | : SUCCEED 62 | \ get out of the return/backtracking mode 63 | 2 THROW 64 | ; 65 | 66 | : WRAPPER ( xt -- ) 67 | \ execute xt in return/backtracking mode 68 | ' SUCCEED 0 PUSH-RETURN SWAP CATCH 69 | CASE 70 | 1 OF ." FAILURE" ENDOF 71 | 2 OF ." SUCCESS" ENDOF 72 | THROW 73 | ENDCASE 74 | DROP 75 | ; 76 | 77 | ' FOO WRAPPER \ 1 2 3 4 FAILURE 78 | CR .S \ should be empty 79 | 80 | : EVEN? 2 MOD 0= ; 81 | 82 | : FIRST-EVEN 83 | >R 84 | DUP EVEN? IF . SUCCEED THEN 85 | FAIL 86 | ; 87 | 88 | : FIND-EVEN 89 | ' FIRST-EVEN SWAP PUSH-RETURN ONE-TO-FOUR 90 | ; 91 | 92 | ' FIND-EVEN WRAPPER \ 2 SUCCEED 93 | 94 | CR .S \ should be empty 95 | 96 | \ The following code is inspired by a EuroForth paper. 97 | \ https://web.archive.org/web/20190107141634/http://www.complang.tuwien.ac.at/anton/euroforth/ef99/gassanenko99b.pdf 98 | 99 | \ Let's try something else. This backtracking system has only three 100 | \ amazing primitives, ENTER, SUCC and FAIL. 101 | 102 | : ENTER >R ; 103 | : SUCC ' R@ , ' ENTER , ; IMMEDIATE 104 | : FAIL ' R> , ' DROP , ' EXIT , ; IMMEDIATE 105 | 106 | : RANGE ( low high "name" -- ) 107 | 1+ >R 1- 108 | CREATE 109 | ' LIT , 110 | , 111 | POSTPONE BEGIN 112 | ' 1+ , 113 | ' DUP , 114 | ' LIT , 115 | R> 116 | , 117 | ' < , 118 | POSTPONE WHILE 119 | POSTPONE SUCC 120 | POSTPONE REPEAT 121 | ' DROP , 122 | POSTPONE FAIL 123 | ' EXIT , 124 | ; 125 | 126 | \ 1-10 can be thought of as the non-deterministic numbers from 1 to 127 | \ 10. 128 | 1 10 RANGE 1-10 129 | 130 | \ Succeed or fail depending on whether the number on the stack is 131 | \ divisible by 2. 132 | : //2 EVEN? IF SUCC ELSE FAIL THEN ; 133 | 134 | \ Take the numbers from 1 to 10, filter the even ones and print them. 135 | : .even1-10 1-10 //2 DUP . ; 136 | 137 | .even1-10 CR \ 2 4 6 8 10 138 | 139 | \ Magic! 140 | 141 | \ Let's do something a little bit more complicated: subsets. 142 | 143 | : el R@ ENTER DROP ; 144 | 145 | \ Note: ?DO is not implemented yet at the time of writing, so this 146 | \ will suffice. 147 | : .{} CR ." { " DEPTH 0 2DUP = IF 2DROP ELSE DO I PICK . LOOP THEN ." } " ; 148 | 149 | : subsets 1 150 | el 2 151 | el 3 152 | el .{} ; 153 | 154 | PAGE subsets 155 | 156 | ( 157 | 158 | You should get the following output: 159 | 160 | { 3 2 1 } 161 | { 2 1 } 162 | { 3 1 } 163 | { 1 } 164 | { 3 2 } 165 | { 2 } 166 | { 3 } 167 | { } 168 | 169 | ) 170 | 171 | \ That's about it! 172 | SHUTDOWN 173 | -------------------------------------------------------------------------------- /words/coroutines.fs: -------------------------------------------------------------------------------- 1 | \ Simple demonstration of coroutines. 2 | 3 | : CO R> R> SWAP >R >R ; 4 | 5 | : TOKYO 6 | ." HERE TOKYO OVER" CR CO 7 | ." WHAT GIVES? OVER" CR CO 8 | ." YES, MORE? OVER" CR CO 9 | ." OVER AND OUT" CR 10 | ; 11 | 12 | : AMSTERDAM 13 | TOKYO 14 | ." HERE AMSTERDAM OVER" CR CO 15 | ." HAS IT ARRIVED OVER" CR CO 16 | ." NO. OVER AND OUT" CR 17 | 18 | ; 19 | 20 | PAUSE PAGE 21 | ." EXPECT SENSIBLE CONVERSATION:" CR AMSTERDAM 22 | -------------------------------------------------------------------------------- /words/cursor.fs: -------------------------------------------------------------------------------- 1 | 1 CONSTANT RIGHT 2 | 2 CONSTANT LEFT 3 | 3 CONSTANT UP 4 | 4 CONSTANT DOWN 5 | VARIABLE CURX 6 | VARIABLE CURY 7 | VARIABLE CURR-CURSOR 8 | 9 | : INC! 1 SWAP +! ; 10 | : DEC! 1 SWAP -! ; 11 | 12 | : INC-CURX CURX INC! ; 13 | : INC-CURY CURY INC! ; 14 | 15 | : DEC-CURX CURX @ IF CURX DEC! THEN ; 16 | : DEC-CURY CURY @ IF CURY DEC! THEN ; 17 | 18 | 95 CONSTANT MAX-X 19 | 63 CONSTANT MAX-Y 20 | : NORMALIZE-X CURX @ 0 MAX MAX-X MIN CURX ! ; 21 | : NORMALIZE-Y CURY @ 0 MAX MAX-Y MIN CURY ! ; 22 | : NORMALIZE-POS NORMALIZE-X NORMALIZE-Y ; 23 | : KEY-TICK 24 | CASE 25 | RIGHT OF INC-CURX ENDOF 26 | LEFT OF DEC-CURX ENDOF 27 | UP OF INC-CURY ENDOF 28 | DOWN OF DEC-CURY ENDOF 29 | ENDCASE 30 | NORMALIZE-POS 31 | ; 32 | 33 | : DRAW-SQUARE ( X Y SIZE -- ) DUP RECT-XOR ; 34 | : DRAW-CURSOR CURX @ CURY @ 10 DRAW-SQUARE ; 35 | 36 | : DRAW-CURSOR-POS 0 0 AT-XY CURX ? CURY ? ; 37 | : DRAW-TICK DRAW-CURSOR DRAW-CURSOR-POS ; 38 | : ARROW-KEY? 1 4 WITHIN ; 39 | : GET-ARROW-KEY BEGIN KEYC DUP ARROW-KEY? IF EXIT THEN DROP AGAIN ; 40 | : CURSOR-DEMO-TICK GET-ARROW-KEY PAGE KEY-TICK DRAW-TICK ; 41 | : CURSOR-DEMO-INIT 0 CURX ! 0 CURY ! ; 42 | : CURSOR-DEMO CURSOR-DEMO-INIT BEGIN CURSOR-DEMO-TICK AGAIN ; 43 | -------------------------------------------------------------------------------- /words/editor.fs: -------------------------------------------------------------------------------- 1 | \ An editor. Since we're using a lot of memory we're going to assign 2 | \ it to use AppBackupScreen. 3 | 4 | : INVTXT ; 5 | 6 | : TITLE ( -- ) 7 | 0 0 CHAR-AT-XY 8 | INVTXT 9 | ." --------EDITOR----------" 10 | INVTXT 11 | ; 12 | 13 | \ : TYPE ( c-addr u -- ) 14 | \ 0 DO DUP C@ DUP 13 = IF [CHAR] n THEN EMIT 1+ LOOP DROP 15 | \ ; 16 | 17 | 18 | ( Display the text area ) 19 | : TXTAREA ( addr -- addr ) 20 | DUP 21 | 0 1 CHAR-AT-XY 22 | 240 TYPE 23 | ; 24 | 25 | ( addr -- addr ) 26 | 24 CONSTANT LINE-SIZE 27 | LINE-SIZE 5 * CONSTANT PAGE-SIZE 28 | : NEXT-LINE LINE-SIZE + ; 29 | : PREV-LINE LINE-SIZE - ; 30 | : NEXT-PAGE PAGE-SIZE + ; 31 | : PREV-PAGE PAGE-SIZE - ; 32 | 33 | : FRAME PAGE TITLE TXTAREA ; 34 | 35 | : CHAR- ( linum -- charnum ) 36 | 16 * 37 | ; 38 | 39 | : MARK-LINE ( addr linum -- addr linum ) 40 | 2DUP 41 | DUP 1+ 0 CHAR-AT-XY 42 | CHAR- + 16 INVTXT TYPE INVTXT 43 | ; 44 | 45 | 46 | : MODE-FRAME ( addr linum -- addr linum ) 47 | OVER FRAME DROP 48 | MARK-LINE 49 | ; 50 | 51 | ( addr count char -- ) 52 | : FILL -ROT 0 DO 2DUP C! 1+ LOOP 2DROP ; 53 | 54 | : CL-LINE ( addr linum -- addr linum ) 55 | 2DUP CHAR- + 16 32 FILL 56 | ; 57 | 58 | : DELETE-TITLE ( -- ) 59 | ORIGIN 60 | INVTXT 61 | ." --------DELETE----------" 62 | INVTXT 63 | ; 64 | 65 | : DELETE-MODE ( addr -- addr ) 66 | 0 67 | BEGIN 68 | MODE-FRAME DELETE-TITLE 69 | KEY DUP 10 <> 70 | WHILE 71 | CASE 72 | 3 OF DUP 0= IF DROP 6 ELSE 1- THEN ENDOF 73 | 4 OF DUP 6 = IF DROP 0 ELSE 1+ THEN ENDOF 74 | 9 OF CL-LINE PAGE ENDOF 75 | ENDCASE 76 | REPEAT 77 | 2DROP 78 | ; 79 | 80 | 81 | 82 | : EDITOR ( addr -- addr ) 83 | BEGIN 84 | FRAME 85 | KEY DUP 5 <> 86 | WHILE 87 | CASE 88 | 3 OF PREV-LINE ENDOF 89 | 4 OF NEXT-LINE ENDOF 90 | 1 OF NEXT-PAGE ENDOF 91 | 2 OF PREV-PAGE ENDOF 92 | 10 OF DELETE-MODE ENDOF 93 | ENDCASE 94 | REPEAT 95 | DROP 96 | ; 97 | 98 | 99 | INPUT-PTR @ EDITOR 100 | -------------------------------------------------------------------------------- /words/see.fs: -------------------------------------------------------------------------------- 1 | : SEE 2 | 3 | ( find the dictionary entry to decompile ) 4 | WORD FIND 5 | 6 | ( Now we search again, looking for the next word in the dictionary. 7 | This gives us the length of the word that we will be decompiling. 8 | Well, mostly it does. ) 9 | 10 | HERE ( address of the end of the last compiled word ) 11 | LATEST @ ( word last curr ) 12 | BEGIN 13 | 2 PICK ( word last curr word ) 14 | OVER ( word last curr word curr ) 15 | <> ( word last curr word<>curr? ) 16 | WHILE ( word last curr ) 17 | NIP ( word curr ) 18 | DUP @ ( word curr prev which becomes: word last curr ) 19 | REPEAT 20 | 21 | 22 | DROP ( at this point, the stack is: start-of-word end-of-word ) 23 | SWAP ( end-of-word start-of-word ) 24 | 25 | ( begin the definition with : NAME [IMMEDIATE] ) 26 | [CHAR] : EMIT SPACE DUP ID. SPACE 27 | DUP ?IMMEDIATE >R 28 | 29 | >DFA ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) 30 | 31 | ( now we start decompiling until we hit the end of the word ) 32 | BEGIN ( end start ) 33 | 2DUP > 34 | WHILE 35 | DUP @ ( end start codeword ) 36 | 37 | CASE 38 | ['] LIT OF ( is it LIT ? ) 39 | 2+ DUP @ ( get next word which is the integer constant ) 40 | . ( and print it ) 41 | ENDOF 42 | ['] LITSTRING OF ( is it LITSTRING ? ) 43 | [CHAR] S EMIT 44 | [CHAR] " EMIT 45 | SPACE ( print S" ) 46 | 2+ DUP @ ( get the length ) 47 | SWAP 2+ SWAP ( end start+2 length ) 48 | 2DUP TELL ( print the string ) 49 | [CHAR] " EMIT SPACE ( finish the string with a final quote ) 50 | + ( end start+4+len, aligned ) 51 | 1+ ( because we're about to add 4 below ) 52 | ENDOF 53 | ['] 0BRANCH OF ( is it 0BRANCH ? ) 54 | ." 0BRANCH ( " 55 | 2+ DUP @ ( print the offset ) 56 | . 57 | ." ) " 58 | ENDOF 59 | ['] BRANCH OF ( is it BRANCH ? ) 60 | ." BRANCH ( " 61 | 2+ DUP @ ( print the offset ) 62 | . 63 | ." ) " 64 | ENDOF 65 | ['] JUMP OF ( is it JUIMP ? ) 66 | ." JUMP ( " 67 | 2+ DUP @ ( print the offset ) 68 | . 69 | ." ) " 70 | ENDOF 71 | 72 | ['] 0JUMP OF ( is it 0JUMP ? ) 73 | ." 0JUMP ( " 74 | 2+ DUP @ ( print the offset ) 75 | . 76 | ." ) " 77 | ENDOF 78 | ['] (') OF ( is it ' TICK ? ) 79 | ." [']" SPACE 80 | 2+ DUP @ ( get the next codeword ) 81 | CFA> ( and force it to be printed as a dictionary entry ) 82 | ID. SPACE 83 | ENDOF 84 | ['] EXIT OF ( is it EXIT? ) 85 | 86 | ( We expect the last word to be EXIT, and if it is then we 87 | don't print it because EXIT is normally implied by ;. EXIT 88 | can also appear in the middle of words, and then it needs to 89 | be printed. ) 90 | 91 | 2DUP ( end start end start ) 92 | 2+ ( end start end start+4 ) 93 | <> IF ( end start | we're not at the end ) 94 | ." EXIT " 95 | THEN 96 | ENDOF 97 | ( default case: ) 98 | DUP ( in the default case we always need to DUP before using ) 99 | CFA> ( look up the codeword to get the dictionary entry ) 100 | ID. SPACE ( and print it ) 101 | ENDCASE 102 | 103 | 2+ ( end start+2 ) 104 | REPEAT 105 | 106 | [CHAR] ; EMIT 107 | 108 | R> IF ." IMMEDIATE " THEN 109 | CR 110 | 111 | 2DROP ( restore stack ) 112 | ; 113 | 114 | SEE SEE 115 | -------------------------------------------------------------------------------- /words/test-suite.fs: -------------------------------------------------------------------------------- 1 | : CONSTANT WORD CREATE DOCOL-H ' LIT , , ' EXIT , ; 2 | 3 | HERE @ 32 CELLS ALLOT NIP CONSTANT ACTUAL-RESULTS 4 | \ : ARRAY WORD CREATE DOCOL-H ' LIT , CELLS ALLOT , ; 5 | 6 | VARIABLE ACTUAL-DEPTH \ stack record 7 | 8 | \ 32 ARRAY ACTUAL-RESULTS 9 | \ 10 | VARIABLE START-DEPTH 11 | 12 | VARIABLE XCURSOR \ for ...}T 13 | 14 | VARIABLE ERROR-XT 15 | 16 | 17 | PAGE 18 | 19 | 20 | : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting 21 | 22 | 23 | : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. 24 | DEPTH START-DEPTH @ < IF 25 | DEPTH START-DEPTH @ SWAP DO 0 LOOP 26 | THEN 27 | DEPTH START-DEPTH @ > IF 28 | DEPTH START-DEPTH @ DO DROP LOOP 29 | THEN 30 | ; 31 | 32 | 33 | 34 | : TYPE 0 DO DUP C@ EMIT 1+ LOOP DROP ; 35 | 36 | 37 | 38 | : UNLOOP ( -- , R: I LIMIT -- : REMOVE LIMIT AND I FROM ) 39 | R> ( SAVE OUR RETURN ADDRESS ) 40 | RDROP ( POP OFF I ) 41 | RDROP ( POP OFF LIMIT ) 42 | >R 43 | ; 44 | 45 | : LEAVE ( -- , R: I LIMIT RETURN -- : BREAK OUT OF A DO-LOOP CONSTRUCT ) 46 | UNLOOP 47 | RDROP 48 | ; ( RETURN TO THE CALLER'S CALLER ROUTINE ) 49 | 50 | 51 | : SEEK-NEWLINE-BACK 52 | \ Need this, why? 53 | 2- 54 | BEGIN 55 | DUP C@ 10 = 56 | IF 57 | 1+ EXIT 58 | ELSE 59 | 1- 60 | THEN 61 | AGAIN 62 | ; 63 | 64 | : EMIT-UNTIL-NEWLINE 65 | BEGIN 66 | DUP C@ 10 = 67 | IF 68 | DROP EXIT 69 | ELSE 70 | DUP C@ EMIT 1+ 71 | THEN 72 | AGAIN 73 | ; 74 | 75 | 76 | : ERROR1 \ ( C-ADDR U -- ) display an error message 77 | \ followed by the line that had the error. 78 | TYPE CR INPUT-PTR @ SEEK-NEWLINE-BACK EMIT-UNTIL-NEWLINE CR 79 | \ display line corresponding to error 80 | EMPTY-STACK \ throw away everything else 81 | ; 82 | 83 | 84 | ' ERROR1 ERROR-XT ! 85 | 86 | : T{ \ ( -- ) syntactic sugar. 87 | DEPTH START-DEPTH ! 0 XCURSOR ! 88 | ; 89 | 90 | PAGE 91 | 92 | : -> \ ( ... -- ) record depth and contents of stack. 93 | DEPTH DUP ACTUAL-DEPTH ! \ record depth 94 | START-DEPTH @ > IF \ if there is something on the stack 95 | DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them 96 | THEN 97 | ; 98 | 99 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 100 | \ (ACTUAL) CONTENTS. 101 | DEPTH ACTUAL-DEPTH @ = IF \ if depths match 102 | DEPTH START-DEPTH @ > IF \ if there is something on the stack 103 | DEPTH START-DEPTH @ - 0 DO \ for each stack item 104 | ACTUAL-RESULTS I CELLS + @ \ compare actual with expected 105 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 106 | LOOP 107 | THEN 108 | ELSE \ depth mismatch 109 | S" WRONG NUMBER OF RESULTS: " ERROR 110 | THEN 111 | ; 112 | 113 | 114 | : ...}T ( -- ) 115 | XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 116 | S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 117 | ELSE DEPTH START-DEPTH @ = 0= IF 118 | S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 119 | THEN THEN 120 | ; 121 | 122 | \ Bit shifts are not fast! 123 | : RSHIFT ?DUP IF 0 DO 2/ LOOP THEN ; 124 | : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ; 125 | 126 | : { T{ ; 127 | : } }T ; 128 | PAGE 129 | 130 | 131 | { -> } \ START WITH CLEAN SLATE 132 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 133 | { : BITSSET? IF 0 0 ELSE 0 THEN ; -> } 134 | { 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) 135 | { 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 136 | 137 | { 0 INVERT 1 AND -> 1 } 138 | { 1 INVERT 1 AND -> 0 } 139 | 140 | 0 CONSTANT 0S 141 | 0 INVERT CONSTANT 1S 142 | 143 | { 0S INVERT -> 1S } 144 | { 1S INVERT -> 0S } 145 | 146 | T{ 0 INVERT 1 AND -> 1 }T 147 | T{ 1 INVERT 1 AND -> 0 }T 148 | 149 | T{ 0S 0S AND -> 0S }T 150 | T{ 0S 1S AND -> 0S }T 151 | T{ 1S 0S AND -> 0S }T 152 | T{ 1S 1S AND -> 1S }T 153 | 154 | { 0S 0S OR -> 0S } 155 | { 0S 1S OR -> 1S } 156 | { 1S 0S OR -> 1S } 157 | { 1S 1S OR -> 1S } 158 | 159 | { 0S 0S XOR -> 0S } 160 | { 0S 1S XOR -> 1S } 161 | { 1S 0S XOR -> 1S } 162 | { 1S 1S XOR -> 0S } 163 | 164 | 0S CONSTANT 165 | 1S CONSTANT 166 | 167 | 168 | : GN2 \ ( -- 16 10 ) 169 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 170 | T{ GN2 -> 16 10 }T 171 | 172 | 173 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 174 | 1S 1 RSHIFT INVERT CONSTANT MSB 175 | { MSB BITSSET? -> 0 0 } 176 | 177 | { 0S 2* -> 0S } 178 | { 1 2* -> 2 } 179 | 180 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 181 | T{ 0 1 * -> 0 }T 182 | T{ 1 0 * -> 0 }T 183 | T{ 1 2 * -> 2 }T 184 | T{ 2 1 * -> 2 }T 185 | T{ 3 3 * -> 9 }T 186 | 187 | { 4000 2* -> 8000 } 188 | { 1S 2* 1 XOR -> 1S } 189 | { MSB 2* -> 0S } 190 | 191 | { 0S 2/ -> 0S } 192 | { 1 2/ -> 0 } 193 | { 4000 2/ -> 2000 } 194 | 195 | { 1 0 LSHIFT -> 1 } 196 | { 1 1 LSHIFT -> 2 } 197 | { 1 2 LSHIFT -> 4 } 198 | { 1S 1 LSHIFT 1 XOR -> 1S } 199 | { MSB 1 LSHIFT -> 0 } 200 | 201 | { 1 0 RSHIFT -> 1 } 202 | { 1 1 RSHIFT -> 0 } 203 | { 2 1 RSHIFT -> 1 } 204 | { 4 2 RSHIFT -> 1 } 205 | { MSB 1 RSHIFT 2* -> MSB } 206 | 207 | 208 | T{ 1 2 2DROP -> }T 209 | 210 | T{ 1 2 2DUP -> 1 2 1 2 }T 211 | 212 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 213 | 214 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 215 | 216 | T{ : NOP : [POSTPONE] ; ; -> }T 217 | T{ NOP NOP1 NOP NOP2 -> }T 218 | T{ NOP1 -> }T 219 | T{ NOP2 -> }T 220 | 221 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 222 | T{ GDX -> 123 234 }T 223 | 224 | T{ 0 ?DUP -> 0 }T 225 | T{ 1 ?DUP -> 1 1 }T 226 | 227 | PAGE 228 | T{ : GR1 >R R> ; -> }T 229 | T{ : GR2 >R R@ R> DROP ; -> }T 230 | T{ 123 GR1 -> 123 }T 231 | T{ 123 GR2 -> 123 }T 232 | T{ 1S GR1 -> 1S }T ( Return stack holds cells ) 233 | 234 | \ This test fails! Maybe this is where being non-standard is better? 235 | \ T{ ( A comment)1234 -> }T 236 | T{ : pc1 ( A comment)1234 ; pc1 -> 1234 }T 237 | 238 | HERE @ 1 , 239 | HERE @ 2 , 240 | CONSTANT 2ND 241 | CONSTANT 1ST 242 | 243 | T{ 1ST 2ND < -> 1 }T \ HERE MUST GROW WITH ALLOT 244 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 245 | T{ 1ST 1 CELLS + -> 2ND }T 246 | T{ 1ST @ 2ND @ -> 1 2 }T 247 | T{ 5 1ST ! -> }T 248 | T{ 1ST @ 2ND @ -> 5 2 }T 249 | T{ 6 2ND ! -> }T 250 | T{ 1ST @ 2ND @ -> 5 6 }T 251 | T{ 1ST 2@ -> 6 5 }T 252 | T{ 2 1 1ST 2! -> }T 253 | T{ 1ST 2@ -> 2 1 }T 254 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 255 | 256 | HERE @ 1 ALLOT 257 | HERE @ 258 | CONSTANT 2NDA 259 | CONSTANT 1STA 260 | T{ 1STA 2NDA < -> 1 }T \ HERE MUST GROW WITH ALLOT 261 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 262 | 263 | 264 | HERE @ 1 C, 265 | HERE @ 2 C, 266 | CONSTANT 2NDC 267 | CONSTANT 1STC 268 | 269 | T{ 1STC 2NDC < -> 1 }T \ HERE MUST GROW WITH ALLOT 270 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 271 | T{ 1STC 1 CHARS + -> 2NDC }T 272 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 273 | T{ 3 1STC C! -> }T 274 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 275 | T{ 4 2NDC C! -> }T 276 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 277 | 278 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 279 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 280 | T{ 4 GI3 -> 4 5 }T 281 | T{ 5 GI3 -> 5 }T 282 | T{ 6 GI3 -> 6 }T 283 | 284 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 285 | T{ 3 GI4 -> 3 4 5 6 }T 286 | T{ 5 GI4 -> 5 6 }T 287 | T{ 6 GI4 -> 6 7 }T 288 | 289 | 290 | T{ VARIABLE V1 -> }T 291 | T{ 123 V1 ! -> }T 292 | T{ V1 @ -> 123 }T 293 | 294 | : GS3 WORD DROP COUNT SWAP C@ ; 295 | T{ GS3 HELLO -> 5 CHAR H }T 296 | 297 | PAGE 298 | 299 | : OUTPUT-TEST 300 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 301 | 65 BL DO I EMIT LOOP CR 302 | 97 65 DO I EMIT LOOP CR 303 | 127 97 DO I EMIT LOOP CRbr 304 | PAUSE PAGE 305 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 306 | 9 1+ 0 DO I . LOOP CR 307 | PAUSE PAGE 308 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 309 | [ CHAR 9 ] LITERAL 1+ [ CHAR 0 ] LITERAL DO I EMIT LOOP CR 310 | PAUSE PAGE 311 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 312 | [ CHAR G ] LITERAL 1+ [ CHAR A ] LITERAL DO I EMIT SPACE LOOP CR 313 | PAUSE PAGE 314 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 315 | 5 1+ 0 DO I [ CHAR 0 ] LITERAL + EMIT 2 SPACES LOOP CR 316 | PAUSE PAGE 317 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 318 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 319 | PAUSE PAGE 320 | ; 321 | 322 | T{ OUTPUT-TEST -> }T 323 | -------------------------------------------------------------------------------- /words/tests.fs: -------------------------------------------------------------------------------- 1 | { -> } \ START WITH CLEAN SLATE 2 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 3 | { : BITSSET? IF 0 0 ELSE 0 THEN ; -> } 4 | { 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) 5 | { 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 6 | 7 | { 0 INVERT 1 AND -> 1 } 8 | { 1 INVERT 1 AND -> 0 } 9 | 10 | 0 CONSTANT 0S 11 | 0 INVERT CONSTANT 1S 12 | 13 | { 0S INVERT -> 1S } 14 | { 1S INVERT -> 0S } 15 | 16 | T{ 0 INVERT 1 AND -> 1 }T 17 | T{ 1 INVERT 1 AND -> 0 }T 18 | 19 | T{ 0S 0S AND -> 0S }T 20 | T{ 0S 1S AND -> 0S }T 21 | T{ 1S 0S AND -> 0S }T 22 | T{ 1S 1S AND -> 1S }T 23 | 24 | { 0S 0S OR -> 0S } 25 | { 0S 1S OR -> 1S } 26 | { 1S 0S OR -> 1S } 27 | { 1S 1S OR -> 1S } 28 | 29 | { 0S 0S XOR -> 0S } 30 | { 0S 1S XOR -> 1S } 31 | { 1S 0S XOR -> 1S } 32 | { 1S 1S XOR -> 0S } 33 | 34 | 0S CONSTANT 35 | 1S CONSTANT 36 | 37 | 38 | : GN2 \ ( -- 16 10 ) 39 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 40 | T{ GN2 -> 16 10 }T 41 | 42 | 43 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 44 | 1S 1 RSHIFT INVERT CONSTANT MSB 45 | { MSB BITSSET? -> 0 0 } 46 | 47 | { 0S 2* -> 0S } 48 | { 1 2* -> 2 } 49 | 50 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 51 | T{ 0 1 * -> 0 }T 52 | T{ 1 0 * -> 0 }T 53 | T{ 1 2 * -> 2 }T 54 | T{ 2 1 * -> 2 }T 55 | T{ 3 3 * -> 9 }T 56 | 57 | { 4000 2* -> 8000 } 58 | { 1S 2* 1 XOR -> 1S } 59 | { MSB 2* -> 0S } 60 | 61 | { 0S 2/ -> 0S } 62 | { 1 2/ -> 0 } 63 | { 4000 2/ -> 2000 } 64 | 65 | { 1 0 LSHIFT -> 1 } 66 | { 1 1 LSHIFT -> 2 } 67 | { 1 2 LSHIFT -> 4 } 68 | { 1S 1 LSHIFT 1 XOR -> 1S } 69 | { MSB 1 LSHIFT -> 0 } 70 | 71 | { 1 0 RSHIFT -> 1 } 72 | { 1 1 RSHIFT -> 0 } 73 | { 2 1 RSHIFT -> 1 } 74 | { 4 2 RSHIFT -> 1 } 75 | { MSB 1 RSHIFT 2* -> MSB } 76 | 77 | 78 | T{ 1 2 2DROP -> }T 79 | 80 | T{ 1 2 2DUP -> 1 2 1 2 }T 81 | 82 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 83 | 84 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 85 | 86 | T{ : NOP : POSTPONE ; ; -> }T 87 | T{ NOP NOP1 NOP NOP2 -> }T 88 | T{ NOP1 -> }T 89 | T{ NOP2 -> }T 90 | 91 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 92 | T{ GDX -> 123 234 }T 93 | 94 | T{ 0 ?DUP -> 0 }T 95 | T{ 1 ?DUP -> 1 1 }T 96 | 97 | PAGE 98 | T{ : GR1 >R R> ; -> }T 99 | T{ : GR2 >R R@ R> DROP ; -> }T 100 | T{ 123 GR1 -> 123 }T 101 | T{ 123 GR2 -> 123 }T 102 | T{ 1S GR1 -> 1S }T ( Return stack holds cells ) 103 | 104 | \ This test fails! Maybe this is where being non-standard is better? 105 | \ T{ ( A comment)1234 -> }T 106 | T{ : pc1 ( A comment)1234 ; pc1 -> 1234 }T 107 | 108 | HERE @ 1 , 109 | HERE @ 2 , 110 | CONSTANT 2ND 111 | CONSTANT 1ST 112 | 113 | T{ 1ST 2ND < -> 1 }T \ HERE MUST GROW WITH ALLOT 114 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 115 | T{ 1ST 1 CELLS + -> 2ND }T 116 | T{ 1ST @ 2ND @ -> 1 2 }T 117 | T{ 5 1ST ! -> }T 118 | T{ 1ST @ 2ND @ -> 5 2 }T 119 | T{ 6 2ND ! -> }T 120 | T{ 1ST @ 2ND @ -> 5 6 }T 121 | T{ 1ST 2@ -> 6 5 }T 122 | T{ 2 1 1ST 2! -> }T 123 | T{ 1ST 2@ -> 2 1 }T 124 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 125 | 126 | HERE @ 1 ALLOT 127 | HERE @ 128 | CONSTANT 2NDA 129 | CONSTANT 1STA 130 | T{ 1STA 2NDA < -> 1 }T \ HERE MUST GROW WITH ALLOT 131 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 132 | 133 | 134 | HERE @ 1 C, 135 | HERE @ 2 C, 136 | CONSTANT 2NDC 137 | CONSTANT 1STC 138 | 139 | T{ 1STC 2NDC < -> 1 }T \ HERE MUST GROW WITH ALLOT 140 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 141 | T{ 1STC 1 CHARS + -> 2NDC }T 142 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 143 | T{ 3 1STC C! -> }T 144 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 145 | T{ 4 2NDC C! -> }T 146 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 147 | 148 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 149 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 150 | T{ 4 GI3 -> 4 5 }T 151 | T{ 5 GI3 -> 5 }T 152 | T{ 6 GI3 -> 6 }T 153 | 154 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 155 | T{ 3 GI4 -> 3 4 5 6 }T 156 | T{ 5 GI4 -> 5 6 }T 157 | T{ 6 GI4 -> 6 7 }T 158 | 159 | 160 | T{ VARIABLE V1 -> }T 161 | T{ 123 V1 ! -> }T 162 | T{ V1 @ -> 123 }T 163 | 164 | : GS3 WORD DROP COUNT SWAP C@ ; 165 | T{ GS3 HELLO -> 5 CHAR H }T 166 | 167 | PAGE 168 | 169 | : OUTPUT-TEST 170 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 171 | 65 BL DO I EMIT LOOP CR 172 | 97 65 DO I EMIT LOOP CR 173 | 127 97 DO I EMIT LOOP CRbr 174 | PAUSE PAGE 175 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 176 | 9 1+ 0 DO I . LOOP CR 177 | PAUSE PAGE 178 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 179 | [ CHAR 9 ] LITERAL 1+ [ CHAR 0 ] LITERAL DO I EMIT LOOP CR 180 | PAUSE PAGE 181 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 182 | [ CHAR G ] LITERAL 1+ [ CHAR A ] LITERAL DO I EMIT SPACE LOOP CR 183 | PAUSE PAGE 184 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 185 | 5 1+ 0 DO I [ CHAR 0 ] LITERAL + EMIT 2 SPACES LOOP CR 186 | PAUSE PAGE 187 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 188 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 189 | PAUSE PAGE 190 | ; 191 | 192 | T{ OUTPUT-TEST -> }T 193 | -------------------------------------------------------------------------------- /z80data.tab: -------------------------------------------------------------------------------- 1 | # z80 Instruction Table 2 | 3 | #### INSTRUCTION 4 | # INS [MNOMIC] [VALUE] 5 | # MNOMIC is any series of case-insenstive characters with support for special 6 | # characters to define additional functionality. MNOMIC may not have whitespace. 7 | # Special Characters: 8 | # '_': Required whitespace 9 | # '-': Optional whitespace 10 | # '%#': Immediate value (# is a character to use to identify later) 11 | # '^#': Immediate value relative to PC (# is a character to use to identify later) 12 | # '@#': Operand (# is a character to use to identify later) 13 | # '&': Special - RST value 14 | # 15 | # VALUE is a value in binary, which may include references to immediate values and operands 16 | # in use above. For example, in the MNOMIC 'hello,-world_%A<16>_@B', the value could be 17 | # '01011 %A 10110 @B' 18 | # 19 | #### OPERAND GROUP 20 | # OPERAND [GROUP NAME] [OPERAND NAME] [VALUE] 21 | # GROUP NAME is the name of the operand group this belongs to. This is used to reference the 22 | # group in a MNOMIC with the @ operator. OPERAND NAME is the name to match, such as A, B, IX, 23 | # etc. VALUE is the value in binary of this operand. 24 | 25 | # Z80 INSTRUCTION SET 26 | 27 | #### Z80 PROPERTIES 28 | ARCH z80 29 | 30 | #### OPERAND GROUPS 31 | # GROUP 1 32 | OPERAND g1 NZ 00 33 | OPERAND g1 Z 01 34 | OPERAND g1 NC 10 35 | OPERAND g1 C 11 36 | 37 | # GROUP 2 38 | OPERAND g2 NZ 000 39 | OPERAND g2 Z 001 40 | OPERAND g2 NC 010 41 | OPERAND g2 C 011 42 | OPERAND g2 PO 100 43 | OPERAND g2 PE 101 44 | OPERAND g2 P 110 45 | OPERAND g2 M 111 46 | 47 | # GROUP 3 48 | OPERAND g3 A 111 49 | OPERAND g3 B 000 50 | OPERAND g3 C 001 51 | OPERAND g3 D 010 52 | OPERAND g3 E 011 53 | OPERAND g3 H 100 54 | OPERAND g3 L 101 55 | OPERAND g3 (HL) 110 56 | 57 | # GROUP 4 58 | OPERAND g4 BC 0 59 | OPERAND g4 DE 1 60 | 61 | # GROUP 5 62 | OPERAND g5 I 0 63 | OPERAND g5 R 1 64 | 65 | # GROUP 6 66 | OPERAND g6 BC 00 67 | OPERAND g6 DE 01 68 | OPERAND g6 HL 10 69 | OPERAND g6 SP 11 70 | 71 | # GROUP 7 72 | OPERAND g7 BC 00 73 | OPERAND g7 DE 01 74 | OPERAND g7 HL 10 75 | OPERAND g7 AF 11 76 | 77 | # GROUP 8 78 | OPERAND g8 IX 11011101 79 | OPERAND g8 IY 11111101 80 | 81 | # GROUP 9 82 | OPERAND g9 BC 00 83 | OPERAND g9 DE 01 84 | OPERAND g9 IX 10 85 | OPERAND g9 SP 11 86 | 87 | # GROUP 10 88 | OPERAND g10 BC 00 89 | OPERAND g10 DE 01 90 | OPERAND g10 IY 10 91 | OPERAND g10 SP 11 92 | 93 | # Most instructions were just lifted from Learn TI-83+ Assembly in 28 Days, they've got 94 | # pretty nice instruction set documentation. 95 | #### INSTRUCTIONS 96 | 97 | # Undocumented IX/IY(H,L) instructions come first for parsing reasons 98 | 99 | # IXH 100 | INS ADD_A-,-IXH 11011101 10000100 101 | INS ADD_IXH 11011101 10000100 102 | 103 | INS AND_IXH 11011101 10100100 104 | INS AND_A-,-IXH 11011101 10100100 105 | 106 | INS CP_IXH 11011101 10111100 107 | INS A-,-CP_IXH 11011101 10111100 108 | 109 | INS DEC_IXH 11011101 00100101 110 | 111 | INS INC_IXH 11011101 00100100 112 | 113 | INS LD_@A-,-IXH 11011101 01@A100 114 | INS LD_IXH-,-@A 11011101 01100@A 115 | INS LD_IXH-,-%A<8> 11011101 00100110 %A 116 | 117 | INS OR_IXH 11011101 10110100 118 | INS OR_A-,-IXH 11011101 10110100 119 | 120 | INS SBC_A-,-IXH 11011101 10011100 121 | INS SBC_IXH 11011101 10011100 122 | 123 | INS SUB_IXH 11011101 10010100 124 | INS SUB_A-,-IXH 11011101 10010100 125 | 126 | INS XOR_IXH 11011101 10101100 127 | INS XOR_A-,-IXH 11011101 10101100 128 | 129 | # IXL 130 | INS ADD_A-,-IXL 11011101 10000101 131 | INS ADD_IXL 11011101 10000101 132 | 133 | INS AND_IXL 11011101 10100101 134 | INS AND_A-,-IXL 11011101 10100101 135 | 136 | INS CP_IXL 11011101 10111101 137 | INS A-,-CP_IXL 11011101 10111101 138 | 139 | INS DEC_IXL 11011101 00101101 140 | 141 | INS INC_IXL 11011101 00101100 142 | 143 | INS LD_@A-,-IXL 11011101 01@A101 144 | INS LD_IXL-,-@A 11011101 01101@A 145 | INS LD_IXL-,-%A<8> 11011101 00101110 %A 146 | 147 | INS OR_IXL 11011101 10110101 148 | INS OR_A-,-IXL 11011101 10110101 149 | 150 | INS SBC_A-,-IXL 11011101 10011101 151 | INS SBC_IXL 11011101 10011101 152 | 153 | INS SUB_IXL 11011101 10010101 154 | INS SUB_A-,-IXL 11011101 10010101 155 | 156 | INS XOR_IXL 11011101 10101101 157 | INS XOR_A-,-IXL 11011101 10101101 158 | 159 | # IYH 160 | INS ADD_A-,-IYH 11111101 10000100 161 | INS ADD_IYH 11111101 10000100 162 | 163 | INS AND_IYH 11111101 10100100 164 | INS AND_A-,-IYH 11111101 10100100 165 | 166 | INS CP_IYH 11111101 10111100 167 | INS A-,-CP_IYH 11111101 10111100 168 | 169 | INS DEC_IYH 11111101 00100101 170 | 171 | INS INC_IYH 11111101 00100100 172 | 173 | INS LD_@A-,-IYH 11111101 01@A100 174 | INS LD_IYH-,-@A 11111101 01100@A 175 | INS LD_IYH-,-%A<8> 11111101 00100110 %A 176 | 177 | INS OR_IYH 11111101 10110100 178 | INS OR_A-,-IYH 11111101 10110100 179 | 180 | INS SBC_A-,-IYH 11111101 10011100 181 | INS SBC_IYH 11111101 10011100 182 | 183 | INS SUB_IYH 11111101 10010100 184 | INS SUB_A-,-IYH 11111101 10010100 185 | 186 | INS XOR_IYH 11111101 10101100 187 | INS XOR_A-,-IYH 11111101 10101100 188 | 189 | # IYL 190 | INS ADD_A-,-IYL 11111101 10000101 191 | INS ADD_IYL 11111101 10000101 192 | 193 | INS AND_IYL 11111101 10100101 194 | INS AND_A-,-IYL 11111101 10100101 195 | 196 | INS CP_IYL 11111101 10111101 197 | INS A-,-CP_IYL 11111101 10111101 198 | 199 | INS DEC_IYL 11111101 00101101 200 | 201 | INS INC_IYL 11111101 00101100 202 | 203 | INS LD_@A-,-IYL 11111101 01@A101 204 | INS LD_IYL-,-@A 11111101 01101@A 205 | INS LD_IYL-,-%A<8> 11111101 00101110 %A 206 | 207 | INS OR_IYL 11111101 10110101 208 | INS OR_A-,-IYL 11111101 10110101 209 | 210 | INS SBC_A-,-IYL 11111101 10011101 211 | INS SBC_IYL 11111101 10011101 212 | 213 | INS SUB_IYL 11111101 10010101 214 | INS SUB_A-,-IYL 11111101 10010101 215 | 216 | INS XOR_IYL 11111101 10101101 217 | INS XOR_A-,-IYL 11111101 10101101 218 | 219 | #### DATA MOVEMENT 220 | 221 | INS EX_DE-,-HL 11101011 222 | INS EX_HL-,-DE 11101011 223 | INS EX_AF-,-AF' 00001000 224 | INS EX_AF'-,-AF 00001000 225 | INS EX_(-SP-)-,-HL 11100011 226 | INS EX_HL-,-(-SP-) 11100011 227 | INS EX_(-SP-)-,-@A @A 11100011 228 | INS EX_@A-,-(-SP-) @A 11100011 229 | 230 | INS EXX 11011001 231 | 232 | INS LD_HL-,-(-%A<16>-) 00101010 %A 233 | 234 | INS LD_@A-,-@B 01@A@B 235 | 236 | INS LD_@A-,-(-@B-%C<8>-) @B 01@A110 %C 237 | INS LD_@A-,-(-%C<8>-+-@B-) @B 01@A110 %C 238 | INS LD_@A-,-(-@B-) @B 01@A110 00000000 239 | INS LD_(-@A-%B<8>-)-,-@C @A 01110@C %B 240 | INS LD_(-%B<8>-+-@A-)-,-@C @A 01110@C %B 241 | INS LD_(-@A-)-,-@C @A 01110@C 00000000 242 | 243 | INS LD_A-,-(-@A-) 000@A1010 244 | INS LD_A-,-(-%A<16>-) 00111010 %A 245 | INS LD_(-@A-)-,-A 000@A0010 246 | INS LD_(-%A<16>-)-,-A 00110010 %A 247 | INS LD_A-,-@A 11101101 0101@A111 248 | INS LD_@A-,-A 11101101 0100@A111 249 | 250 | INS LD_@A-,-%B<8> 00@A110 %B 251 | 252 | INS LD_(@A-%B<8>-)-,-%C<8> @A 00110110 %B %C 253 | INS LD_(-@A-+-%B<8>-)-,-%C<8> @A 00110110 %B %C 254 | INS LD_(-%B<8>-+-@A-)-,-%C<8> @A 00110110 %B %C 255 | INS LD_(-@A-)-,-%B<8> @A 00110110 00000000 %B 256 | 257 | INS LD_(-@A-%B<8>-)-,-%C<8> @A 00110110 %B %C 258 | INS LD_(-%B<8>-+-@A-)-,-%C<8> @A 00110110 %B %C 259 | INS LD_(-@A-)-,-%B<8> @A 00110110 00000000 %B 260 | 261 | INS LD_SP-,-HL 11111001 262 | INS LD_SP-,-@A @A 11111001 263 | 264 | INS LD_@A-,-(-%B<16>-) 11101101 01@A1011 %B 265 | INS LD_@A-,-(-%B<16>-) @A 00101010 %B 266 | INS LD_@A-,-%B<16> 00@A0001 %B 267 | INS LD_@A-,-%B<16> @A 00100001 %B 268 | INS LD_(-%A<16>-)-,-HL 00100010 %A 269 | INS LD_(-%A<16>-)-,-@B 11101101 01@B0011 %A 270 | INS LD_(-%A<16>-)-,-@B @B 00100010 %A 271 | INS LD_SP-,-HL 11111001 272 | INS LD_SP-,-@A @A 11111001 273 | 274 | INS LDD 11101101 10101000 275 | 276 | INS LDDR 11101101 10111000 277 | 278 | INS LDI 11101101 10100000 279 | 280 | INS LDIR 11101101 10110000 281 | 282 | INS POP_@A 11@A0001 283 | INS POP_@A @A 11100001 284 | 285 | INS PUSH_@A 11@A0101 286 | INS PUSH_@A @A 11100101 287 | 288 | #### ARITHMETIC 289 | 290 | INS ADC_A-,-@A 10001@A 291 | INS ADC_@A-,-A 10001@A 292 | INS ADC_@A 10001@A 293 | INS ADC_A-,-(-@A-%B<8>-) @A 10001110 %B 294 | INS ADC_A-,-(-%B<8>-+-@A-) @A 10001110 %B 295 | INS ADC_A-,-(-@A-) @A 10001110 00000000 296 | INS ADC_HL-,-@A 11101101 01@A1010 297 | INS ADC_A-,-%A<8> 11001110 %A 298 | INS ADC_%A<8> 11001110 %A 299 | 300 | INS ADD_A-,-@A 10000@A 301 | INS ADD_-@A-,-A 10000@A 302 | INS ADD_@A 10000@A 303 | INS ADD_A-,-(-@A-%B<8>-) @A 10000110 %B 304 | INS ADD_A-,-(-%B<8>-+-@A-) @A 10000110 %B 305 | INS ADD_A-,-(-@A-) @A 10000110 00000000 306 | INS ADD_-(-@A-+-%B<8>-) @A 10000110 %B 307 | INS ADD_-(-%B<8>-+-@A-) @A 10000110 %B 308 | INS ADD_-(-@A-) @A 10000110 00000000 309 | INS ADD_A-,-%A<8> 11000110 %A 310 | INS ADD_HL-,-@A 00@A1001 311 | INS ADD_IX-,-@A 11011101 00@A1001 312 | INS ADD_IY-,-@A 11111101 00@A1001 313 | 314 | INS CP_@A 10111@A 315 | INS CP_A-,-@A 10111@A 316 | INS CP_(-@A-%B<8>-) @A 10111110 %B 317 | INS CP_(-%B<8>-+-@A-) @A 10111110 %B 318 | INS CP_A-,-(-%B<8>-+-@A-) @A 10111110 %B 319 | INS CP_A-,-(-@A-+-%B<8>-) @A 10111110 %B 320 | INS CP_A-,-(-@A-) @A 10111110 00000000 321 | INS CP_(-@A-) @A 10111110 00000000 322 | INS CP_A-,-%A<8> 11111110 %A 323 | INS CP_%A<8> 11111110 %A 324 | 325 | INS CPD 11101101 10101001 326 | 327 | INS CPDR 11101101 10111001 328 | 329 | INS CPI 11101101 10100001 330 | 331 | INS CPIR 11101101 10110001 332 | 333 | INS CPL 00101111 334 | 335 | INS DAA 00100111 336 | 337 | INS DEC_@A 00@A101 338 | INS DEC_(-@A-%B<8>-) @A 00110101 %B 339 | INS DEC_(-%B<8>-+-@A-) @A 00110101 %B 340 | INS DEC_(-@A-) @A 00110101 00000000 341 | INS DEC_@A 00@A1011 342 | INS DEC_@A @A 00101011 343 | 344 | INS INC_@A 00@A100 345 | INS INC_(-@A-%B<8>-) @A 00110100 %B 346 | INS INC_(-%B<8>-+-@A-) @A 00110100 %B 347 | INS INC_(-@A-) @A 00110100 00000000 348 | INS INC_@A 00@A0011 349 | INS INC_@A @A 00100011 350 | 351 | INS NEG 11101101 01000100 352 | 353 | INS SBC_HL-,-@A 11101101 01@A0010 354 | INS SBC_A-,-@A 10011@A 355 | INS SBC_@A 10011@A 356 | INS SBC_A-,-(-@A-%B<8>-) @A 10011110 %B 357 | INS SBC_A-,-(-%B<8>-+-@A-) @A 10011110 %B 358 | INS SBC_A-,-(-@A-) @A 10011110 00000000 359 | INS SBC_A-,-%A<8> 11011110 %A 360 | INS SBC_%A<8> 11011110 %A 361 | 362 | INS SUB_A-,-@A 10010@A 363 | INS SUB_@A 10010@A 364 | INS SUB_A-,-(-@A-%B<8>-) @A 10010110 %B 365 | INS SUB_A-,-(-%B<8>-+-@A-) @A 10010110 %B 366 | INS SUB_A-,-(-@A-) @A 10010110 00000000 367 | INS SUB_(-@A-%B<8>-) @A 10010110 %B 368 | INS SUB_(-%B<8>-+-@A-) @A 10010110 %B 369 | INS SUB_(-@A-) @A 10010110 00000000 370 | INS SUB_A-,-%A<8> 11010110 %A 371 | INS SUB_%A<8> 11010110 %A 372 | 373 | #### BIT MANIPULATION 374 | 375 | INS AND_@A 10100@A 376 | INS AND_A-,-@A 10100@A 377 | INS AND_(-@A-%B<8>-) @A 10100110 %B 378 | INS AND_(-%B<8>-+-@A-) @A 10100110 %B 379 | INS AND_(-@A-) @A 10100110 00000000 00000000 380 | INS AND_A-,-(-@A-%B<8>-) @A 10100110 %B 381 | INS AND_A-,-(-%B<8>-+-@A-) @A 10100110 %B 382 | INS AND_A-,-%A<8> 11100110 %A 383 | INS AND_%A<8> 11100110 %A 384 | 385 | INS BIT_%A<3>-,-@B 11001011 01%A@B 386 | INS BIT_%A<3>-,-(-@B-%C<8>-) @B 11001011 %C 01%A110 387 | INS BIT_%A<3>-,-(-%C<8>-+-@B-) @B 11001011 %C 01%A110 388 | INS BIT_%A<3>-,-(-@B-) @B 11001011 00000000 01%A110 389 | 390 | INS CCF 00111111 391 | 392 | INS OR_@A 10110@A 393 | INS OR_A-,-@A 10110@A 394 | INS OR_(-@A-%B<8>-) @A 10110110 %B 395 | INS OR_(-%B<8>-+-@A-) @A 10110110 %B 396 | INS OR_(-@A-) @A 10110110 00000000 397 | INS OR_A-,-(-@A-%B<8>-) @A 10110110 %B 398 | INS OR_A-,-(-%B<8>-+-@A-) @A 10110110 %B 399 | INS OR_A-,-(-@A-) @A 10110110 00000000 400 | INS OR_A-,-%A<8> 11110110 %A 401 | INS OR_%A<8> 11110110 %A 402 | 403 | INS RES_%A<3>-,-@B 11001011 10%A@B 404 | INS RES_%A<3>-,-(-@B-%C<8>-) @B 11001011 %C 10%A110 405 | INS RES_%A<3>-,-(-%C<8>-+-@B-) @B 11001011 %C 10%A110 406 | INS RES_%A<3>-,-(-@B-) @B 11001011 00000000 10%A110 407 | 408 | INS SCF 00110111 409 | 410 | INS SET_%A<3>-,-@B 11001011 11%A@B 411 | INS SET_%A<3>-,-(-@B-%C<8>-) @B 11001011 %C 11%A110 412 | INS SET_%A<3>-,-(-%C<8>-+-@B-) @B 11001011 %C 11%A110 413 | INS SET_%A<3>-,-(-@B-) @B 11001011 00000000 11%A110 414 | 415 | INS XOR_@A 10101@A 416 | INS XOR_A-,-@A 10101@A 417 | INS XOR_(-@A-%B<8>-) @A 10101110 %B 418 | INS XOR_(-%B<8>-+-@A-) @A 10101110 %B 419 | INS XOR_(-@A-) @A 10101110 00000000 420 | INS XOR_A-,-(-@A-%B<8>-) @A 10101110 %B 421 | INS XOR_A-,-(-%B<8>-+-@A-) @A 10101110 %B 422 | INS XOR_A-,-(-@A-) @A 10101110 00000000 423 | INS XOR_A-,-%A<8> 11101110 %A 424 | INS XOR_%A<8> 11101110 %A 425 | 426 | #### SHIFT/ROTATE 427 | 428 | INS RL_@A 11001011 00010@A 429 | INS RL_(-@A-%B<8>-) @A 11001011 %B 00010110 430 | INS RL_(-%B<8>-+-@A-) @A 11001011 %B 00010110 431 | INS RL_(-@A-) @A 11001011 00000000 00010110 432 | 433 | INS RLA 00010111 434 | 435 | INS RLC_@A 11001011 00000@A 436 | INS RLC_(-@A-%B<8>-) @A 11001011 %B 00000110 437 | INS RLC_(-%B<8>-+-@A-) @A 11001011 %B 00000110 438 | INS RLC_(-@A-) @A 11001011 00000000 00000110 439 | 440 | INS RLCA 00000111 441 | 442 | INS RLD 11101101 01101111 443 | 444 | INS RR_@A 11001011 00011@A 445 | 446 | INS RR_(-@A-%B<8>-) @A 11001011 %B 00011110 447 | INS RR_(-%B<8>-+-@A-) @A 11001011 %B 00011110 448 | INS RR_(-@A-) @A 11001011 00000000 00011110 449 | 450 | INS RRA 00011111 451 | 452 | INS RRC_@A 11001011 00001@A 453 | INS RRC_(-@A-%B<8>-) @A 11001011 %B 00001110 454 | INS RRC_(-%B<8>-+-@A-) @A 11001011 %B 00001110 455 | INS RRC_(-@A-) @A 11001011 00000000 00001110 456 | 457 | INS RRCA 00001111 458 | 459 | INS RRD 11101101 01100111 460 | 461 | INS SLA_@A 11001011 00100@A 462 | INS SLA_(-@A-%B<8>-) @A 11001011 %B 00100110 463 | INS SLA_(-%B<8>-+-@A-) @A 11001011 %B 00100110 464 | INS SLA_(-@A-) @A 11001011 00000000 00100110 465 | 466 | INS SRA_@A 11001011 00101@A 467 | INS SRA_(-@A-%B<8>-) @A 11001011 %B 00101110 468 | INS SRA_(-%B<8>-+-@A-) @A 11001011 %B 00101110 469 | INS SRA_(-@A-) @A 11001011 00000000 00101110 470 | 471 | INS SRL_@A 11001011 00111@A 472 | INS SRL_(-@A-%B<8>-) @A 11001011 %B 00111110 473 | INS SRL_(-%B<8>-+-@A-) @A 11001011 %B 00111110 474 | INS SRL_(-@A-) @A 11001011 00000000 00111110 475 | 476 | #### CONTROL 477 | 478 | INS CALL_@A-,-%B<16> 11@A100 %B 479 | INS CALL_%A<16> 11001101 %A 480 | 481 | INS DJNZ_^A<8> 00010000 ^A 482 | 483 | INS JP_(-HL-) 11101001 484 | INS JP_HL 11101001 485 | INS JP_(-@A-) @A 11101001 486 | 487 | INS JP_@A-,-%B<16> 11@A010 %B 488 | INS JP_%A<16> 11000011 %A 489 | 490 | INS JR_@A-,-^B<8> 001@A000 ^B 491 | INS JR_^A<8> 00011000 ^A 492 | 493 | INS NOP 00000000 494 | 495 | INS RET 11001001 496 | INS RET_@A 11@A000 497 | 498 | INS RETI 11101101 01001101 499 | 500 | INS RETN 11101101 01000101 501 | 502 | INS RST_&A 11&A111 503 | 504 | #### HARDWARE 505 | 506 | INS DI 11110011 507 | 508 | INS EI 11111011 509 | 510 | INS HALT 01110110 511 | 512 | INS IM_0 11101101 01000110 513 | INS IM_1 11101101 01010110 514 | INS IM_2 11101101 01011110 515 | 516 | INS IN_@A-,-(-C-) 11101101 01@A000 517 | INS IN_A-,-(-%A<8>-) 11011011 %A 518 | 519 | INS IND 11101101 10101010 520 | 521 | INS INDR 11101101 10111010 522 | 523 | INS INI 11101101 10100010 524 | 525 | INS INIR 11101101 10110010 526 | 527 | INS OTDR 11101101 10111011 528 | 529 | INS OTIR 11101101 10110011 530 | 531 | INS OUT_(-C-)-,-@A 11101101 01@A001 532 | INS OUT_(-%A<8>-)-,-A 11010011 %A 533 | 534 | INS OUTD 11101101 10101011 535 | 536 | INS OUTI 11101101 10100011 537 | 538 | # HARDWARE 539 | INS IN_(-C-) 11101101 01110000 540 | INS IN_F-,-(-C-) 11101101 01110000 541 | INS OUT_(-C-)-,-0 11101101 01110001 542 | --------------------------------------------------------------------------------