├── .editorconfig ├── .gitattributes ├── .github └── workflows │ └── build.yml ├── .gitignore ├── .lvimrc ├── CHANGELOG.md ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE.txt ├── Makefile ├── README.md ├── RELEASING.md ├── asm ├── cart.asm ├── compiler.asm ├── control.asm ├── core.asm ├── disk.asm ├── durexforth.asm ├── exception.asm ├── format.asm ├── header.py ├── interpreter.asm ├── io.asm ├── lowercase.asm ├── math.asm └── move.asm ├── forth ├── .gitignore ├── accept.fs ├── asm.fs ├── base.fs ├── compat.fs ├── debug.fs ├── demo │ └── charrom.fs ├── doloop.fs ├── dos.fs ├── float.fs ├── fractals.fs ├── generators │ └── sintab.py ├── gfx.fs ├── gfxdemo.fs ├── iec.fs ├── io.fs ├── labels.fs ├── ls.fs ├── mml.fs ├── mmldemo.fs ├── open.fs ├── require.fs ├── rnd.fs ├── see.fs ├── sid.fs ├── sin.fs ├── sprite.fs ├── spritedemo.fs ├── sys.fs ├── timer.fs ├── turnkey.fs ├── turtle.fs ├── v.fs ├── viceutil.fs └── wordlist.fs ├── manual ├── .lvimrc ├── Makefile ├── anatomy.adoc ├── asm.adoc ├── config.adoc ├── cover │ ├── durexForth-Vintage1.jpg │ └── durexForth_omslag-1.0.pdf ├── editor.adoc ├── exceptions.adoc ├── gfx.adoc ├── index.adoc ├── intro.adoc ├── links.adoc ├── memmap.adoc ├── mml.adoc ├── mnemonics.adoc ├── sid.adoc ├── stack.adoc ├── tutorial.adoc └── words.adoc └── test ├── 1.fs ├── test.fs ├── testcore.fs ├── testcoreext.fs ├── testcoreplus.fs ├── tester.fs ├── testexception.fs └── testsee.fs /.editorconfig: -------------------------------------------------------------------------------- 1 | root=true 2 | 3 | [*] 4 | insert_final_newline = true 5 | trim_trailing_whitespace = true 6 | 7 | [*.asm] 8 | indent_style = space 9 | indent_size = 4 10 | 11 | [*.fs] 12 | indent_style = space 13 | indent_size = 2 14 | 15 | [Makefile] 16 | indent_style = tab 17 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set the default behavior, in case people don't have core.autocrlf set. 2 | * text=auto 3 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | 12 | # libflac8 (required by VICE) does not exist on 24.04. 13 | # change back to ubuntu-latest once this is resolved. 14 | runs-on: ubuntu-22.04 15 | 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - name: Install dependencies 20 | run: | 21 | wget https://github.com/VICE-Team/svn-mirror/releases/download/3.8.0/headlessvice_3.8.deb 22 | sudo apt-get install libportaudio2 23 | sudo apt-get install ./headlessvice_3.8.deb 24 | sudo apt-get install acme 25 | sudo apt-get install ruby-asciidoctor-pdf 26 | 27 | - name: make deploy 28 | run: make deploy 29 | 30 | - name: Archive screenshots on failure 31 | uses: actions/upload-artifact@v3 32 | if: failure() 33 | with: 34 | name: screenshots 35 | path: build/*.png 36 | 37 | - name: Archive durexForth 38 | uses: actions/upload-artifact@v3 39 | with: 40 | name: durexForth 41 | path: deploy 42 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.d64 2 | *.prg 3 | build 4 | deploy 5 | -------------------------------------------------------------------------------- /.lvimrc: -------------------------------------------------------------------------------- 1 | map :wall!:make all 2 | map :!x64sc.exe durexforth.d64 & 3 | 4 | set nomodeline 5 | 6 | " acme 7 | set errorformat+=Error\ -\ File\ %f\\,\ line\ %l\ %m 8 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, religion, or sexual identity 10 | and orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the 26 | overall community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or 31 | advances of any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email 35 | address, without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards of 42 | acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies when 54 | an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail address, 56 | posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at 63 | "info at littlesounddj dot com". 64 | All complaints will be reviewed and investigated promptly and fairly. 65 | 66 | All community leaders are obligated to respect the privacy and security of the 67 | reporter of any incident. 68 | 69 | ## Enforcement Guidelines 70 | 71 | Community leaders will follow these Community Impact Guidelines in determining 72 | the consequences for any action they deem in violation of this Code of Conduct: 73 | 74 | ### 1. Correction 75 | 76 | **Community Impact**: Use of inappropriate language or other behavior deemed 77 | unprofessional or unwelcome in the community. 78 | 79 | **Consequence**: A private, written warning from community leaders, providing 80 | clarity around the nature of the violation and an explanation of why the 81 | behavior was inappropriate. A public apology may be requested. 82 | 83 | ### 2. Warning 84 | 85 | **Community Impact**: A violation through a single incident or series 86 | of actions. 87 | 88 | **Consequence**: A warning with consequences for continued behavior. No 89 | interaction with the people involved, including unsolicited interaction with 90 | those enforcing the Code of Conduct, for a specified period of time. This 91 | includes avoiding interactions in community spaces as well as external channels 92 | like social media. Violating these terms may lead to a temporary or 93 | permanent ban. 94 | 95 | ### 3. Temporary Ban 96 | 97 | **Community Impact**: A serious violation of community standards, including 98 | sustained inappropriate behavior. 99 | 100 | **Consequence**: A temporary ban from any sort of interaction or public 101 | communication with the community for a specified period of time. No public or 102 | private interaction with the people involved, including unsolicited interaction 103 | with those enforcing the Code of Conduct, is allowed during this period. 104 | Violating these terms may lead to a permanent ban. 105 | 106 | ### 4. Permanent Ban 107 | 108 | **Community Impact**: Demonstrating a pattern of violation of community 109 | standards, including sustained inappropriate behavior, harassment of an 110 | individual, or aggression toward or disparagement of classes of individuals. 111 | 112 | **Consequence**: A permanent ban from any sort of public interaction within 113 | the community. 114 | 115 | ## Attribution 116 | 117 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 118 | version 2.0, available at 119 | https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. 120 | 121 | Community Impact Guidelines were inspired by [Mozilla's code of conduct 122 | enforcement ladder](https://github.com/mozilla/diversity). 123 | 124 | [homepage]: https://www.contributor-covenant.org 125 | 126 | For answers to common questions about this code of conduct, see the FAQ at 127 | https://www.contributor-covenant.org/faq. Translations are available at 128 | https://www.contributor-covenant.org/translations. 129 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Thanks! 2 | 3 | Thank you for considering a contribution to durexForth! 4 | 5 | ## Submitting an Issue 6 | 7 | Found a problem? Have a great idea? Check the Issue database! 8 | 9 | If you don't see your problem or idea listed there, it might 10 | be time to open a new issue. To do so, we have some guidelines: 11 | 12 | * Check for duplicate issues first, including closed issues 13 | * Give your issue a descriptive title 14 | * Put details about bug or idea in the body 15 | * Include relevant details, such as the version number 16 | 17 | 18 | ## Contributing Code 19 | 20 | ### Adding or modifying source code 21 | 22 | We welcome new features and bug fixes! To keep things sane, we suggest: 23 | 24 | * Use a text editor that supports EditorConfig to keep source tidy 25 | * Follow the conventions and idioms of the surrounding code 26 | - Indentation, letter case, etc. 27 | * Include stack effect comments on new words 28 | * Include comments documenting complex or non-self-descriptive code 29 | 30 | ### Building durexForth 31 | 32 | Building Durexforth requires the following software: 33 | 34 | * acme - the cross-assembler (v0.97 or greater) 35 | * vice - the c64 emulator 36 | * c1541 - comes with Vice 37 | * make - the build system 38 | * asciidoctor and asciidoctor-pdf - text publishing 39 | 40 | Obtaining and installing above software is beyond the scope of this document. 41 | 42 | Build the durexForth disk and cartridge by executing: 43 | ``` 44 | # make clean && make deploy 45 | ``` 46 | The base system and documentation is produced, after which the Forth code is compiled in Vice. 47 | Once completed, a new Vice instance will execute the test suite. 48 | You may want to disable warp mode to hear the music test. 49 | After the tests, the cartridge image is built. 50 | If the program is too large, the cartridge conversion will fail. 51 | 52 | Once make completes, the generated files can be found in the `deploy/` directory. 53 | You can test the cartridge image with e.g. 54 | ``` 55 | # x64sc deploy/durexforth-3.0.0-M.crt 56 | ``` 57 | 58 | ### Submitting a Pull Request 59 | 60 | When submitting changes to durexForth, you should: 61 | 62 | * `make deploy` to run the test suite. If existing tests do not cover your changes, consider adding new ones. 63 | * If the change is significant to end users, describe it in `CHANGELOG.md` 64 | * Give the pull request a descriptive name 65 | - e.g.: "Changed FOO to BAR" 66 | - not e.g.: "Updated file.ext" 67 | * Elaborate on your change in the body of the pull request 68 | * Include links to related issues 69 | 70 | The text in the body of the pull request should explain what problem the patch 71 | solves, or what new functionality it affords. Give as much detail as required. 72 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | ---- 2 | durexForth 3 | Copyright (c) 2008 Johan Kotlinski, Mats Andrén 4 | Copyright (c) 2012 Kevin Lee Reno 5 | Copyright (c) 2017 Corey Minter 6 | Copyright (c) 2020 Poindexter Frink, Richard Halkyard 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | ---- 26 | 27 | ---- 28 | / MOD */MOD */ ?NEGATE ?DNEGATE DABS SM/REM 29 | Forth Interest Group UK. Public domain. 30 | ---- 31 | 32 | ---- 33 | UM/MOD 34 | Copyright (c) 2002 Garth Wilson. Public domain. 35 | ---- 36 | 37 | ---- 38 | MOVE 39 | Based on cc65 memmove.s 40 | 41 | This software is provided 'as-is', without any express or implied warranty. 42 | In no event will the authors be held liable for any damages arising from 43 | the use of this software. 44 | 45 | Permission is granted to anyone to use this software for any purpose, 46 | including commercial applications, and to alter it and redistribute it 47 | freely, subject to the following restrictions: 48 | 49 | 1. The origin of this software must not be misrepresented; you must not 50 | claim that you wrote the original software. If you use this software in 51 | a product, an acknowledgment in the product documentation would be 52 | appreciated but is not required. 53 | 54 | 2. Altered source versions must be plainly marked as such, and must not 55 | be misrepresented as being the original software. 56 | 57 | 3. This notice may not be removed or altered from any source distribution. 58 | ---- 59 | 60 | ---- 61 | Forth Test Suite 62 | 63 | (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 64 | MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 65 | VERSION 1.2 66 | 67 | This program was written by Gerry Jackson in 2007, with contributions from 68 | others where indicated, and is in the public domain - it can be distributed 69 | and/or modified in any way but please retain this notice. 70 | 71 | This program is distributed in the hope that it will be useful, 72 | but WITHOUT ANY WARRANTY; without even the implied warranty of 73 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 74 | ---- 75 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | C1541 = c1541 2 | AS = acme 3 | # deploy 1571 (d71) or 1581 (d81); e.g. make DISK_SUF=d81 deploy 4 | DISK_SUF = d64 5 | 6 | TAG := $(shell git describe --tags --abbrev=0 || svnversion --no-newline) 7 | TAG_DEPLOY_DOT := $(shell git describe --tags --long --dirty=_m | sed 's/-g[0-9a-f]\+//' | tr _- -.) 8 | TAG_DEPLOY := $(shell git describe --tags --abbrev=0 --dirty=_M | tr _. -_) 9 | VERSION_STRING := $(shell git describe --tags --abbrev=0) 10 | GIT_HASH := $(shell git rev-parse --short HEAD) 11 | 12 | DEPLOY_NAME = durexforth-$(TAG_DEPLOY) 13 | DISK_IMAGE = durexforth.$(DISK_SUF) 14 | 15 | X64_DEPLOY_OPTS = -warp -debugcart -limitcycles 2000000000 16 | X64 = x64sc 17 | PETCAT = petcat # text conversion utility, included in VICE package 18 | 19 | SRC_DIR = forth 20 | SRC_NAMES = base debug v asm gfx gfxdemo rnd sin ls turtle fractals \ 21 | sprite doloop sys labels mml mmldemo sid spritedemo \ 22 | require compat timer float viceutil turnkey \ 23 | wordlist io open dos see accept 24 | SRCS = $(addprefix $(SRC_DIR)/,$(addsuffix .fs,$(SRC_NAMES))) 25 | 26 | TEST_SRC_NAMES = test testcore testcoreplus testcoreext testexception tester testsee 1 27 | TEST2_SRC_NAMES = see gfx gfxdemo fractals mmldemo mml sid spritedemo sprite compat rnd sin turtle 28 | TEST_SRCS = $(addprefix test/,$(addsuffix .fs,$(TEST_SRC_NAMES))) 29 | 30 | SEPARATOR_NAME1 = '=-=-=-=-=-=-=-=,s' 31 | SEPARATOR_NAME2 = '=-------------=,s' 32 | SEPARATOR_NAME3 = '=-=---=-=---=-=,s' 33 | 34 | all: $(DISK_IMAGE) 35 | 36 | deploy: $(DISK_IMAGE) asm/cart.asm $(TEST_SRCS) 37 | python asm/header.py $(wildcard asm/*.asm) # verify .asm headers 38 | rm -rf deploy 39 | mkdir deploy 40 | cp $(DISK_IMAGE) deploy/$(DEPLOY_NAME).$(DISK_SUF) 41 | $(X64) $(X64_DEPLOY_OPTS) -exitscreenshot build/vice-build deploy/$(DEPLOY_NAME).$(DISK_SUF) 42 | \ 43 | # make test disk 44 | echo >build/c1541.script attach deploy/$(DEPLOY_NAME).$(DISK_SUF) 45 | echo >>build/c1541.script read durexforth 46 | echo >>build/c1541.script format "test,DF" $(DISK_SUF) deploy/tests.$(DISK_SUF) 47 | echo >>build/c1541.script write durexforth 48 | @for forth in $(TEST_SRC_NAMES); do\ 49 | printf aa | cat - test/$$forth.fs | $(PETCAT) -text -w2 -o build/$$forth.pet - ; \ 50 | echo >>build/c1541.script write build/$$forth.pet $$forth; \ 51 | done; 52 | @for forth in $(TEST2_SRC_NAMES); do\ 53 | printf aa | cat - $(SRC_DIR)/$$forth.fs | $(PETCAT) -text -w2 -o build/$$forth.pet - ; \ 54 | echo >>build/c1541.script write build/$$forth.pet $$forth; \ 55 | done; 56 | $(C1541) build/version.asm !pet \"durexForth $(VERSION_STRING)\" 71 | @$(AS) -I asm asm/durexforth.asm 72 | 73 | $(DISK_IMAGE): durexforth.prg Makefile $(SRCS) 74 | mkdir -p build 75 | touch build/empty 76 | echo >build/c1541.script format "durexforth,DF" $(DISK_SUF) $@ 77 | echo >>build/c1541.script write durexforth.prg durexforth 78 | echo >>build/c1541.script write build/empty $(SEPARATOR_NAME1) 79 | echo >>build/c1541.script write build/empty $(TAG_DEPLOY_DOT),s 80 | echo >>build/c1541.script write build/empty ' '$(GIT_HASH),s 81 | echo >>build/c1541.script write build/empty $(SEPARATOR_NAME2) 82 | @for forth in $(SRC_NAMES); do\ 83 | printf aa | cat - $(SRC_DIR)/$$forth.fs | $(PETCAT) -text -w2 -o build/$$forth.pet - ; \ 84 | echo >>build/c1541.script write build/$$forth.pet $$forth; \ 85 | done; 86 | echo >>build/c1541.script write build/empty $(SEPARATOR_NAME3) 87 | $(C1541) fastest C64 Forth, running at ~50x the speed of Basic V2! 13 | * Easy to use. Implements the Forth 2012 core standard, learn it with Starting Forth! 14 | 15 | ### Testimonials 16 | 17 | 18 | 19 | [C64 Programming May the Forth be with you Pt 1 - YouTube](https://www.youtube.com/watch?v=TXIDqptXmiM) 20 | 21 | [C64 Programming Into the Forth Dimension Pt 2 - YouTube](https://www.youtube.com/watch?v=1oZztCmC8kc) 22 | 23 | [A Brief Introduction to DurexForth for the Commodore 64](https://dev.to/ianwitham/a-brief-introduction-to-durexforth-for-the-commodore-64-1c99) 24 | 25 | "Just fooling around but Durexforth is fast and fun!" -Kevin Reno 26 | 27 | "Ich finde das Forth klein und effektiv, wunderbar." -Peter Bierbach 28 | 29 | "Ist eine mächtige Sprache für ein 8-Bitter." -Pebisoft 30 | 31 | "The author of durexForth was quite helpful... There is even a vim-like editor, impressive for being on a C64." -Christian Johansson 32 | -------------------------------------------------------------------------------- /RELEASING.md: -------------------------------------------------------------------------------- 1 | ## How to Release 2 | 1. `git checkout master` 3 | 1. Update CHANGELOG.md with new version and release date. 4 | 1. Commit CHANGELOG.md. 5 | 1. `git push` 6 | 1. `git tag v#.#.#` 7 | 1. `git push --tag` 8 | 1. `make deploy`. Vice now runs twice. Do not quit Vice manually! If it gets stuck somewhere, it is an error which must be fixed before restarting from step 1. 9 | 1. Wait until `make` completes without errors. 10 | 1. Create new release in Github. Copy change list from CHANGELOG.md and add the binaries in deploy folder. 11 | 1. `git checkout github-pages` 12 | 1. `git merge master` 13 | 1. `make docs` 14 | 1. `git commit docs` 15 | 1. `git push` 16 | -------------------------------------------------------------------------------- /asm/cart.asm: -------------------------------------------------------------------------------- 1 | !cpu 6510 2 | !ct raw 3 | !to "build/cart.bin", plain ; set output file and format 4 | 5 | * = $8000 6 | !word coldstart ; coldstart vector 7 | !word warmstart ; warmstart vector 8 | !byte $C3,$C2,$CD,$38,$30 ; "CBM80". Autostart string 9 | 10 | coldstart 11 | sei 12 | stx $d016 13 | jsr $fda3 ;Prepare IRQ 14 | 15 | ; init system constants ($fd50) 16 | lda #0 17 | tay 18 | - sta 2,y 19 | sta $200,y 20 | sta $300,y 21 | iny 22 | bne - 23 | lda #4 24 | sta $288 25 | 26 | jsr $fd15 ;Init I/O 27 | jsr $ff5b ;Init video 28 | 29 | warmstart 30 | sei 31 | lda #durexforth_bin 34 | sta $8c 35 | lda #8 36 | sta $8e 37 | sta $ba ; last device 38 | lda #$1 39 | sta $8d 40 | sta $de00 ; make sure we are in 16k mode (doesn't matter what we write, just a write does the trick) 41 | ldy #0 42 | - 43 | lda ($8b),y 44 | sta ($8d),y 45 | iny 46 | lda ($8b),y 47 | sta ($8d),y 48 | iny 49 | lda ($8b),y 50 | sta ($8d),y 51 | iny 52 | lda ($8b),y 53 | sta ($8d),y 54 | iny 55 | bne - 56 | inc $8c 57 | inc $8e 58 | lda $8c 59 | cmp #$c0 60 | bne - 61 | 62 | cli 63 | ldx #0 64 | lda $de00 ; $a000-$bfff = RAM (Simons' basic) 65 | jmp $80d 66 | 67 | durexforth_bin 68 | !binary "build/durexforth",,$2 69 | 70 | * = $bfff ; fill up to -$9fff (or $bfff if 16K) 71 | !byte 0 72 | -------------------------------------------------------------------------------- /asm/compiler.asm: -------------------------------------------------------------------------------- 1 | ; C, , [ ] ; IMMEDIATE STATE LATESTXT : HEADER LIT LITC COMPILE, LITERAL HERE 2 | ; DODOES 3 | 4 | curr_word_no_tail_call_elimination 5 | !byte 1 6 | last_word_no_tail_call_elimination 7 | !byte 1 8 | 9 | +BACKLINK "c,", 2 10 | CCOMMA 11 | lda HERE_LSB 12 | sta W 13 | lda HERE_MSB 14 | sta W + 1 15 | 16 | ldy #0 17 | lda LSB, x 18 | sta (W), y 19 | 20 | ; update HERE 21 | inc HERE_LSB 22 | bne + 23 | inc HERE_MSB 24 | + inx 25 | rts 26 | 27 | +BACKLINK ",", 1 28 | COMMA 29 | lda HERE_LSB 30 | sta W 31 | lda HERE_MSB 32 | sta W + 1 33 | 34 | ldy #0 35 | lda LSB, x 36 | sta (W), y 37 | iny 38 | lda MSB, x 39 | sta (W), y 40 | 41 | ; update HERE 42 | lda HERE_LSB 43 | clc 44 | adc #2 45 | sta HERE_LSB 46 | bcc + 47 | inc HERE_MSB 48 | + 49 | inx 50 | rts 51 | 52 | ; ----- 53 | 54 | +BACKLINK "[", 1 | F_IMMEDIATE 55 | LBRAC 56 | lda #0 57 | sta STATE 58 | rts 59 | 60 | ; ----- 61 | 62 | ; Exempt from TCE because `: x [ ] ;` does not compile a jsr. 63 | +BACKLINK "]", 1 | F_NO_TAIL_CALL_ELIMINATION 64 | RBRAC 65 | lda #1 66 | sta STATE 67 | rts 68 | 69 | +BACKLINK ";", 1 | F_IMMEDIATE 70 | SEMICOLON 71 | jsr EXIT 72 | 73 | ; Unhides the word. 74 | PENDING_LATEST_MSB = * + 1 75 | lda #0 76 | beq + 77 | sta LATEST_MSB 78 | PENDING_LATEST_LSB = * + 1 79 | lda #0 80 | sta LATEST_LSB 81 | lda #0 82 | sta PENDING_LATEST_MSB 83 | + 84 | 85 | ; go back to IMMEDIATE mode. 86 | jmp LBRAC 87 | 88 | +BACKLINK "immediate", 9 89 | ldy #0 90 | lda LATEST_LSB 91 | sta W 92 | lda LATEST_MSB 93 | sta W + 1 94 | lda (W), y 95 | ora #F_IMMEDIATE 96 | sta (W), y 97 | rts 98 | 99 | ; STATE - Is the interpreter executing code (0) or compiling a word (non-zero)? 100 | +BACKLINK "state", 5 101 | +VALUE STATE 102 | STATE 103 | !word 0 104 | 105 | +BACKLINK "latestxt", 8 106 | LATEST_XT_LSB = * + 1 107 | LATEST_XT_MSB = * + 3 108 | +VALUE 0 109 | 110 | ; Exempt from TCE because `: x ;` does not compile a jsr. 111 | +BACKLINK ":", 1 | F_NO_TAIL_CALL_ELIMINATION 112 | COLON 113 | lda LATEST_LSB 114 | pha 115 | lda LATEST_MSB 116 | pha 117 | 118 | jsr HEADER ; makes the dictionary entry / header 119 | 120 | ; defer the LATEST update to ; 121 | lda LATEST_LSB 122 | sta PENDING_LATEST_LSB 123 | lda LATEST_MSB 124 | sta PENDING_LATEST_MSB 125 | 126 | pla 127 | sta LATEST_MSB 128 | pla 129 | sta LATEST_LSB 130 | 131 | lda HERE_LSB 132 | sta LATEST_XT_LSB 133 | lda HERE_MSB 134 | sta LATEST_XT_MSB 135 | 136 | jmp RBRAC ; enter compile mode 137 | 138 | +BACKLINK "header", 6 139 | HEADER ; ( "name" -- ) 140 | inc last_word_no_tail_call_elimination 141 | 142 | ; Parse, get [W2]name-addr and [LSB-2]length. 143 | jsr PARSE_NAME 144 | inx 145 | lda LSB, x 146 | sta W2 147 | lda MSB, x 148 | sta W2 + 1 149 | inx 150 | 151 | ; Abort if empty string. 152 | lda LSB - 2, x 153 | bne + 154 | lda #-16 ; attempt to use zero-length string as a name 155 | jmp throw_a 156 | + sta .putlen+1 157 | 158 | ; Move back [W]LATEST. 159 | clc 160 | adc #3 161 | sta W 162 | lda LATEST_LSB 163 | sec 164 | sbc W 165 | sta LATEST_LSB 166 | sta W 167 | bcs + 168 | dec LATEST_MSB 169 | + lda LATEST_MSB 170 | sta W + 1 171 | 172 | ; Store name length. 173 | ldy #0 174 | lda LSB - 2, x 175 | sta (W), y 176 | 177 | ; Copy name. 178 | - lda (W2), y 179 | jsr CHAR_TO_LOWERCASE 180 | iny 181 | sta (W), y 182 | .putlen 183 | cpy #0 184 | bne - 185 | 186 | ; Store xt. 187 | iny 188 | lda HERE_LSB 189 | sta (W), y 190 | iny 191 | lda HERE_MSB 192 | sta (W), y 193 | rts 194 | 195 | +BACKLINK "lit", 3 196 | LIT 197 | dex 198 | 199 | ; load IP 200 | pla 201 | sta W 202 | pla 203 | sta W + 1 204 | 205 | ; copy literal to stack 206 | ldy #1 207 | lda (W), y 208 | sta LSB, x 209 | iny 210 | lda (W), y 211 | sta MSB, x 212 | 213 | clc 214 | lda W 215 | adc #3 216 | sta W 217 | bcc + 218 | inc W+1 219 | + jmp (W) 220 | 221 | +BACKLINK "litc", 4 222 | LITC 223 | dex 224 | 225 | ; load IP 226 | pla 227 | sta W 228 | pla 229 | sta W + 1 230 | 231 | inc W 232 | bne + 233 | inc W + 1 234 | + 235 | ; copy literal to stack 236 | ldy #0 237 | lda (W), y 238 | sta LSB, x 239 | sty MSB, x 240 | 241 | inc W 242 | bne + 243 | inc W + 1 244 | + jmp (W) 245 | 246 | +BACKLINK "compile,", 8 247 | COMPILE_COMMA 248 | lda #OP_JSR 249 | jsr compile_a 250 | jmp COMMA 251 | 252 | +BACKLINK "literal", 7 | F_IMMEDIATE 253 | LITERAL 254 | dex 255 | lda MSB + 1,x 256 | bne + 257 | lda #LITC 260 | sta MSB,x 261 | jsr COMPILE_COMMA 262 | jmp CCOMMA ; writes byte 263 | + 264 | lda #LIT 267 | sta MSB, x 268 | jsr COMPILE_COMMA 269 | jmp COMMA ; writes number 270 | 271 | ; HERE - points to the next free byte of memory. When compiling, compiled words go here. 272 | +BACKLINK "here", 4 273 | HERE 274 | HERE_LSB = * + 1 275 | HERE_MSB = * + 3 276 | +VALUE HERE_POSITION 277 | 278 | +BACKLINK "dodoes", 6 279 | 280 | ; behavior pointer address => W 281 | pla 282 | sta W 283 | pla 284 | sta W + 1 285 | 286 | inc W 287 | bne + 288 | inc W + 1 289 | + 290 | 291 | ; push data pointer to param stack 292 | dex 293 | lda W 294 | clc 295 | adc #2 296 | sta LSB,x 297 | lda W + 1 298 | adc #0 299 | sta MSB,x 300 | 301 | ldy #0 302 | lda (W),y 303 | sta W2 304 | iny 305 | lda (W),y 306 | sta W2 + 1 307 | jmp (W2) 308 | 309 | -------------------------------------------------------------------------------- /asm/control.asm: -------------------------------------------------------------------------------- 1 | ; IF THEN BEGIN WHILE REPEAT BRANCH 0BRANCH UNLOOP EXIT 2 | 3 | +BACKLINK "if", 2 | F_IMMEDIATE 4 | jsr LIT 5 | !word ZBRANCH 6 | jsr COMPILE_COMMA 7 | jsr HERE 8 | jsr ZERO 9 | jmp COMMA 10 | 11 | +BACKLINK "then", 4 | F_IMMEDIATE 12 | jsr HERE 13 | jsr SWAP 14 | jmp STORE 15 | 16 | +BACKLINK "begin", 5 | F_IMMEDIATE 17 | jmp HERE 18 | 19 | +BACKLINK "while", 5 | F_IMMEDIATE 20 | jsr LIT 21 | !word ZBRANCH 22 | jsr COMPILE_COMMA 23 | jsr HERE 24 | jsr ZERO 25 | jsr COMMA 26 | jmp SWAP 27 | 28 | COMPILE_JMP 29 | jsr LITC 30 | !byte OP_JMP 31 | jmp CCOMMA 32 | 33 | +BACKLINK "repeat", 6 | F_IMMEDIATE 34 | jsr COMPILE_JMP 35 | jsr COMMA 36 | jsr HERE 37 | jsr SWAP 38 | jmp STORE 39 | 40 | +BACKLINK "branch", 6 41 | BRANCH 42 | pla 43 | sta W 44 | pla 45 | sta W + 1 46 | 47 | ldy #2 48 | lda (W), y 49 | sta + + 2 50 | dey 51 | lda (W), y 52 | sta + + 1 53 | + jmp PLACEHOLDER_ADDRESS ; replaced with branch destination 54 | 55 | +BACKLINK "0branch", 7 56 | ZBRANCH 57 | inx 58 | lda LSB-1, x 59 | ora MSB-1, x 60 | beq BRANCH 61 | 62 | ; skip offset 63 | pla 64 | clc 65 | adc #2 66 | bcc + 67 | tay 68 | pla 69 | adc #0 70 | pha 71 | tya 72 | + pha 73 | rts 74 | 75 | ; Exempt from TCE as top of return stack must contain a return address. 76 | +BACKLINK "unloop", 6 | F_NO_TAIL_CALL_ELIMINATION 77 | jsr R_TO 78 | jsr R_TO 79 | jsr R_TO 80 | inx 81 | inx 82 | jsr TO_R 83 | rts 84 | 85 | +BACKLINK "exit", 4 | F_IMMEDIATE 86 | EXIT 87 | lda last_word_no_tail_call_elimination 88 | bne + 89 | ; do tail call elimination: instead of adding a final rts, 90 | ; replace the last jsr with a jmp. 91 | lda HERE_LSB 92 | sec 93 | sbc #3 94 | tay 95 | lda HERE_MSB 96 | sbc #0 97 | sta .instr_ptr + 1 98 | lda #OP_JMP 99 | .instr_ptr = * + 1 100 | sta PLACEHOLDER_ADDRESS,y ; replaced with instruction pointer 101 | rts 102 | + 103 | lda #OP_RTS 104 | jmp compile_a 105 | -------------------------------------------------------------------------------- /asm/core.asm: -------------------------------------------------------------------------------- 1 | ; DROP SWAP DUP ?DUP NIP OVER 2DUP 1+ 1- + = 0= AND ! @ C! C@ COUNT < > MAX MIN 2 | ; TUCK >R R> R@ BL PICK DEPTH WITHIN ERASE FILL BASE 2* ROT +! SPLIT 3 | 4 | +BACKLINK "drop", 4 | F_IMMEDIATE 5 | DROP 6 | lda STATE 7 | bne + 8 | inx 9 | rts 10 | + lda #OP_INX 11 | compile_a 12 | dex 13 | sta LSB, x 14 | jmp CCOMMA 15 | 16 | +BACKLINK "swap", 4 17 | SWAP 18 | ldy MSB, x 19 | lda MSB + 1, x 20 | sta MSB, x 21 | sty MSB + 1, x 22 | 23 | ldy LSB, x 24 | lda LSB + 1, x 25 | sta LSB, x 26 | sty LSB + 1, x 27 | rts 28 | 29 | +BACKLINK "dup", 3 30 | DUP 31 | dex 32 | lda MSB + 1, x 33 | sta MSB, x 34 | lda LSB + 1, x 35 | sta LSB, x 36 | rts 37 | 38 | +BACKLINK "?dup", 4 39 | QDUP 40 | lda MSB, x 41 | ora LSB, x 42 | bne DUP 43 | rts 44 | 45 | +BACKLINK "nip", 3 46 | NIP ; ( a b -- b ) 47 | jsr SWAP 48 | inx 49 | rts 50 | 51 | +BACKLINK "over", 4 52 | OVER 53 | dex 54 | lda MSB + 2, x 55 | sta MSB, x 56 | lda LSB + 2, x 57 | sta LSB, x 58 | rts 59 | 60 | +BACKLINK "2dup", 4 61 | TWODUP 62 | jsr OVER 63 | jmp OVER 64 | 65 | +BACKLINK "1+", 2 66 | ONEPLUS 67 | inc LSB, x 68 | bne + 69 | inc MSB, x 70 | + rts 71 | 72 | +BACKLINK "1-", 2 73 | ONEMINUS 74 | lda LSB, x 75 | bne + 76 | dec MSB, x 77 | + dec LSB, x 78 | rts 79 | 80 | +BACKLINK "+", 1 81 | PLUS 82 | lda LSB, x 83 | clc 84 | adc LSB + 1, x 85 | sta LSB + 1, x 86 | 87 | lda MSB, x 88 | adc MSB + 1, x 89 | sta MSB + 1, x 90 | 91 | inx 92 | rts 93 | 94 | +BACKLINK "=", 1 95 | EQUAL 96 | ldy #0 97 | lda LSB, x 98 | cmp LSB + 1, x 99 | bne + 100 | lda MSB, x 101 | cmp MSB + 1, x 102 | bne + 103 | dey 104 | + inx 105 | sty MSB, x 106 | sty LSB, x 107 | rts 108 | 109 | ; 0= 110 | +BACKLINK "0=", 2 111 | ZEQU 112 | ldy #0 113 | lda LSB, x 114 | bne + 115 | lda MSB, x 116 | bne + 117 | dey 118 | + sty MSB, x 119 | sty LSB, x 120 | rts 121 | 122 | +BACKLINK "and", 3 123 | lda MSB, x 124 | and MSB + 1, x 125 | sta MSB + 1, x 126 | 127 | lda LSB, x 128 | and LSB + 1, x 129 | sta LSB + 1, x 130 | 131 | inx 132 | rts 133 | 134 | +BACKLINK "!", 1 135 | STORE 136 | lda LSB, x 137 | sta W 138 | lda MSB, x 139 | sta W + 1 140 | 141 | ldy #0 142 | lda LSB+1, x 143 | sta (W), y 144 | iny 145 | lda MSB+1, x 146 | sta (W), y 147 | 148 | inx 149 | inx 150 | rts 151 | 152 | +BACKLINK "@", 1 153 | FETCH 154 | lda LSB,x 155 | sta W 156 | lda MSB,x 157 | sta W+1 158 | 159 | ldy #0 160 | lda (W),y 161 | sta LSB,x 162 | iny 163 | lda (W),y 164 | sta MSB,x 165 | rts 166 | 167 | +BACKLINK "c!", 2 168 | STOREBYTE 169 | ldy LSB,x 170 | lda MSB,x 171 | sta + + 2 172 | lda LSB+1,x 173 | + sta PLACEHOLDER_ADDRESS,y ; replaced with addr 174 | inx 175 | inx 176 | rts 177 | 178 | +BACKLINK "c@", 2 179 | FETCHBYTE 180 | ldy LSB,x 181 | lda MSB,x 182 | sta + + 2 183 | + lda PLACEHOLDER_ADDRESS,y ; replaced with addr 184 | sta LSB,x 185 | lda #0 186 | sta MSB,x 187 | rts 188 | 189 | +BACKLINK "count", 5 190 | COUNT 191 | jsr DUP 192 | jsr ONEPLUS 193 | jsr SWAP 194 | jmp FETCHBYTE 195 | 196 | +BACKLINK "<", 1 197 | LESS_THAN 198 | ldy #0 199 | sec 200 | lda LSB+1,x 201 | sbc LSB,x 202 | lda MSB+1,x 203 | sbc MSB,x 204 | bvc + 205 | eor #$80 206 | + bpl + 207 | dey 208 | + inx 209 | sty LSB,x 210 | sty MSB,x 211 | rts 212 | 213 | +BACKLINK ">", 1 214 | GREATER_THAN 215 | jsr SWAP 216 | jmp LESS_THAN 217 | 218 | +BACKLINK "max", 3 219 | MAX 220 | jsr TWODUP 221 | jsr LESS_THAN 222 | jsr ZBRANCH 223 | !word + 224 | jsr SWAP 225 | + inx 226 | rts 227 | 228 | +BACKLINK "min", 3 229 | MIN 230 | jsr TWODUP 231 | jsr GREATER_THAN 232 | jsr ZBRANCH 233 | !word + 234 | jsr SWAP 235 | + inx 236 | rts 237 | 238 | +BACKLINK "tuck", 4 239 | TUCK ; ( x y -- y x y ) 240 | jsr SWAP 241 | jmp OVER 242 | 243 | ; Exempt from TCE as top of return stack must contain a return address. 244 | +BACKLINK ">r", 2 | F_NO_TAIL_CALL_ELIMINATION 245 | TO_R 246 | pla 247 | sta W 248 | pla 249 | sta W+1 250 | inc W 251 | bne + 252 | inc W+1 253 | + 254 | lda MSB,x 255 | pha 256 | lda LSB,x 257 | pha 258 | inx 259 | jmp (W) 260 | 261 | ; Exempt from TCE as top of return stack must contain a return address. 262 | +BACKLINK "r>", 2 | F_NO_TAIL_CALL_ELIMINATION 263 | R_TO 264 | pla 265 | sta W 266 | pla 267 | sta W+1 268 | inc W 269 | bne + 270 | inc W+1 271 | + 272 | dex 273 | pla 274 | sta LSB,x 275 | pla 276 | sta MSB,x 277 | jmp (W) 278 | 279 | ; Exempt from TCE as top of return stack must contain a return address. 280 | +BACKLINK "r@", 2 | F_NO_TAIL_CALL_ELIMINATION 281 | R_FETCH 282 | txa 283 | tsx 284 | ldy $103,x 285 | sty W 286 | ldy $104,x 287 | tax 288 | dex 289 | sty MSB,x 290 | lda W 291 | sta LSB,x 292 | rts 293 | 294 | +BACKLINK "bl", 2 295 | BL 296 | +VALUE K_SPACE 297 | 298 | +BACKLINK "pick", 4 299 | txa 300 | sta + + 1 301 | clc 302 | adc LSB,x 303 | tax 304 | inx 305 | lda LSB,x 306 | ldy MSB,x 307 | + ldx #0 308 | sta LSB,x 309 | sty MSB,x 310 | rts 311 | 312 | +BACKLINK "depth", 5 313 | txa 314 | eor #$ff 315 | tay 316 | iny 317 | dex 318 | sty LSB,x 319 | lda #0 320 | sta MSB,x 321 | rts 322 | 323 | +BACKLINK "within", 6 324 | WITHIN ; ( test low high -- flag ) 325 | jsr OVER 326 | jsr MINUS 327 | jsr TO_R 328 | jsr MINUS 329 | jsr R_TO 330 | jmp U_LESS 331 | 332 | ; ERASE ( start len -- ) 333 | +BACKLINK "erase", 5 334 | ldy #0 335 | jmp FILL_Y 336 | 337 | ; FILL ( start len char -- ) 338 | +BACKLINK "fill", 4 339 | FILL 340 | lda LSB, x 341 | tay 342 | inx 343 | FILL_Y 344 | lda LSB + 1, x 345 | sta .fdst 346 | lda MSB + 1, x 347 | sta .fdst + 1 348 | lda LSB, x 349 | eor #$ff 350 | sta W 351 | lda MSB, x 352 | eor #$ff 353 | sta W + 1 354 | inx 355 | inx 356 | - 357 | inc W 358 | bne + 359 | inc W + 1 360 | bne + 361 | rts 362 | + 363 | .fdst = * + 1 364 | sty PLACEHOLDER_ADDRESS ; replaced with start 365 | 366 | ; advance 367 | inc .fdst 368 | bne - 369 | inc .fdst + 1 370 | jmp - 371 | 372 | +BACKLINK "base", 4 373 | BASE 374 | +VALUE _BASE 375 | _BASE 376 | !word 16 377 | 378 | +BACKLINK "2*", 2 379 | asl LSB, x 380 | rol MSB, x 381 | rts 382 | 383 | +BACKLINK "rot", 3 ; ( a b c -- b c a ) 384 | ROT 385 | ldy MSB+2, x 386 | lda MSB+1, x 387 | sta MSB+2, x 388 | lda MSB , x 389 | sta MSB+1, x 390 | sty MSB , x 391 | ldy LSB+2, x 392 | lda LSB+1, x 393 | sta LSB+2, x 394 | lda LSB , x 395 | sta LSB+1, x 396 | sty LSB , x 397 | rts 398 | 399 | +BACKLINK "+!", 2 ; ( num addr -- ) 400 | PLUS_STORE 401 | lda LSB,x 402 | sta W 403 | lda MSB,x 404 | sta W+1 405 | ldy #0 406 | clc 407 | lda (W),y 408 | adc LSB+1,x 409 | sta (W),y 410 | iny 411 | lda (W),y 412 | adc MSB+1,x 413 | sta (W),y 414 | inx 415 | inx 416 | rts 417 | 418 | +BACKLINK "split", 5 ; ( n -- lsb msb ) 419 | lda MSB,x 420 | sta LSB-1,x 421 | lda #0 422 | sta MSB,x 423 | sta MSB-1,x 424 | dex 425 | rts 426 | -------------------------------------------------------------------------------- /asm/disk.asm: -------------------------------------------------------------------------------- 1 | ; DEVICE RDERR LOADB SAVEB INCLUDED 2 | 3 | READST = $ffb7 4 | SETLFS = $ffba 5 | SETNAM = $ffbd 6 | OPEN = $ffc0 7 | CLOSE = $ffc3 8 | CHKIN = $ffc6 9 | CHKOUT = $ffc9 10 | CLRCHN = $ffcc 11 | CHRIN = $ffcf 12 | CHROUT = $ffd2 13 | LOAD = $ffd5 14 | SAVE = $ffd8 15 | 16 | ; ----- 17 | 18 | +BACKLINK "device", 6 19 | lda LSB,x 20 | sta $ba 21 | inx 22 | rts 23 | 24 | +BACKLINK "rderr", 5 25 | _errorchread 26 | ; read and print error channel of the active device 27 | ; from https://codebase64.org/doku.php?id=base:reading_the_error_channel_of_a_disk_drive 28 | LDA #$00 29 | STA $90 ; clear STATUS flags 30 | 31 | LDA $BA ; device number 32 | JSR $FFB1 ; call LISTEN 33 | LDA #$6F ; secondary address 15 (command channel) 34 | JSR $FF93 ; call SECLSN (SECOND) 35 | JSR $FFAE ; call UNLSN 36 | LDA $90 ; get STATUS flags 37 | BNE .devnp ; device not present 38 | 39 | LDA $BA ; device number 40 | JSR $FFB4 ; call TALK 41 | LDA #$6F ; secondary address 15 (error channel) 42 | JSR $FF96 ; call SECTLK (TKSA) 43 | 44 | .loop LDA $90 ; get STATUS flags 45 | BNE .eof ; either EOF or error 46 | JSR $FFA5 ; call IECIN (get byte from IEC bus) 47 | JSR $FFD2 ; call CHROUT (print byte to screen) 48 | JMP .loop ; next byte 49 | .eof jmp $FFAB ; call UNTLK 50 | 51 | .devnp ; print "device not present" and abort 52 | ldx #X_INIT-1 53 | lda #5 54 | sta LSB,x 55 | lda #0 56 | sta MSB,x 57 | jmp IOABORT 58 | 59 | ; LOADB ( filenameptr filenamelen dst -- endaddress ) load binary file 60 | ; - s" base" 7000 loadb #load file to 7000 61 | ; - returns 0 on failure, otherwise address after last written byte 62 | +BACKLINK "loadb", 5 63 | LOADB 64 | txa 65 | pha 66 | lda $b8 ; current logical file 67 | pha 68 | 69 | lda MSB, x ; >destination 70 | sta load_binary_laddr_hi 71 | lda LSB, x ; basename 77 | lda LSB+2, x ; x load_address 115 | sty load_binary_status 116 | lda #0 ;0 = load to memory (no verify) 117 | jsr LOAD 118 | bcs .disk_io_error 119 | rts 120 | 121 | .disk_io_setnamsetlfs ;reused by both loadb and saveb 122 | jsr SETNAM 123 | ldx $ba ; keep current device 124 | lda #1 ; logical file # 125 | ldy #0 ; if load: 0 = load to new address, if save: 0 = dunno, but okay... 126 | jmp SETLFS 127 | 128 | .disk_io_error 129 | ; Accumulator contains BASIC error code 130 | 131 | ;... error handling ... 132 | ldx #$00 ; filenumber 0 = keyboard 133 | stx load_binary_status 134 | jmp CLRCHN 135 | 136 | ; SAVEB (save binary file) 137 | ; - 7000 71ae s" base" saveb #save file from 7000 to 71ae (= the byte AFTER the last byte in the file) 138 | +BACKLINK "saveb", 5 139 | SAVEB 140 | stx W 141 | 142 | lda $b8 ; current logical file 143 | pha 144 | lda $ae 145 | pha 146 | lda $af 147 | pha 148 | 149 | lda LSB+3, x ; range begin lo 150 | sta $c1 151 | lda MSB+3, x ; range begin hi 152 | sta $c2 153 | 154 | lda LSB+2, x ; range end lo 155 | sta save_binary_srange_end_lo 156 | lda MSB+2, x ; range end hi 157 | sta save_binary_srange_end_hi 158 | 159 | lda LSB, x ; a filename length 160 | pha 161 | ldy MSB+1, x ; y basename hi 162 | lda LSB+1, x ; x basename lo 163 | tax 164 | pla 165 | 166 | jsr .disk_io_setnamsetlfs 167 | 168 | ;This should point to the byte AFTER the last byte in the file. 169 | save_binary_srange_end_lo = *+1 170 | ldx #$ff ;load_address lo 171 | save_binary_srange_end_hi = *+1 172 | ldy #$ff ;load_address hi 173 | lda #$c1 ;tell routine that start address is located in $c1/$c2 174 | jsr SAVE 175 | jsr _errorchread 176 | 177 | pla 178 | sta $af 179 | pla 180 | sta $ae 181 | pla 182 | tax 183 | jsr CHKIN 184 | 185 | ldx W 186 | inx 187 | inx 188 | inx 189 | inx 190 | rts 191 | 192 | +BACKLINK "included", 8 193 | INCLUDED 194 | lda LSB, x 195 | sta .filelen 196 | lda MSB+1, x 197 | sta .namehi 198 | lda LSB+1, x 199 | sta .namelo 200 | inx 201 | inx 202 | 203 | jsr PUSH_INPUT_SOURCE 204 | 205 | ; Is TIB_PTR pointing to TIB? 206 | lda TIB_PTR+1 207 | cmp #>TIB 208 | bne .reset_tib_ptr_to_tib 209 | 210 | ; ...if yes: Adjust TIB_PTR to point past the current TIB content, to avoid clobbering. 211 | lda TO_IN_W 212 | cmp TIB_SIZE 213 | beq .load_file ; If TIB is already consumed, no need to do anything. 214 | lda TIB_SIZE 215 | clc 216 | adc TIB_PTR 217 | sta TIB_PTR 218 | jmp .load_file 219 | 220 | ; ...if no: Reset TIB_PTR so that it points to TIB again. 221 | .reset_tib_ptr_to_tib: 222 | lda #TIB 225 | sta TIB_PTR+1 226 | 227 | .load_file: 228 | 229 | txa 230 | pha 231 | 232 | .filelen = * + 1 233 | lda #0 234 | .namehi = * + 1 235 | ldy #0 236 | .namelo = * + 1 237 | ldx #0 238 | 239 | ; open file 240 | jsr SETNAM 241 | lda #0 242 | sta SOURCE_ID_MSB 243 | ldy SOURCE_ID_LSB 244 | iny 245 | tya 246 | ora #8 247 | tay 248 | sty SOURCE_ID_LSB 249 | 250 | ldx $ba ; last used device# 251 | jsr SETLFS 252 | jsr OPEN 253 | bcc + 254 | ldx #-1 255 | sta LSB,x 256 | jmp IOABORT 257 | + 258 | ldx SOURCE_ID_LSB ; file number 259 | jsr CHKIN 260 | 261 | ; Skips load address. It is tempting to keep the source 262 | ; code as .SEQ files instead of .PRG to avoid this step. 263 | ; However, the advantage with .PRG is that loading/saving 264 | ; files from text editor can be dramatically speeded up 265 | ; by fast loader cartridges such as Retro Replay. 266 | JSR CHRIN ; get a byte from file 267 | JSR CHRIN ; get a byte from file 268 | 269 | jsr READST 270 | beq + 271 | jsr _errorchread 272 | lda #-37 ; file i/o exception 273 | jmp throw_a 274 | + 275 | pla 276 | tax 277 | 278 | jmp interpret_and_close 279 | -------------------------------------------------------------------------------- /asm/durexforth.asm: -------------------------------------------------------------------------------- 1 | ; PUSHYA 0 1 -1 START MSB LSB LATEST 2 | 3 | ; ACME assembler 4 | 5 | !cpu 6510 6 | !to "durexforth.prg", cbm ; set output file and format 7 | !ct pet 8 | 9 | ; Opcodes. 10 | OP_JMP = $4c 11 | OP_JSR = $20 12 | OP_RTS = $60 13 | OP_INX = $e8 14 | 15 | ; CHROUT keys. 16 | K_RETURN = $d 17 | K_CLRSCR = $93 18 | K_SPACE = ' ' 19 | 20 | ; Addresses. 21 | LSB = $3b ; low-byte stack placed in [3 .. $3a] 22 | MSB = $73 ; high-byte stack placed in [$3b .. $72] 23 | W = $8b ; rnd seed \ Temporary work area 24 | W2 = $8d ; rnd seed ) available for words. 25 | W3 = $9e ; tape error log / Each two bytes. 26 | TIB = $200 ; text input buffer 27 | PROGRAM_BASE = $801 28 | ;HERE_POSITION = $801 + assembled program (defined below) 29 | WORDLIST_BASE = $9fff 30 | PUTCHR = $ffd2 ; kernal CHROUT routine 31 | 32 | ; Parameter Stack 33 | ; --------------- 34 | 35 | ; The x register contains the current stack depth. 36 | ; It is initially 0 and decrements when items are pushed. 37 | ; The parameter stack is placed in zeropage to save space. 38 | ; (E.g. lda $FF,x takes less space than lda $FFFF,x) 39 | ; We use a split stack that store low-byte and high-byte 40 | ; in separate ranges on the zeropage, so that popping and 41 | ; pushing gets faster (only one inx/dex operation). 42 | 43 | X_INIT = 0 44 | 45 | ; Dictionary 46 | ; ---------- 47 | 48 | ; Grows backwards from WORDLIST_BASE. Each entry has one 49 | ; byte of flag bits + name length, followed by the bytes of 50 | ; the word's name, and a two-byte "execution token," the 51 | ; address of its code. The address of a dictionary entry is 52 | ; called the word's "name token." 53 | 54 | STRLEN_MASK = $1f 55 | F_IMMEDIATE = $80 ; interpret the word even in compiler STATE 56 | F_NO_TAIL_CALL_ELIMINATION = $40 57 | ; Exempt this word from tail call elimination i.e. 58 | ; "jsr WORD + rts" will not be replaced by "jmp WORD". 59 | 60 | * = WORDLIST_BASE 61 | 62 | !byte 0 ; zero name length = end of dictionary. 63 | 64 | !set __LATEST = WORDLIST_BASE 65 | !macro BACKLINK .name , .namesize { 66 | !set .xt = * 67 | * = __LATEST - len(.name) - 3 68 | !set __LATEST = * 69 | !byte .namesize 70 | !text .name 71 | !word .xt 72 | * = .xt 73 | } 74 | 75 | ; Program Space 76 | ; ------------- 77 | 78 | ; Main assembly starts at PROGRAM_BASE, then the assembled 79 | ; compiler begins writing at HERE_POSITION, to which we 80 | ; assemble a startup routine that we're okay with being 81 | ; overwritten. 82 | 83 | ; PLACEHOLDER_ADDRESSes are assembled into the instruction 84 | ; stream then self-modified by the running program. Low 85 | ; byte must be 0 for situations where the Y register is 86 | ; used instead. 87 | PLACEHOLDER_ADDRESS = $1200 88 | 89 | * = PROGRAM_BASE 90 | 91 | !byte $b, $08, $a, 0, $9E, $32, $30, $36, $31, 0, 0, 0 92 | ; basic header, and program entry: 93 | 94 | tsx 95 | stx INIT_S 96 | ldx #X_INIT 97 | 98 | jsr quit_reset 99 | 100 | jsr PAGE 101 | 102 | lda #%00010110 ; lowercase 103 | sta $d018 104 | 105 | _START = * + 1 106 | jsr load_base 107 | 108 | ; Word Definitions 109 | ; ---------------- 110 | 111 | !macro VALUE .word { 112 | lda #<.word 113 | ldy #>.word 114 | jmp pushya 115 | } 116 | 117 | +BACKLINK "pushya", 6 118 | pushya 119 | dex 120 | sta LSB, x 121 | sty MSB, x 122 | rts 123 | 124 | +BACKLINK "0", 1 125 | ZERO 126 | lda #0 127 | tay 128 | jmp pushya 129 | 130 | +BACKLINK "1", 1 131 | ONE 132 | +VALUE 1 133 | 134 | +BACKLINK "-1", 2 135 | MINUS_ONE 136 | lda #-1 137 | tay 138 | jmp pushya 139 | 140 | ; START - points to the code of the startup word. 141 | +BACKLINK "start", 5 142 | +VALUE _START 143 | 144 | +BACKLINK "msb", 3 145 | +VALUE MSB 146 | 147 | +BACKLINK "lsb", 3 148 | +VALUE LSB 149 | 150 | !src "core.asm" 151 | !src "math.asm" 152 | !src "move.asm" 153 | !src "interpreter.asm" 154 | !src "compiler.asm" 155 | !src "control.asm" 156 | !src "io.asm" 157 | !src "lowercase.asm" 158 | !src "disk.asm" 159 | !src "exception.asm" 160 | !src "format.asm" 161 | 162 | BOOT_STRING 163 | !src "../build/version.asm" 164 | PRINT_BOOT_MESSAGE 165 | ldx #0 166 | - lda BOOT_STRING,x 167 | jsr PUTCHR 168 | inx 169 | cpx #(PRINT_BOOT_MESSAGE - BOOT_STRING) 170 | bne - 171 | jsr CR 172 | ldx #X_INIT 173 | jmp QUIT 174 | 175 | ; LATEST - points to the most recently defined dictionary word. 176 | 177 | +BACKLINK "latest", 6 178 | LATEST 179 | LATEST_LSB = * + 1 180 | LATEST_MSB = * + 3 181 | +VALUE __LATEST 182 | 183 | HERE_POSITION ; everything following this will be overwritten! 184 | 185 | load_base 186 | lda #PRINT_BOOT_MESSAGE 189 | sta _START+1 190 | dex 191 | dex 192 | lda #basename 195 | sta MSB+1, x 196 | lda #(basename_end - basename) 197 | sta LSB,x 198 | lda #>(QUIT-1) 199 | pha 200 | lda #<(QUIT-1) 201 | pha 202 | jmp INCLUDED 203 | 204 | basename 205 | !text "base" 206 | basename_end 207 | -------------------------------------------------------------------------------- /asm/exception.asm: -------------------------------------------------------------------------------- 1 | ; CATCH THROW (ABORT") 2 | 3 | EXCEPTION_HANDLER 4 | +VALUE _EXCEPTION_HANDLER 5 | _EXCEPTION_HANDLER 6 | !word 0 7 | 8 | +BACKLINK "catch", 5 9 | CATCH 10 | ; save data stack pointer 11 | txa 12 | jsr pushya 13 | jsr TO_R 14 | ; save previous handler 15 | jsr EXCEPTION_HANDLER 16 | jsr FETCH 17 | jsr TO_R 18 | ; set current handler 19 | stx W 20 | tsx 21 | txa 22 | ldx W 23 | jsr pushya 24 | jsr EXCEPTION_HANDLER 25 | jsr STORE 26 | ; execute returns if no THROW 27 | jsr EXECUTE 28 | ; restore previous handler 29 | jsr R_TO 30 | jsr EXCEPTION_HANDLER 31 | jsr STORE 32 | ; discard saved stack pointer 33 | jsr R_TO 34 | inx ; drop 35 | ; normal completion 36 | jmp ZERO 37 | 38 | +BACKLINK "throw", 5 39 | THROW 40 | lda LSB,x 41 | ora MSB,x 42 | bne + 43 | ; 0 throw is no-op 44 | inx 45 | rts 46 | + lda _EXCEPTION_HANDLER + 1 47 | beq .print_error_and_abort 48 | 49 | ; restore previous return stack 50 | jsr EXCEPTION_HANDLER 51 | jsr FETCH 52 | stx W 53 | lda LSB,x 54 | tax 55 | txs 56 | ldx W 57 | inx 58 | 59 | ; restore previous handler 60 | jsr R_TO 61 | jsr EXCEPTION_HANDLER 62 | jsr STORE 63 | 64 | ; exc# on return stack 65 | jsr R_TO 66 | jsr SWAP 67 | jsr TO_R 68 | 69 | ; restore stack 70 | lda LSB,x 71 | tax 72 | inx 73 | jsr R_TO 74 | rts 75 | 76 | .print_error_and_abort 77 | lda MSB,x 78 | cmp #-1 79 | bne .unknown_exception 80 | lda LSB,x 81 | cmp #-13 ; Undefined word is printed before THROW. 82 | beq .cr_and_abort 83 | cmp #-37 ; File I/O errors are printed before THROW. 84 | beq .cr_and_abort 85 | cmp #-2 ; abort" 86 | bne + 87 | jsr .get_abort_string 88 | jmp .type_and_abort 89 | + jsr .get_system_exception_string 90 | jsr COUNT 91 | .type_and_abort 92 | jsr RVS 93 | jsr TYPE 94 | .cr_and_abort 95 | jsr CR 96 | ldx #X_INIT 97 | jmp QUIT 98 | 99 | ; It is a bit cheesy to use a hardcoded list, but it works. 100 | ; A linked list would be more flexible. 101 | .get_system_exception_string 102 | cmp #-1 103 | bne + 104 | +VALUE .abort_string 105 | + cmp #-4 106 | bne + 107 | +VALUE .stack_underflow 108 | + cmp #-8 109 | bne + 110 | +VALUE .mem_full 111 | + cmp #-10 112 | bne + 113 | +VALUE .div_error 114 | + cmp #-16 115 | bne + 116 | +VALUE .no_word 117 | + cmp #-28 118 | bne .unknown_exception 119 | +VALUE .user_interrupt 120 | 121 | .unknown_exception 122 | jsr RVS 123 | jsr DOT 124 | lda #'e' 125 | jsr PUTCHR 126 | lda #'r' 127 | jsr PUTCHR 128 | jsr PUTCHR 129 | jmp .cr_and_abort 130 | 131 | .get_abort_string 132 | .msg_lsb = * + 1 133 | lda #0 134 | .msg_msb = * + 1 135 | ldy #0 136 | jsr pushya 137 | .msg_len = * + 1 138 | lda #0 139 | ldy #0 140 | jmp pushya 141 | 142 | .abort_string 143 | !byte 5 144 | !text "abort" 145 | .stack_underflow 146 | !byte 5 147 | !text "stack" 148 | .mem_full 149 | !byte 4 150 | !text "full" 151 | .no_word 152 | !byte 7 153 | !text "no name" 154 | .div_error 155 | !byte 2 156 | !text "/0" ; division by zero 157 | .user_interrupt 158 | !byte 3 159 | !text "brk" 160 | 161 | +BACKLINK "(abort\")", 8 ; ( addr u -- ) 162 | lda LSB,x 163 | sta .msg_len 164 | inx 165 | lda LSB,x 166 | sta .msg_lsb 167 | lda MSB,x 168 | sta .msg_msb 169 | inx 170 | lda #-2 171 | jmp throw_a 172 | -------------------------------------------------------------------------------- /asm/format.asm: -------------------------------------------------------------------------------- 1 | ; <# #> HOLD SIGN # #S U. . SPACE 2 | 3 | .hold_start = $3fc 4 | 5 | ; : <# $3fc holdp ! ; 6 | +BACKLINK "<#", 2 7 | LESS_NUMBER_SIGN 8 | lda #<.hold_start 9 | sta .holdp 10 | rts 11 | 12 | ; : #> 2drop holdp @ $3fc over - ; 13 | +BACKLINK "#>", 2 14 | NUMBER_SIGN_GREATER 15 | lda .holdp 16 | sta LSB+1,x 17 | lda #>.hold_start 18 | sta MSB+1,x 19 | lda #<.hold_start 20 | sec 21 | sbc .holdp 22 | sta LSB,x 23 | lda #0 24 | sta MSB,x 25 | rts 26 | 27 | ; : hold -1 holdp +! holdp @ c! ; 28 | +BACKLINK "hold", 4 29 | HOLD 30 | dec .holdp 31 | inx 32 | lda LSB-1,x 33 | .holdp = * + 1 34 | sta .hold_start 35 | rts 36 | 37 | ; : sign 0< if '-' hold then ; 38 | +BACKLINK "sign", 4 39 | SIGN 40 | inx 41 | lda MSB-1,x 42 | and #$80 43 | bne + 44 | rts 45 | + jsr LITC 46 | !byte '-' 47 | jmp HOLD 48 | 49 | ; : # base @ ud/mod rot 50 | ; dup $a < if 7 - then $37 + hold ; 51 | +BACKLINK "#", 1 52 | NUMBER_SIGN 53 | jsr BASE 54 | jsr FETCH 55 | jsr UD_MOD 56 | jsr ROT 57 | lda LSB,x 58 | cmp #10 59 | bcs + 60 | sbc #6 61 | + clc 62 | adc #$37 63 | sta LSB,x 64 | jmp HOLD 65 | 66 | ; : #s # begin 2dup or while # repeat ; 67 | +BACKLINK "#s", 2 68 | NUMBER_SIGN_S 69 | jsr NUMBER_SIGN 70 | lda LSB,x 71 | ora MSB,x 72 | ora LSB+1,x 73 | ora MSB+1,x 74 | bne NUMBER_SIGN_S 75 | rts 76 | 77 | ; : u. 0 <# #s #> type space ; 78 | +BACKLINK "u.", 2 79 | jsr ZERO 80 | jsr LESS_NUMBER_SIGN 81 | jsr NUMBER_SIGN_S 82 | jsr NUMBER_SIGN_GREATER 83 | jsr TYPE 84 | jmp SPACE 85 | 86 | ; : . dup abs 0 <# #s rot sign #> 87 | ; type space ; 88 | +BACKLINK ".", 1 89 | DOT 90 | jsr DUP 91 | jsr ABS 92 | jsr ZERO 93 | jsr LESS_NUMBER_SIGN 94 | jsr NUMBER_SIGN_S 95 | jsr ROT 96 | jsr SIGN 97 | jsr NUMBER_SIGN_GREATER 98 | jsr TYPE 99 | jmp SPACE 100 | 101 | +BACKLINK "space", 5 102 | SPACE 103 | lda #' ' 104 | jmp PUTCHR 105 | -------------------------------------------------------------------------------- /asm/header.py: -------------------------------------------------------------------------------- 1 | # Verifies that .asm files list their Forth words in the header. 2 | # This is intended as a convenience for human readers. 3 | 4 | import sys 5 | 6 | MAX_LINE_LENGTH = 80 7 | 8 | def verify(path): 9 | lines = open(path).readlines() 10 | 11 | found_header = [] 12 | for line in lines: 13 | if line[0] == ";": 14 | found_header += [line] 15 | else: 16 | break 17 | 18 | words = [] 19 | for line in lines: 20 | if "+BACKLINK" not in line: 21 | continue 22 | start = line.find('"') + 1 23 | end = line.rfind('"') 24 | word = line[start:end] 25 | word = word.replace('\\"', '"') 26 | word = word.upper() 27 | words += [word] 28 | 29 | if not words: 30 | return 31 | 32 | expected_header = [";"] 33 | for word in words: 34 | if len(expected_header[-1]) + len(word) < MAX_LINE_LENGTH: 35 | expected_header[-1] += ' ' + word 36 | else: 37 | expected_header[-1] += '\n' 38 | expected_header += ["; " + word] 39 | expected_header[-1] += '\n' 40 | 41 | if found_header == expected_header: 42 | return 43 | 44 | sys.exit(path + " -- found outdated header! Change it to:\n" + ''.join(expected_header)) 45 | 46 | for path in sys.argv[1:]: 47 | verify(path) 48 | -------------------------------------------------------------------------------- /asm/io.asm: -------------------------------------------------------------------------------- 1 | ; EMIT PAGE RVS CR TYPE KEY? KEY REFILL SOURCE SOURCE-ID >IN CHAR IOABORT 2 | 3 | +BACKLINK "emit", 4 4 | EMIT 5 | lda LSB, x 6 | inx 7 | jmp PUTCHR 8 | 9 | +BACKLINK "page", 4 10 | PAGE 11 | lda #K_CLRSCR 12 | jmp PUTCHR 13 | 14 | +BACKLINK "rvs", 3 15 | RVS ; ( -- ) invert text output 16 | lda #$12 17 | jmp CHROUT 18 | 19 | +BACKLINK "cr", 2 20 | CR ; ( -- ) 21 | lda #$d 22 | jmp CHROUT 23 | 24 | +BACKLINK "type", 4 25 | TYPE ; ( caddr u -- ) 26 | lda #0 ; quote mode off 27 | sta $d4 28 | - lda LSB,x 29 | ora MSB,x 30 | bne + 31 | inx 32 | inx 33 | rts 34 | + jsr OVER 35 | jsr FETCHBYTE 36 | jsr EMIT 37 | jsr ONE 38 | jsr SLASH_STRING 39 | jmp - 40 | 41 | +BACKLINK "key?", 4 42 | lda $c6 ; Number of characters in keyboard buffer 43 | beq + 44 | .pushtrue 45 | lda #$ff 46 | + tay 47 | jmp pushya 48 | 49 | +BACKLINK "key", 3 50 | - lda $c6 51 | beq - 52 | stx W 53 | jsr $e5b4 ; Get character from keyboard buffer 54 | ldx W 55 | ldy #0 56 | jmp pushya 57 | 58 | CLOSE_INPUT_SOURCE 59 | stx W 60 | lda SOURCE_ID_LSB 61 | jsr CLOSE 62 | jsr POP_INPUT_SOURCE 63 | ldx SOURCE_ID_LSB 64 | beq + 65 | jsr CHKIN 66 | jmp ++ 67 | + jsr CLRCHN 68 | ++ ldx W 69 | rts 70 | 71 | +BACKLINK "refill", 6 72 | REFILL ; ( -- flag ) 73 | 74 | ldy #0 75 | sty TO_IN_W 76 | sty TO_IN_W + 1 77 | sty TIB_SIZE 78 | sty TIB_SIZE + 1 79 | 80 | lda SOURCE_ID_LSB 81 | bmi .getLineFromEvaluateString 82 | bne .getLineFromDisk 83 | 84 | ; getLineFromConsole 85 | 86 | stx W 87 | ldx #0 88 | - jsr $e112 ; Input Character 89 | cmp #$d 90 | beq .gotReturn 91 | sta TIB,x 92 | cpx #$58 ; Default TIB area is $200-$258 93 | beq - 94 | inx 95 | jmp - 96 | .gotReturn 97 | jsr PUTCHR 98 | ; Set TIB_SIZE to number of chars fetched. 99 | stx TIB_SIZE 100 | ldx W 101 | .return_true 102 | dex 103 | lda #$ff 104 | sta LSB,x 105 | sta MSB,x 106 | rts 107 | 108 | .getLineFromDisk 109 | jsr READST 110 | bne .return_false ; eof/error 111 | 112 | lda TIB_PTR 113 | sta W 114 | lda TIB_PTR + 1 115 | sta W+1 116 | - stx W2 117 | jsr CHRIN 118 | ldx W2 119 | ora #0 120 | beq .return_true 121 | cmp #K_RETURN 122 | beq .return_true 123 | inc $d020 124 | ldy TIB_SIZE 125 | sta (W),y 126 | inc TIB_SIZE 127 | dec $d020 128 | jmp - 129 | 130 | .return_false 131 | dex 132 | lda #0 133 | sta MSB,x 134 | sta LSB,x 135 | rts 136 | 137 | .getLineFromEvaluateString 138 | lda EVALUATE_STRING_SIZE_LSB 139 | ora EVALUATE_STRING_SIZE_MSB 140 | beq .return_false 141 | 142 | EVALUATE_STRING_PTR_LSB = * + 1 143 | lda #0 144 | sta TIB_PTR 145 | EVALUATE_STRING_PTR_MSB = * + 1 146 | lda #0 147 | sta TIB_PTR + 1 148 | 149 | .grow_tib_to_end_of_line 150 | lda EVALUATE_STRING_PTR_LSB 151 | sta + + 1 152 | lda EVALUATE_STRING_PTR_MSB 153 | sta + + 2 154 | + lda PLACEHOLDER_ADDRESS 155 | tay 156 | 157 | inc EVALUATE_STRING_PTR_LSB 158 | bne + 159 | inc EVALUATE_STRING_PTR_MSB 160 | + 161 | lda EVALUATE_STRING_SIZE_LSB 162 | bne + 163 | dec EVALUATE_STRING_SIZE_MSB 164 | + dec EVALUATE_STRING_SIZE_LSB 165 | 166 | tya 167 | cmp #$d 168 | beq .return_true 169 | 170 | inc TIB_SIZE 171 | bne + 172 | inc TIB_SIZE + 1 173 | + 174 | EVALUATE_STRING_SIZE_LSB = * + 1 175 | lda #0 176 | EVALUATE_STRING_SIZE_MSB = * + 1 177 | ora #0 178 | bne .grow_tib_to_end_of_line 179 | jmp .return_true 180 | 181 | +BACKLINK "source", 6 182 | SOURCE 183 | dex 184 | dex 185 | lda TIB_PTR 186 | sta LSB+1, x 187 | lda TIB_PTR + 1 188 | sta MSB+1, x 189 | lda TIB_SIZE 190 | sta LSB, x 191 | lda TIB_SIZE + 1 192 | sta MSB, x 193 | rts 194 | 195 | TIB_PTR 196 | !word 0 197 | TIB_SIZE 198 | !word 0 199 | 200 | +BACKLINK "source-id", 9 201 | SOURCE_ID_LSB = * + 1 202 | SOURCE_ID_MSB = * + 3 203 | ; -1 : string (via evaluate) 204 | ; 0 : keyboard 205 | ; 1+ : file id 206 | +VALUE 0 207 | 208 | +BACKLINK ">in", 3 209 | TO_IN 210 | +VALUE TO_IN_W 211 | TO_IN_W 212 | !word 0 213 | 214 | +BACKLINK "char", 4 215 | CHAR ; ( name -- char ) 216 | jsr PARSE_NAME 217 | inx 218 | jmp FETCHBYTE 219 | 220 | SAVE_INPUT_STACK 221 | ; Forth standard 11.3.3 "Input Source": 222 | ; "Input [...] shall be nestable in any order to at least eight levels." 223 | ; Eight levels is overkill for INCLUDED, since opening more than four DOS 224 | ; channels gives a "no channel" error message on C64. 225 | ; It is anyway nice to keep some extra levels for EVALUATE and LOAD. 226 | !fill 8*12 227 | SAVE_INPUT_STACK_DEPTH 228 | !byte 0 229 | 230 | push_input_stack 231 | ; Stack overflow check could be added, but does not seem needed in practice. 232 | ldy SAVE_INPUT_STACK_DEPTH 233 | sta SAVE_INPUT_STACK, y 234 | inc SAVE_INPUT_STACK_DEPTH 235 | rts 236 | 237 | pop_input_stack 238 | dec SAVE_INPUT_STACK_DEPTH 239 | ldy SAVE_INPUT_STACK_DEPTH 240 | lda SAVE_INPUT_STACK, y 241 | rts 242 | 243 | PUSH_INPUT_SOURCE 244 | lda TO_IN_W 245 | jsr push_input_stack 246 | lda TO_IN_W+1 247 | jsr push_input_stack 248 | lda SOURCE_ID_LSB 249 | jsr push_input_stack 250 | lda SOURCE_ID_MSB 251 | jsr push_input_stack 252 | lda TIB_PTR 253 | jsr push_input_stack 254 | lda TIB_PTR+1 255 | jsr push_input_stack 256 | lda TIB_SIZE 257 | jsr push_input_stack 258 | lda TIB_SIZE+1 259 | jsr push_input_stack 260 | lda EVALUATE_STRING_PTR_LSB 261 | jsr push_input_stack 262 | lda EVALUATE_STRING_PTR_MSB 263 | jsr push_input_stack 264 | lda EVALUATE_STRING_SIZE_LSB 265 | jsr push_input_stack 266 | lda EVALUATE_STRING_SIZE_MSB 267 | jmp push_input_stack 268 | 269 | POP_INPUT_SOURCE 270 | jsr pop_input_stack 271 | sta EVALUATE_STRING_SIZE_MSB 272 | jsr pop_input_stack 273 | sta EVALUATE_STRING_SIZE_LSB 274 | jsr pop_input_stack 275 | sta EVALUATE_STRING_PTR_MSB 276 | jsr pop_input_stack 277 | sta EVALUATE_STRING_PTR_LSB 278 | jsr pop_input_stack 279 | sta TIB_SIZE+1 280 | jsr pop_input_stack 281 | sta TIB_SIZE 282 | jsr pop_input_stack 283 | sta TIB_PTR+1 284 | jsr pop_input_stack 285 | sta TIB_PTR 286 | jsr pop_input_stack 287 | sta SOURCE_ID_MSB 288 | jsr pop_input_stack 289 | sta SOURCE_ID_LSB 290 | jsr pop_input_stack 291 | sta TO_IN_W+1 292 | jsr pop_input_stack 293 | sta TO_IN_W 294 | rts 295 | 296 | ; handle errors returned by open, 297 | ; close, and chkin. If ioresult is 298 | ; nonzero, print error message and 299 | ; throw -37. 300 | +BACKLINK "ioabort", 7 301 | IOABORT ; ( ioresult -- ) 302 | inx 303 | lda MSB-1,x 304 | bne .print_ioerr 305 | lda LSB-1,x 306 | bne + 307 | rts 308 | + cmp #10 309 | bcc .print_basic_error 310 | 311 | .print_ioerr 312 | lda #<.ioerr 313 | sta W 314 | lda #>.ioerr 315 | sta W+1 316 | jmp .print_msb_terminated_string 317 | 318 | .ioerr 319 | !text "ioer" 320 | !byte 'r'|$80 321 | 322 | .print_basic_error 323 | ; switch in BASIC ROM 324 | lda #$37 325 | sta 1 326 | 327 | lda LSB-1,x 328 | asl 329 | tax 330 | lda $a326,x 331 | sta W 332 | lda $a327,x 333 | sta W+1 334 | 335 | .print_msb_terminated_string 336 | jsr CLRCHN 337 | jsr RVS 338 | 339 | ldy #0 340 | - lda (W),y 341 | pha 342 | and #$7f 343 | jsr CHROUT 344 | iny 345 | pla 346 | bpl - 347 | 348 | lda #-37 ; file i/o exception 349 | jmp throw_a 350 | -------------------------------------------------------------------------------- /asm/lowercase.asm: -------------------------------------------------------------------------------- 1 | CHAR_TO_LOWERCASE ; ( a -- a ) 2 | cmp #'A' 3 | bcc + 4 | cmp #'Z' + 1 5 | bcs + 6 | sbc #'A' - 'a' - 1 7 | + rts 8 | -------------------------------------------------------------------------------- /asm/math.asm: -------------------------------------------------------------------------------- 1 | ; U< - UM* UM/MOD M+ INVERT NEGATE ABS * DNEGATE M* 0< S>D FM/MOD /MOD UD/MOD 2 | 3 | ; UM/MOD by Garth Wilson 4 | ; http://6502.org/source/integers/ummodfix/ummodfix.htm 5 | 6 | +BACKLINK "u<", 2 7 | U_LESS 8 | ldy #0 9 | lda MSB, x 10 | cmp MSB + 1, x 11 | bcc .false 12 | bne .true 13 | ; ok, msb are equal... 14 | lda LSB + 1, x 15 | cmp LSB, x 16 | bcs .false 17 | .true 18 | dey 19 | .false 20 | inx 21 | sty MSB, x 22 | sty LSB, x 23 | rts 24 | 25 | +BACKLINK "-", 1 26 | MINUS 27 | lda LSB + 1, x 28 | sec 29 | sbc LSB, x 30 | sta LSB + 1, x 31 | 32 | lda MSB + 1, x 33 | sbc MSB, x 34 | sta MSB + 1, x 35 | 36 | inx 37 | rts 38 | 39 | product = W 40 | 41 | +BACKLINK "um*", 3 42 | ; wastes W, W2, y 43 | U_M_STAR 44 | lda #$00 45 | sta product+2 ; clear upper bits of product 46 | sta product+3 47 | ldy #$10 ; set binary count to 16 48 | .shift_r 49 | lsr MSB + 1, x ; multiplier+1 ; divide multiplier by 2 50 | ror LSB + 1, x ; multiplier 51 | bcc rotate_r 52 | lda product+2 ; get upper half of product and add multiplicand 53 | clc 54 | adc LSB, x ; multiplicand 55 | sta product+2 56 | lda product+3 57 | adc MSB, x ; multiplicand+1 58 | rotate_r 59 | ror ; rotate partial product 60 | sta product+3 61 | ror product+2 62 | ror product+1 63 | ror product 64 | dey 65 | bne .shift_r 66 | 67 | lda product 68 | sta LSB + 1, x 69 | lda product + 1 70 | sta MSB + 1, x 71 | lda product + 2 72 | sta LSB, x 73 | lda product + 3 74 | sta MSB, x 75 | rts 76 | 77 | +BACKLINK "um/mod", 6 78 | UM_DIV_MOD 79 | ; ( lsw msw divisor -- rem quot ) 80 | ; Wastes W, lo(W2) 81 | N = W 82 | SEC 83 | LDA LSB+1,X ; Subtract hi cell of dividend by 84 | SBC LSB,X ; divisor to see if there's an overflow condition. 85 | LDA MSB+1,X 86 | SBC MSB,X 87 | BCS oflo ; Branch if /0 or overflow. 88 | 89 | LDA #17 ; Loop 17x. 90 | STA N ; Use N for loop counter. 91 | loop: ROL LSB+2,X ; Rotate dividend lo cell left one bit. 92 | ROL MSB+2,X 93 | DEC N ; Decrement loop counter. 94 | BEQ end ; If we're done, then branch to end. 95 | ROL LSB+1,X ; Otherwise rotate dividend hi cell left one bit. 96 | ROL MSB+1,X 97 | lda #0 98 | sta N+1 99 | ROL N+1 ; Rotate the bit carried out of above into N+1. 100 | 101 | SEC 102 | LDA LSB+1,X ; Subtract dividend hi cell minus divisor. 103 | SBC LSB,X 104 | STA N+2 ; Put result temporarily in N+2 (lo byte) 105 | LDA MSB+1,X 106 | SBC MSB,X 107 | TAY ; and Y (hi byte). 108 | LDA N+1 ; Remember now to bring in the bit carried out above. 109 | SBC #0 110 | BCC loop 111 | 112 | LDA N+2 ; If that didn't cause a borrow, 113 | STA LSB+1,X ; make the result from above to 114 | STY MSB+1,X ; be the new dividend hi cell 115 | bcs loop ; and then branch up. 116 | 117 | oflo: ; if overflow or /0 condition found, throw division by zero error. 118 | lda #-10 119 | jmp throw_a 120 | 121 | end: INX 122 | jmp SWAP 123 | 124 | +BACKLINK "m+", 2 125 | M_PLUS 126 | ldy #0 127 | lda MSB,x 128 | bpl + 129 | dey 130 | + clc 131 | lda LSB,x 132 | adc LSB+2,x 133 | sta LSB+2,x 134 | lda MSB,x 135 | adc MSB+2,x 136 | sta MSB+2,x 137 | tya 138 | adc LSB+1,x 139 | sta LSB+1,x 140 | tya 141 | adc MSB+1,x 142 | sta MSB+1,x 143 | inx 144 | rts 145 | 146 | +BACKLINK "invert", 6 147 | INVERT 148 | lda MSB, x 149 | eor #$ff 150 | sta MSB, x 151 | lda LSB, x 152 | eor #$ff 153 | sta LSB,x 154 | rts 155 | 156 | +BACKLINK "negate", 6 157 | NEGATE 158 | jsr INVERT 159 | jmp ONEPLUS 160 | 161 | +BACKLINK "abs", 3 162 | ABS 163 | lda MSB,x 164 | bmi NEGATE 165 | rts 166 | 167 | DABS_STAR ; ( n1 n2 -- ud1 ) 168 | lda MSB,x ; ud1 = abs(n1) * abs(n2) 169 | eor MSB+1,x ; with final sign output in A register 170 | pha 171 | jsr ABS 172 | inx 173 | jsr ABS 174 | dex 175 | jsr U_M_STAR 176 | pla 177 | rts 178 | 179 | +BACKLINK "*", 1 180 | jsr DABS_STAR 181 | inx 182 | and #$ff 183 | bmi NEGATE 184 | rts 185 | 186 | +BACKLINK "dnegate", 7 187 | DNEGATE 188 | jsr INVERT 189 | inx 190 | jsr INVERT 191 | dex 192 | inc LSB+1,x 193 | bne + 194 | inc MSB+1,x 195 | bne + 196 | inc LSB,x 197 | bne + 198 | inc MSB,x 199 | + rts 200 | 201 | +BACKLINK "m*", 2 202 | jsr DABS_STAR 203 | bmi DNEGATE 204 | rts 205 | 206 | +BACKLINK "0<", 2 207 | ZERO_LESS 208 | lda MSB,x 209 | and #$80 210 | beq + 211 | lda #$ff 212 | + sta MSB,x 213 | sta LSB,x 214 | rts 215 | 216 | +BACKLINK "s>d", 3 217 | S_TO_D 218 | jsr DUP 219 | jmp ZERO_LESS 220 | 221 | +BACKLINK "fm/mod", 6 222 | FM_DIV_MOD 223 | lda MSB,x 224 | sta DIVISOR_SIGN 225 | bpl + 226 | jsr NEGATE 227 | inx 228 | jsr DNEGATE 229 | dex 230 | + lda MSB+1,x 231 | bpl + 232 | jsr TUCK 233 | jsr PLUS 234 | jsr SWAP 235 | + jsr UM_DIV_MOD 236 | DIVISOR_SIGN = * + 1 237 | lda #$ff ; placeholder 238 | bpl + 239 | inx 240 | jsr NEGATE 241 | dex 242 | + rts 243 | 244 | +BACKLINK "/mod", 4 245 | lda MSB,x 246 | sta MSB-1,x 247 | lda LSB,x 248 | sta LSB-1,x 249 | inx 250 | jsr S_TO_D 251 | dex 252 | jmp FM_DIV_MOD 253 | 254 | ; (ud1 u2 -- urem udquot) 255 | +BACKLINK "ud/mod", 6 256 | UD_MOD 257 | lda LSB,x 258 | sta LSB - 1,x 259 | sta W3 260 | lda MSB,x 261 | sta MSB - 1,x 262 | sta W3 + 1 ; cache the divisor 263 | lda #0 264 | sta LSB,x 265 | sta MSB,x 266 | dex 267 | jsr UM_DIV_MOD ; divide the high word 268 | lda LSB,x 269 | pha 270 | lda MSB,x 271 | pha ; cache the high word of quotient 272 | lda W3 ; uncache the divisor 273 | sta LSB,x 274 | lda W3 + 1 275 | sta MSB,x 276 | jsr UM_DIV_MOD ; divide the low byte 277 | dex 278 | pla ; push the high word of quotient 279 | sta MSB,x 280 | pla 281 | sta LSB,x 282 | rts 283 | -------------------------------------------------------------------------------- /asm/move.asm: -------------------------------------------------------------------------------- 1 | ; MOVE 2 | 3 | ; routines adapted from cc65 4 | ; original by Ullrich von Bassewitz, Christian Krueger, Greg King 5 | 6 | SRC = W 7 | DST = W2 8 | LEN = W3 9 | 10 | cmove_getparams: 11 | lda LSB, x 12 | sta LEN 13 | lda MSB, x 14 | sta LEN + 1 15 | lda LSB + 1, x 16 | sta DST 17 | lda MSB + 1, x 18 | sta DST + 1 19 | lda LSB + 2, x 20 | sta SRC 21 | lda MSB + 2, x 22 | sta SRC + 1 23 | rts 24 | 25 | CMOVE_BACK 26 | txa 27 | pha 28 | jsr cmove_getparams 29 | ; copy downwards. adjusts pointers to the end of memory regions. 30 | lda SRC + 1 31 | clc 32 | adc LEN + 1 33 | sta SRC + 1 34 | lda DST + 1 35 | clc 36 | adc LEN + 1 37 | sta DST + 1 38 | 39 | ldy LEN 40 | bne .entry 41 | beq .pagesizecopy 42 | .copybyte 43 | lda (SRC),y 44 | sta (DST),y 45 | .entry 46 | dey 47 | bne .copybyte 48 | lda (SRC),y 49 | sta (DST),y 50 | .pagesizecopy 51 | ldx LEN + 1 52 | beq cmove_done 53 | .initbase 54 | dec SRC + 1 55 | dec DST + 1 56 | dey 57 | .copybytes 58 | lda (SRC),y 59 | sta (DST),y 60 | dey 61 | lda (SRC),y 62 | sta (DST),y 63 | dey 64 | lda (SRC),y 65 | sta (DST),y 66 | dey 67 | bne .copybytes 68 | lda (SRC),y 69 | sta (DST),y 70 | dex 71 | bne .initbase 72 | jmp cmove_done 73 | 74 | CMOVE 75 | txa 76 | pha 77 | jsr cmove_getparams 78 | ldy #0 79 | ldx LEN + 1 80 | beq .l2 81 | .l1 82 | lda (SRC),y ; copy byte 83 | sta (DST),y 84 | iny 85 | lda (SRC),y ; copy byte again, to make it faster 86 | sta (DST),y 87 | iny 88 | bne .l1 89 | inc SRC + 1 90 | inc DST + 1 91 | dex ; next 256-byte block 92 | bne .l1 93 | .l2 94 | ldx LEN 95 | beq cmove_done 96 | .l3 97 | lda (SRC),y 98 | sta (DST),y 99 | iny 100 | dex 101 | bne .l3 102 | cmove_done 103 | pla 104 | clc 105 | adc #3 106 | tax 107 | rts 108 | 109 | +BACKLINK "move", 4 110 | MOVE 111 | jsr TO_R 112 | jsr TWODUP 113 | jsr U_LESS 114 | jsr R_TO 115 | jsr SWAP 116 | jsr ZBRANCH 117 | !word .br 118 | jmp CMOVE_BACK 119 | .br = * 120 | jmp CMOVE 121 | -------------------------------------------------------------------------------- /forth/.gitignore: -------------------------------------------------------------------------------- 1 | *.pet 2 | -------------------------------------------------------------------------------- /forth/accept.fs: -------------------------------------------------------------------------------- 1 | 0 value addr 2 | : accept ( addr avail -- len ) 3 | 0 $cc ( enable cursor-blink ) c! 4 | swap to addr 0 ( avail len ) 5 | begin key case 6 | \ return and delete: 7 | $0d of nip space 1 $cc c! exit endof 8 | $14 of dup if 1- $14 emit then endof 9 | \ ( avail len char ) add to buffer? 10 | >r 2dup > r@ $7f and $1f > and if 11 | r@ over addr + c! 1+ r@ emit then r> 12 | endcase again ; 13 | hide addr 14 | -------------------------------------------------------------------------------- /forth/asm.fs: -------------------------------------------------------------------------------- 1 | : 1mi create c, does> c@ c, ; 2 | : 2mi create c, does> c@ c, c, ; 3 | : 3mi create c, does> c@ c, , ; 4 | : 23mi create , does> 5 | over $ff00 and if c@ c, , 6 | else 1+ c@ c, c, then ; 7 | 8 | $69 2mi adc,# 9 | $656d 23mi adc, 10 | $757d 23mi adc,x 11 | $79 3mi adc,y 12 | $61 2mi adc,(x) 13 | $71 2mi adc,(y) 14 | 15 | $29 2mi and,# 16 | $252d 23mi and, 17 | $353d 23mi and,x 18 | $39 3mi and,y 19 | $21 2mi and,(x) 20 | $31 2mi and,(y) 21 | 22 | $a 1mi asl,a 23 | $060e 23mi asl, 24 | $161e 23mi asl,x 25 | 26 | $90 2mi bcc, 27 | $b0 2mi bcs, 28 | $f0 2mi beq, 29 | 30 | $242c 23mi bit, 31 | 32 | $30 2mi bmi, 33 | $d0 2mi bne, 34 | $10 2mi bpl, 35 | $0 1mi brk, 36 | $50 2mi bvc, 37 | $70 2mi bvs, 38 | $18 1mi clc, 39 | $d8 1mi cld, 40 | $58 1mi cli, 41 | $b8 1mi clv, 42 | 43 | $c9 2mi cmp,# 44 | $c5cd 23mi cmp, 45 | $d5dd 23mi cmp,x 46 | $d9 3mi cmp,y 47 | $c1 2mi cmp,(x) 48 | $d1 2mi cmp,(y) 49 | 50 | $e0 2mi cpx,# 51 | $e4ec 23mi cpx, 52 | 53 | $c0 2mi cpy,# 54 | $c4cc 23mi cpy, 55 | 56 | $c6ce 23mi dec, 57 | $d6de 23mi dec,x 58 | 59 | $ca 1mi dex, 60 | $88 1mi dey, 61 | 62 | $49 2mi eor,# 63 | $454d 23mi eor, 64 | $555d 23mi eor,x 65 | $59 3mi eor,y 66 | $41 2mi eor,(x) 67 | $51 2mi eor,(y) 68 | 69 | $e6ee 23mi inc, 70 | $f6fe 23mi inc,x 71 | 72 | $e8 1mi inx, 73 | $c8 1mi iny, 74 | 75 | $4c 3mi jmp, 76 | $6c 3mi (jmp), 77 | 78 | $20 3mi jsr, 79 | 80 | $a9 2mi lda,# 81 | $a5ad 23mi lda, 82 | $b5bd 23mi lda,x 83 | $b9 3mi lda,y 84 | $a1 2mi lda,(x) 85 | $b1 2mi lda,(y) 86 | 87 | $a2 2mi ldx,# 88 | $a6ae 23mi ldx, 89 | $b6be 23mi ldx,y 90 | 91 | $a0 2mi ldy,# 92 | $a4ac 23mi ldy, 93 | $b4bc 23mi ldy,x 94 | 95 | $4a 1mi lsr,a 96 | $464e 23mi lsr, 97 | $565e 23mi lsr,x 98 | 99 | $ea 1mi nop, 100 | 101 | $9 2mi ora,# 102 | $050d 23mi ora, 103 | $151d 23mi ora,x 104 | $19 3mi ora,y 105 | $1 2mi ora,(x) 106 | $11 2mi ora,(y) 107 | 108 | $48 1mi pha, 109 | $8 1mi php, 110 | $68 1mi pla, 111 | $28 1mi plp, 112 | 113 | $2a 1mi rol,a 114 | $262e 23mi rol, 115 | $363e 23mi rol,x 116 | 117 | $6a 1mi ror,a 118 | $666e 23mi ror, 119 | $767e 23mi ror,x 120 | 121 | $40 1mi rti, 122 | $60 1mi rts, 123 | 124 | $e9 2mi sbc,# 125 | $e5ed 23mi sbc, 126 | $f5fd 23mi sbc,x 127 | $f9 3mi sbc,y 128 | $e1 2mi sbc,(x) 129 | $f1 2mi sbc,(y) 130 | 131 | $38 1mi sec, 132 | $f8 1mi sed, 133 | $78 1mi sei, 134 | 135 | $858d 23mi sta, 136 | $959d 23mi sta,x 137 | $99 3mi sta,y 138 | $81 2mi sta,(x) 139 | $91 2mi sta,(y) 140 | 141 | $868e 23mi stx, 142 | $96 2mi stx,y 143 | 144 | $848c 23mi sty, 145 | $94 2mi sty,x 146 | 147 | $aa 1mi tax, 148 | $a8 1mi tay, 149 | $ba 1mi tsx, 150 | $8a 1mi txa, 151 | $9a 1mi txs, 152 | $98 1mi tya, 153 | 154 | \ illegal opcodes 155 | $cb 2mi sbx,# 156 | 157 | : code header ; 158 | : end-code ; 159 | 160 | ( usage: 161 | foo lda, 162 | +branch beq, 163 | bar inc, 164 | :+ ) 165 | : +branch ( -- a ) here 0 ; 166 | : :+ ( a -- ) 167 | here over 2+ - swap 1+ c! ; 168 | 169 | ( usage: 170 | :- $d014 lda, f4 cmp,# 171 | -branch bne, ) 172 | : :- here ; 173 | : -branch ( absaddr -- reladdr ) 174 | here 2+ - ; 175 | -------------------------------------------------------------------------------- /forth/base.fs: -------------------------------------------------------------------------------- 1 | : 2+ 1+ 1+ ; 2 | : jmp, 4c c, ; 3 | : postpone bl word dup find ?dup 0= if 4 | count notfound then 5 | rot drop -1 = if [ ' literal compile, 6 | ' compile, literal ] then compile, 7 | ; immediate 8 | : ['] ' postpone literal ; immediate 9 | : [char] char postpone literal 10 | ; immediate 11 | : else jmp, here 0 , 12 | swap here swap ! ; immediate 13 | : until postpone 0branch , ; immediate 14 | : again jmp, , ; immediate 15 | : recurse 16 | latestxt compile, ; immediate 17 | 18 | : \ source >in ! drop ; immediate 19 | : <> = 0= ; 20 | : u> swap u< ; 21 | : 0<> 0= 0= ; 22 | 23 | : parse >r source >in @ /string 24 | over swap begin dup while over c@ r@ <> 25 | while 1 /string repeat then r> drop >r 26 | over - dup r> if 1+ then >in +! ; 27 | 28 | : ( source-id 0= if ')' parse drop drop 29 | else begin >in @ ')' parse nip >in @ rot 30 | - = while refill drop repeat then ; 31 | immediate 32 | 33 | : lits ( -- addr len ) 34 | r> 1+ count 2dup + 1- >r ; 35 | 36 | ( "0 to foo" sets value foo to 0 ) 37 | : (to) >r split r@ 2+ c! r> c! ; 38 | : to ' 1+ state c@ if 39 | postpone literal postpone (to) exit 40 | then (to) ; immediate 41 | 42 | : allot ( n -- ) here + to here ; 43 | 44 | : s" ( -- addr len ) 45 | '"' parse state @ if postpone lits 46 | dup c, tuck here swap move allot 47 | then ; immediate 48 | 49 | : ." postpone s" postpone type 50 | ; immediate 51 | : .( ')' parse type ; immediate 52 | .( compile base..) 53 | 54 | : case 0 ; immediate 55 | : (of) over = if drop r> 2+ >r exit 56 | then branch ; 57 | : of postpone (of) here 0 , ; immediate 58 | : endof postpone else ; immediate 59 | : endcase postpone drop 60 | begin ?dup while postpone then 61 | repeat ; immediate 62 | 63 | ( dodoes words contain: 64 | 1. jsr dodoes 65 | 2. two-byte code pointer. default: rts 66 | 3. variable length data ) 67 | here 60 c, ( rts ) 68 | : create 69 | header postpone dodoes literal , ; 70 | : does> r> 1+ latest >xt 1+ 2+ ! ; 71 | 72 | .( asm..) 73 | parse-name asm included 74 | 75 | : -rot rot rot ; 76 | 77 | ( creates value that is fast to read 78 | but can only be rewritten by "to". 79 | 0 value foo 80 | foo . \ prints 0 81 | 1 to foo 82 | foo . \ prints 1 ) 83 | : value ( n -- ) 84 | ( TO relies on this lda/ldy order ) 85 | code split swap lda,# ldy,# 86 | ['] pushya jmp, ; 87 | : constant value ; 88 | ( to free up space, pad could be 89 | e.g. HERE+34 instead ) 90 | $35b constant pad 91 | : spaces ( n -- ) 92 | begin ?dup while space 1- repeat ; 93 | 94 | 8b value w 95 | 8d value w2 96 | 9e value w3 97 | 98 | : hex 10 base ! ; 99 | : decimal a base ! ; 100 | 101 | : 2drop ( a b -- ) 102 | postpone drop postpone drop ; immediate 103 | 104 | 105 | : save-forth ( strptr strlen -- ) 106 | 801 $a000 d word count saveb ; 107 | 108 | code 2/ 109 | msb lda,x 80 cmp,# msb ror,x lsb ror,x 110 | rts, end-code 111 | code or 112 | msb lda,x msb 1+ ora,x msb 1+ sta,x 113 | lsb lda,x lsb 1+ ora,x lsb 1+ sta,x 114 | inx, rts, end-code 115 | code xor 116 | msb lda,x msb 1+ eor,x msb 1+ sta,x 117 | lsb lda,x lsb 1+ eor,x lsb 1+ sta,x 118 | inx, rts, end-code 119 | 120 | :- dup inx, rts, end-code 121 | code lshift ( x1 u -- x2 ) 122 | lsb dec,x -branch bmi, 123 | lsb 1+ asl,x msb 1+ rol,x 124 | latest >xt jmp, 125 | code rshift ( x1 u -- x2 ) 126 | lsb dec,x -branch bmi, 127 | msb 1+ lsr,x lsb 1+ ror,x 128 | latest >xt jmp, 129 | 130 | : variable 131 | 0 value 132 | here latest >xt 1+ (to) 133 | 2 allot ; 134 | 135 | ( from FIG UK... ) 136 | : / /mod nip ; 137 | : mod /mod drop ; 138 | : */mod >r m* r> fm/mod ; 139 | : */ */mod nip ; 140 | ( ...from FIG UK ) 141 | 142 | : .s depth begin ?dup while 143 | dup pick . 1- repeat ; 144 | 145 | : abort -1 throw ; 146 | : abort" postpone if 147 | postpone s" postpone (abort") 148 | postpone then ; immediate 149 | 150 | ( linked list. each element contains 151 | backlink + hashed file name ) 152 | 0 value (includes) 153 | 154 | : marker ( -- ) 155 | (includes) latest here create , , , 156 | does> dup @ to here 157 | 2+ dup @ to latest 158 | 2+ @ to (includes) ; 159 | 160 | : include parse-name included ; 161 | 162 | : :noname here here to latestxt ] ; 163 | 164 | marker ---modules--- 165 | 166 | .( wordlist..) include wordlist 167 | 168 | \ hides private words 169 | hide 1mi hide 2mi hide 23mi hide 3mi 170 | hide latestxt 171 | hide dodoes hide (abort") 172 | 173 | .( labels..) include labels 174 | .( doloop..) include doloop 175 | .( sys..) include sys 176 | .( debug..) include debug 177 | .( ls..) include ls 178 | .( require..) include require 179 | .( open..) include open 180 | .( accept..) include accept 181 | .( v..) include v 182 | 183 | decimal 184 | include turnkey 185 | cr 186 | .( cart: ) 187 | $4000 $6b - \ available ROM 188 | here $801 - \ code + data 189 | top 1+ latest - \ dictionary 190 | $20 + + - \ save-pack padding 191 | . .( bytes remain.) cr 192 | 193 | .( save new durexforth..) 194 | save-pack @0:durexforth 195 | .( ok!) cr 196 | 197 | 0 $d7ff c! \ for vice -debugcart 198 | -------------------------------------------------------------------------------- /forth/compat.fs: -------------------------------------------------------------------------------- 1 | \ forth2012 compatibility stuff 2 | 3 | -1 constant true 4 | 0 constant false 5 | 6 | code 2over ( a b c d -- a b c d a b ) 7 | dex, 8 | msb 4 + lda,x msb sta,x 9 | lsb 4 + lda,x lsb sta,x 10 | dex, 11 | msb 4 + lda,x msb sta,x 12 | lsb 4 + lda,x lsb sta,x rts, end-code 13 | code 2swap ( a b c d -- c d a b ) 14 | lsb lda,x lsb 2+ ldy,x 15 | lsb sty,x lsb 2+ sta,x 16 | msb lda,x msb 2+ ldy,x 17 | msb sty,x msb 2+ sta,x 18 | lsb 1+ lda,x lsb 3 + ldy,x 19 | lsb 1+ sty,x lsb 3 + sta,x 20 | msb 1+ lda,x msb 3 + ldy,x 21 | msb 1+ sty,x msb 3 + sta,x rts, end-code 22 | 23 | : environment? 2drop 0 ; 24 | : cells 2* ; 25 | : cell+ 2+ ; 26 | : char+ 1+ ; 27 | : chars ; : align ; : aligned ; 28 | 29 | : 2@ ( addr -- x1 x2 ) 30 | dup 2+ @ swap @ ; 31 | : 2! ( x1 x2 addr -- ) 32 | swap over ! 2+ ! ; 33 | 34 | : 0> 0 > ; 35 | 36 | code d+ ( d1 d2 -- d3 ) 37 | clc, 38 | lsb 1+ lda,x lsb 3 + adc,x lsb 3 + sta,x 39 | msb 1+ lda,x msb 3 + adc,x msb 3 + sta,x 40 | lsb lda,x lsb 2+ adc,x lsb 2+ sta,x 41 | msb lda,x msb 2+ adc,x msb 2+ sta,x 42 | inx, inx, rts, end-code 43 | 44 | : accumulate ( +d0 addr digit - +d1 addr ) 45 | swap >r swap base @ um* drop 46 | rot base @ um* d+ r> ; 47 | 48 | : pet# ( char -- num ) 49 | $7f and dup \ lowercase 50 | ':' < if '0' else '7' then - ; 51 | 52 | : >number ( ud addr u -- ud addr u ) 53 | begin over c@ pet# base @ u< over and 54 | while >r dup c@ pet# accumulate 55 | 1+ r> 1- repeat ; 56 | 57 | \ from FIG UK 58 | : ?negate 0< if negate then ; 59 | : ?dnegate 0< if dnegate then ; 60 | : dabs dup ?dnegate ; 61 | : sm/rem 62 | 2dup xor >r over >r abs >r dabs 63 | r> um/mod swap r> ?negate 64 | swap r> ?negate ; 65 | 66 | : >body ( xt -- dataaddr ) 5 + ; 67 | : defer create ['] abort , 68 | does> @ execute ; 69 | : defer! >body ! ; 70 | : is state @ if 71 | postpone ['] postpone defer! 72 | else ' defer! then ; immediate 73 | -------------------------------------------------------------------------------- /forth/debug.fs: -------------------------------------------------------------------------------- 1 | :noname ( xt xt-1 nt -- xt xt-1 1 | xt xt-1 0 ) 2 | >xt dup 3 pick 3 | > if ( xt xt-1 xt0 ) 4 | 2dup < if drop else 5 | nip then 1 exit then drop 1 ; 6 | 7 | : size ( word -- ) 8 | ' here literal dowords 9 | swap - . cr ; 10 | 11 | variable last-dump 12 | 13 | : dump ( addr -- ) 14 | base @ swap hex 15 | 8 0 do dup u. 16 | dup 8 0 do dup c@ 0 <# # # #> type 17 | space 1+ loop drop 18 | 8 0 do dup c@ 19 | dup $7f and $20 < if drop '.' then 20 | emit 1+ loop cr loop 21 | last-dump ! base ! ; 22 | : n last-dump @ dump ; 23 | hide last-dump 24 | 25 | : more 26 | $d6 c@ $18 = if $12 emit 27 | ." more" $92 emit key drop page then ; 28 | 29 | : name>string ( nametoken -- caddr u ) 30 | count $1f and ; 31 | :noname more name>string type space 1 ; 32 | : words page literal dowords ; 33 | -------------------------------------------------------------------------------- /forth/demo/charrom.fs: -------------------------------------------------------------------------------- 1 | 2 | 3 | ( how to modify char ROM font ) 4 | : chardemo 5 | ( switch in char ROM ) 6 | [ sei, 2 base ! ] 7 | 1 c@ 11111000 and 11 or 1 c! 8 | 9 | ( copy char ROM to $7800 ) 10 | [ hex ] d800 7800 800 move 11 | 12 | ( switch back I/O + kernal ) 13 | [ 2 base ! ] 14 | 1 c@ 11111000 and 110 or 1 c! 15 | [ cli, ] 16 | 17 | ( set vic bank to $4000-$7fff ) 18 | [ hex ] dd00 c@ 19 | [ 2 base ! ] 11111100 and 10 or 20 | [ hex ] dd00 c! 21 | 22 | ( set vic text screen = $7400, 23 | vic character data = $7800 ) 24 | de d018 c! 25 | 26 | ( fill text screen ) 27 | 7800 7400 do i dup c! loop 28 | 29 | ( invert font forever ) 30 | begin 31 | 8000 7800 do i c@ invert i c! loop 32 | again ; 33 | -------------------------------------------------------------------------------- /forth/doloop.fs: -------------------------------------------------------------------------------- 1 | code (do) ( limit first -- ) 2 | pla, w sta, 3 | pla, tay, 4 | 5 | msb 1+ lda,x pha, lsb 1+ lda,x pha, 6 | msb lda,x pha, lsb lda,x pha, 7 | inx, inx, 8 | 9 | tya, pha, 10 | w lda, pha, 11 | rts, end-code 12 | 13 | \ leave stack 14 | variable lstk $14 allot 15 | variable lsp lstk lsp ! 16 | : >l ( n -- ) lsp @ ! 2 lsp +! ; 17 | 18 | : do 0 19 | postpone (do) here dup >l ; immediate 20 | 21 | : (?do) 22 | 2dup = if 2drop [ ' branch jmp, ] else 23 | r> 2+ >r [ ' (do) jmp, ] then ; 24 | 25 | : ?do 26 | postpone (?do) here 0 , 27 | here dup >l ; immediate 28 | 29 | : leave 30 | postpone unloop 31 | here 1+ >l 0 jmp, ; immediate 32 | 33 | : resolve-leaves ( ?dopos dopos -- ) 34 | begin -2 lsp +! 35 | dup lsp @ @ < while 36 | here lsp @ @ ! repeat drop 37 | \ ?do forward branch 38 | ?dup if here swap ! then ; 39 | 40 | code (loop) 41 | w stx, tsx, \ x = stack pointer 42 | $103 inc,x 3 bne, $104 inc,x \ i++ 43 | $103 lda,x $105 cmp,x 1 @@ beq, \ lsb 44 | 2 @: 45 | \ not done, branch back 46 | w ldx, \ restore x 47 | ' branch jmp, 48 | 1 @: 49 | $104 lda,x $106 cmp,x 2 @@ bne, \ msb 50 | \ loop done 51 | \ skip branch addr 52 | pla, clc, 3 adc,# w2 sta, 53 | pla, 0 adc,# w2 1+ sta, 54 | txa, clc, 6 adc,# tax, txs, \ sp += 6 55 | w ldx, \ restore x 56 | w2 (jmp), 57 | 58 | : loop 59 | postpone (loop) dup , resolve-leaves ; immediate 60 | 61 | : (+loop) ( inc -- ) 62 | r> swap r> 2dup + 63 | rot 0< if tuck swap else tuck then 64 | r@ 1- -rot within 0= if 65 | >r >r [ ' branch jmp, ] then 66 | r> 2drop 2+ >r ; 67 | 68 | : +loop 69 | postpone (+loop) dup , resolve-leaves ; immediate 70 | 71 | : i postpone r@ ; immediate 72 | code j txa, tsx, 73 | $107 ldy,x w sty, $108 ldy,x 74 | tax, dex, 75 | msb sty,x w lda, lsb sta,x rts, end-code 76 | 77 | hide lstk 78 | hide lsp 79 | hide >l 80 | hide resolve-leaves 81 | -------------------------------------------------------------------------------- /forth/dos.fs: -------------------------------------------------------------------------------- 1 | require io 2 | 3 | \ send command string to drive and 4 | \ print response 5 | : send-cmd ( addr len -- ) 6 | ?dup if $f $f open ioabort 7 | $f chkin ioabort 8 | begin chrin emit readst until 9 | clrchn $f close cr 10 | else drop rderr then ; 11 | 12 | \ send remainder of line as dos command 13 | \ and print response 14 | : dos source >in @ /string 15 | dup >in +! \ consume buffer 16 | send-cmd ; 17 | -------------------------------------------------------------------------------- /forth/float.fs: -------------------------------------------------------------------------------- 1 | ( BASIC floating point words. 2 | 3 | Caution! This code cannot be used 4 | safely, as the Kernal floating-point 5 | routines use addresses inside the 6 | Durexforth parameter stack area. 7 | It is only intended for amusement 8 | and as a fun hack. 9 | 10 | If running from cartridge, these 11 | words will crash because BASIC ROM 12 | cannot be accessed! 13 | 14 | Example: 15 | 16 | s" .5" strf .5 17 | s" .8" strf .8 18 | .5 fac! .8 fac* fac. 19 | 20 | ...prints .4! ) 21 | 22 | : bsys \ system call to BASIC ROM 23 | 1 c@ dup 3 or 1 c! swap sys 1 c! ; 24 | : fac, $bbca bsys 25 | $57 here 5 move here 5 + to here ; 26 | \ 5-byte float word from string 27 | : strf ( str strlen -- ) 28 | ar ! $22 ! $b7b5 bsys create fac, ; 29 | \ 5-byte float word from signed int 30 | : intf ( s -- ) create 31 | split ar ! yr ! $b391 bsys fac, ; 32 | : fac! ( faddr -- ) 33 | split yr ! ar ! $bba2 bsys ; 34 | : fac* ( faddr -- ) 35 | split yr ! ar ! $ba28 bsys ; 36 | : fac. $bddd bsys $b487 bsys $ab21 bsys ; 37 | -------------------------------------------------------------------------------- /forth/fractals.fs: -------------------------------------------------------------------------------- 1 | \ lindenmayer systems 2 | 3 | require turtle 4 | 5 | 0 value Da \ delta angle 6 | 0 value Dd \ delta distance 7 | 8 | variable rule variable rulel variable scale 9 | 10 | : dofract ( depth -- depth ) 11 | scale @ $100 <> if 12 | Dd dup >r scale @ * split to Dd drop 13 | then 14 | 0 begin dup rulel < while 15 | dup rule + c@ case 16 | 'f' of over if 17 | swap 1- recurse 1+ swap 18 | else Dd forward then 19 | endof 20 | '@' of Dd forward endof 21 | '+' of Da right endof 22 | '-' of Da left endof 23 | '[' of turtle@ >r >r >r 24 | endof 25 | ']' of r> r> r> turtle! 26 | endof endcase 1+ repeat drop 27 | scale @ $100 <> if r> to Dd then ; 28 | 29 | : fractal ( ax axl depth scale Dd Da 30 | rule rulel -- ) 31 | to rulel to rule to Da to Dd scale ! 32 | 0 \ axiom axioml depth i 33 | begin 2 pick over > while 34 | 3 pick over + c@ case 35 | 'f' of over if 36 | swap 1- dofract 1+ swap 37 | else Dd forward then endof 38 | '+' of Da right endof 39 | '-' of Da left endof 40 | endcase 41 | 1+ repeat 2drop 2drop ; 42 | 43 | : done key drop lores ; 44 | : koch init $10 clrcol 45 | $20 $4c 0 moveto 46 | s" f" 3 $100 9 $3c s" f-f++f-f" fractal 47 | $20 $88 0 moveto 48 | s" f" 4 $100 3 $3c s" f-f++f-f" fractal 49 | $20 $c4 0 moveto 50 | s" f" 5 $100 1 $3c s" f-f++f-f" fractal 51 | done ; 52 | : weed1 init $d clrcol 53 | $a0 $c4 $10e moveto 54 | s" f" 3 $100 7 $19 s" f[-f]f[+f]f" 55 | fractal done ; 56 | : bush1 init $d clrcol 57 | $a0 $bb $10e moveto 58 | s" f" 4 $100 3 $19 59 | s" ff+[+f-f-f]-[-f+f+f]" fractal done ; 60 | : bush2 init $d clrcol $d $d020 c! 61 | $a0 $c8 $10e moveto 62 | s" f" 6 $80 $64 $14 63 | s" @[+f]@[-f]+f" fractal done ; 64 | 65 | : demo $d020 @ 66 | koch weed1 bush1 bush2 $d020 ! ; 67 | -------------------------------------------------------------------------------- /forth/generators/sintab.py: -------------------------------------------------------------------------------- 1 | import math 2 | 3 | for d in xrange(360): 4 | if d % 4 == 0: 5 | print 6 | a = int(32767.5 + 32767.5 * math.sin(d * math.pi / 180)) 7 | print hex(a)[2:], ",", 8 | -------------------------------------------------------------------------------- /forth/gfx.fs: -------------------------------------------------------------------------------- 1 | base @ hex 2 | e000 value bmpbase 3 | cc00 value colbase 4 | 5 | code kernal-in 6 | 36 lda,# 1 sta, cli, rts, end-code 7 | code kernal-out 8 | sei, 35 lda,# 1 sta, rts, end-code 9 | 10 | code hires 11 | bb lda,# d011 sta, \ enable bitmap mode 12 | dd00 lda, 13 | %11111100 and,# \ vic bank 2 14 | dd00 sta, 15 | 38 lda,# d018 sta, 16 | rts, end-code 17 | 18 | code lores 19 | 9b lda,# d011 sta, 20 | dd00 lda, 21 | %11 ora,# 22 | dd00 sta, 23 | 17 lda,# 24 | d018 sta, 25 | rts, end-code 26 | 27 | : clrcol ( fgbgcol -- ) 28 | colbase 3e8 rot fill 29 | bmpbase 1f40 erase ; 30 | 31 | : blkcol ( col row c -- ) 32 | -rot 28 * + colbase + c! ; 33 | 34 | header mask 35 | 80 c, 40 c, 20 c, 10 c, 36 | 8 c, 4 c, 2 c, 1 c, 37 | 38 | variable penx variable peny 39 | 0 penx ! 0 peny ! 40 | 41 | \ blit operations for plot, line 42 | header blitop 43 | 0 , \ doplot 44 | 0 , \ lineplot 45 | 46 | code blitloc ( x y -- mask addr ) 47 | lsb lda,x w sta, 48 | 7 and,# w3 sta, 49 | msb lda,x w 1+ sta, 50 | 51 | w lda, f8 and,# w sta, 52 | 53 | \ * 8 54 | w asl, w 1+ rol, 55 | w asl, w 1+ rol, 56 | w asl, w 1+ rol, 57 | 58 | w lda, w2 sta, 59 | w 1+ lda, w2 1+ sta, 60 | 61 | \ * 20 62 | w asl, w 1+ rol, 63 | w asl, w 1+ rol, 64 | 65 | clc, 66 | w lda, w2 adc, w sta, 67 | w 1+ lda, w2 1+ adc, 68 | w 1+ sta, 69 | clc, 70 | w lda, w3 adc, w sta, 71 | 2 bcc, w 1+ inc, 72 | 73 | w lda, lsb sta,x 74 | w 1+ lda, msb sta,x 75 | 76 | \ ... 77 | 78 | ' mask split lda,# drop w 1+ sta, 79 | 80 | clc, 81 | lsb 1+ lda,x 7 and,# ' mask adc,# 82 | w sta, 83 | 2 bcc, w 1+ inc, 84 | 85 | \ w = mask 86 | 0 ldy,# 87 | w lda,(y) w3 sta, 88 | 89 | clc, 90 | lsb 1+ lda,x f8 and,# lsb adc,x lsb sta,x 91 | msb 1+ lda,x msb adc,x clc, e0 adc,# msb sta,x 92 | w3 lda, lsb 1+ sta,x 93 | 0 lda,# msb 1+ sta,x 94 | rts, 95 | 96 | : doplot ( x y -- ) 97 | blitloc tuck c@ 98 | [ here 1+ ' blitop ! ] or 99 | swap c! ; 100 | 101 | : chkplot ( x y -- ) 102 | over 13f > over c7 > or 103 | if 2drop else doplot then ; 104 | 105 | : plot ( x y -- ) 106 | kernal-out 107 | 2dup peny ! penx ! chkplot 108 | kernal-in ; 109 | 110 | : peek ( x y -- b ) 111 | blitloc kernal-out c@ kernal-in and ; 112 | 113 | variable dy 114 | variable sy variable sx 115 | variable err variable 2err 116 | 117 | variable mask variable addr 118 | 119 | create lineplot ( -- ) 120 | 121 | \ penx @ 140 < 122 | penx split 123 | lda,# w 1+ sta, 124 | lda,# w sta, 125 | 1 ldy,# w lda,(y) 126 | +branch beq, 127 | 1 cmp,# 1 beq, rts, 128 | dey, w lda,(y) 129 | sec, 40 sbc,# 130 | 1 bcc, rts, 131 | :+ 132 | 133 | \ peny @ c8 < 134 | peny split 135 | lda,# w 1+ sta, 136 | lda,# w sta, 137 | 1 ldy,# w lda,(y) 138 | 1 beq, rts, 139 | dey, w lda,(y) 140 | sec, c8 sbc,# 141 | 1 bcc, rts, 142 | 143 | \ addr 144 | addr split 145 | lda,# w 1+ sta, 146 | lda,# w sta, 147 | 148 | \ @ 149 | 0 ldy,# 150 | w lda,(y) w2 sta, iny, 151 | w lda,(y) w2 1+ sta, dey, 152 | 153 | \ c@ mask c@ or 154 | w2 lda,(y) 155 | here ' blitop 2+ ! 156 | mask ora, 157 | 158 | \ addr @ c! 159 | w2 sta,(y) rts, 160 | 161 | variable dx2 variable dy2 162 | 163 | create stepx 164 | \ 2err @ dx2 @ < if 165 | sec, 2err lda, dx2 sbc, 166 | 2err 1+ lda, dx2 1+ sbc, 167 | 3 bmi, lineplot jmp, 168 | 169 | \ dx2 @ err +! 170 | clc, dx2 lda, err adc, err sta, 171 | dx2 1+ lda, err 1+ adc, err 1+ sta, 172 | \ sy @ peny +! 173 | clc, sy lda, peny adc, peny sta, 174 | sy 1+ lda, peny 1+ adc, peny 1+ sta, 175 | 176 | \ sy @ 1 = if down else up then 177 | sy lda, 1 cmp,# +branch beq, 178 | \ up 179 | addr lda, 7 and,# +branch bne, 180 | sec, addr lda, 38 sbc,# addr sta, 181 | addr 1+ lda, 1 sbc,# addr 1+ sta, 182 | :+ 183 | addr lda, 3 bne, addr 1+ dec, addr dec, 184 | lineplot jmp, 185 | :+ \ down 186 | addr inc, 3 bne, addr 1+ inc, 187 | addr lda, 7 and,# 3 beq, lineplot jmp, 188 | clc, addr lda, 38 adc,# addr sta, 189 | addr 1+ lda, 1 adc,# addr 1+ sta, 190 | lineplot jmp, 191 | 192 | create step ( 2err -- 2err ) 193 | \ err @ 2* 2err ! 194 | err lda, 2err sta, 195 | err 1+ lda, 2err 1+ sta, 196 | 2err asl, 2err 1+ rol, 197 | 198 | \ step up/down 199 | 200 | \ 2err @ dy2 @ > if 201 | sec, dy2 lda, 2err sbc, 202 | dy2 1+ lda, 2err 1+ sbc, 203 | 3 bmi, stepx jmp, 204 | 205 | \ dy2 @ err +! 206 | clc, dy2 lda, err adc, err sta, 207 | dy2 1+ lda, err 1+ adc, err 1+ sta, 208 | \ sx @ penx +! 209 | clc, sx lda, penx adc, penx sta, 210 | sx 1+ lda, penx 1+ adc, penx 1+ sta, 211 | 212 | \ sx @ 1 = if maskror else maskrol then 213 | sx lda, 1 cmp,# +branch bne, 214 | \ right 215 | \ maskror.mask>>1,addr+8? 216 | mask lsr, 3 bcs, stepx jmp, 217 | 80 lda,# mask sta, 218 | clc, addr lda, 8 adc,# addr sta, 219 | 3 bcc, addr 1+ inc, stepx jmp, 220 | :+ \ left 221 | \ mask<<1,addr-8? 222 | mask asl, 3 bcs, stepx jmp, 223 | 1 lda,# mask sta, 224 | sec, addr lda, 8 sbc,# addr sta, 225 | 3 bcs, addr 1+ dec, stepx jmp, 226 | 227 | code doline 228 | 1 @: step jsr, 229 | peny lda, lsb cmp,x 1 @@ bne, 230 | penx lda, lsb 1+ cmp,x 1 @@ bne, 231 | peny 1+ lda, msb cmp,x 1 @@ bne, 232 | penx 1+ lda, msb 1+ cmp,x 1 @@ bne, 233 | inx, inx, rts, end-code 234 | 235 | : line ( x y -- ) 236 | kernal-out 237 | 2dup peny @ - abs dy2 ! 238 | penx @ - abs dx2 ! 239 | 2dup 240 | peny @ swap < if 1 else ffff then sy ! 241 | penx @ swap < if 1 else ffff then sx ! 242 | dx2 @ dy2 @ - err ! 243 | dy2 @ negate dy2 ! 244 | 245 | penx @ peny @ blitloc addr ! mask ! 246 | 247 | doline kernal-in ; 248 | 249 | \ --- circle 250 | 251 | 0 value cx 0 value cy 252 | 253 | : plot4 ( x y -- x y ) 254 | over cx + over cy + chkplot 255 | over if \ x? 256 | over cx swap - over cy + chkplot 257 | then 258 | dup if \ y? 259 | over cx + over cy swap - chkplot 260 | then 261 | over 0<> over 0<> and if 262 | over cx swap - over cy swap - chkplot 263 | then ; 264 | 265 | : plot8 ( x y -- x y ) 266 | plot4 267 | 2dup <> if 268 | swap plot4 swap 269 | then ; 270 | 271 | : circle ( cx cy r -- ) 272 | kernal-out 273 | dup negate err ! 274 | swap to cy 275 | swap to cx 276 | 0 \ x y 277 | begin 2dup < 0= while 278 | plot8 279 | dup err +! 280 | 1+ 281 | dup err +! 282 | err @ 0< 0= if 283 | over negate err +! 284 | swap 1- swap 285 | over negate err +! 286 | then 287 | repeat 2drop kernal-in ; 288 | 289 | : pen if 290 | 4d ['] xor else 291 | d ['] or then ['] blitop @ ! 292 | ['] blitop 2+ @ c! ; 293 | 294 | \ -------------------------- 295 | 296 | \ paul heckbert seed fill 297 | \ from graphics gems 298 | variable stk 299 | create dopush 300 | stk lda, w sta, 301 | stk 1+ lda, w 1+ sta, 302 | 303 | \ dy 304 | 0 ldy,# lsb lda,x w sta,(y) 305 | \ xr 306 | iny, lsb 1+ lda,x w sta,(y) 307 | iny, msb 1+ lda,x w sta,(y) 308 | \ xl 309 | iny, lsb 2 + lda,x w sta,(y) 310 | iny, msb 2 + lda,x w sta,(y) 311 | \ y 312 | iny, lsb 3 + lda,x w sta,(y) 313 | 314 | clc, stk lda, 6 adc,# stk sta, 315 | 3 bcc, stk 1+ inc, rts, 316 | 317 | code spush ( y xl xr dy -- ) 318 | \ y out of bounds? 319 | clc, lsb lda,x lsb 3 + adc,x tay, 320 | msb lda,x msb 3 + adc,x +branch bne, 321 | tya, sec, c8 cmp,# 3 bcs, dopush jsr, 322 | :+ 323 | inx, inx, inx, inx, rts, end-code 324 | 325 | variable x1 variable x2 326 | 327 | code spop ( -- y ) 328 | stk lda, 329 | sec, 6 sbc,# w sta, stk sta, 330 | 3 bcs, stk 1+ dec, 331 | stk 1+ lda, w 1+ sta, 332 | 333 | \ ff = if ffff else 1 then dy ! 334 | 0 ldy,# w lda,(y) 335 | dy sta, dy 1+ sta, 336 | 1 cmp,# 3 bne, dy 1+ sty, 337 | 338 | dex, 339 | msb sty,x \ msb y=0 340 | iny, w lda,(y) x2 sta, 341 | iny, w lda,(y) x2 1+ sta, 342 | iny, w lda,(y) x1 sta, 343 | iny, w lda,(y) x1 1+ sta, 344 | iny, w lda,(y) lsb sta,x 345 | rts, end-code 346 | 347 | variable l 348 | 349 | \ --- 350 | 351 | create .bitblt ( mask addr -- 352 | mask addr ) 353 | lsb lda,x w sta, 354 | msb lda,x w 1+ sta, 355 | 0 ldy,# w lda,(y) 356 | lsb 1+ ora,x w sta,(y) 357 | \ 1 penx +! swap 2/ swap 358 | penx inc, 3 bne, penx 1+ inc, 359 | lsb 1+ lsr,x rts, 360 | 361 | create rightend 362 | \ nip 80 swap \ mask 363 | 80 lda,# lsb 1+ sta,x 364 | 0 lda,# msb 1+ sta,x 365 | 366 | :- 367 | lsb 1+ lda,x 1 bne, rts, 368 | lsb lda,x w sta, 369 | msb lda,x w 1+ sta, 370 | 0 ldy,# w lda,(y) 371 | lsb 1+ and,x 1 beq, rts, 372 | .bitblt jsr, jmp, \ recurse 373 | 374 | create bytewise 375 | \ penx @ 140 < if 376 | penx 1+ lda, 0 cmp,# +branch beq, 377 | 3f lda,# penx cmp, 1 bcs, rts, 378 | :+ 379 | 380 | :- \ 8 + 381 | clc, lsb lda,x 8 adc,# lsb sta,x 382 | 2 bcc, msb inc,x 383 | \ penx=140? 384 | penx lda, 40 cmp,# +branch bne, 385 | penx 1+ lda, 1 cmp,# +branch bne, 386 | rts, 387 | :+ :+ 388 | lsb lda,x w sta, 389 | msb lda,x w 1+ sta, 390 | 0 ldy,# w lda,(y) 391 | rightend -branch bne, 392 | 393 | \ ff over c! 394 | ff lda,# w sta,(y) 395 | \ 8 penx +! 396 | clc, penx lda, 8 adc,# penx sta, 397 | 3 bcc, penx 1+ inc, 398 | jmp, \ recurse 399 | 400 | create leavel 401 | \ 2drop nip penx @ swap 402 | inx, inx, 403 | penx lda, lsb 1+ sta,x 404 | penx 1+ lda, msb 1+ sta,x rts, 405 | 406 | \ this one must be fast 407 | code fillr ( x y -- newx y ) 408 | \ over 140 >= if exit then 409 | msb 1+ lda,x 0 cmp,# +branch beq, 410 | 3f lda,# lsb 1+ cmp,x 1 bcs, rts, 411 | :+ 412 | 413 | \ over penx ! 414 | lsb 1+ lda,x penx sta, 415 | msb 1+ lda,x penx 1+ sta, 416 | \ 2dup blitloc \ x y mask addr 417 | dex, dex, 418 | lsb 2 + lda,x lsb sta,x 419 | msb 2 + lda,x msb sta,x 420 | lsb 3 + lda,x lsb 1+ sta,x 421 | msb 3 + lda,x msb 1+ sta,x 422 | ' blitloc jsr, 423 | 424 | \ leftend ( x y mask addr -- 425 | \ x y mask addr more? ) 426 | :- 427 | lsb 1+ lda,x +branch bne, 428 | \ continue bytewise 429 | bytewise jsr, leavel jmp, end-code 430 | :+ 431 | lsb lda,x w sta, 432 | msb lda,x w 1+ sta, 433 | 0 ldy,# w lda,(y) 434 | lsb 1+ and,x +branch beq, 435 | \ done 436 | leavel jmp, end-code 437 | :+ 438 | .bitblt jsr, jmp, \ recurse 439 | 440 | code scanl 441 | :- 442 | \ x<0? 443 | msb 1+ lda,x 1 bpl, rts, 444 | 445 | addr lda, w sta, 446 | addr 1+ lda, w 1+ sta, 447 | 0 ldy,# w lda,(y) 448 | mask and, 1 beq, rts, 449 | 450 | w lda,(y) 451 | mask ora, w sta,(y) 452 | 453 | mask asl, +branch bcc, 454 | 1 lda,# mask sta, 455 | addr lda, sec, 8 sbc,# addr sta, 456 | 3 bcs, addr 1+ dec, 457 | 458 | :+ \ 1- 459 | lsb 1+ lda,x 2 bne, msb 1+ dec,x 460 | lsb 1+ dec,x 461 | jmp, \ recurse 462 | 463 | create .scanr 464 | \ over l ! \ l=x 465 | lsb 1+ lda,x l sta, 466 | msb 1+ lda,x l 1+ sta, 467 | rts, end-code 468 | 469 | code scanr ( x y mask addr -- newx y ) 470 | lsb lda,x addr sta, 471 | msb lda,x addr 1+ sta, 472 | lsb 1+ lda,x mask sta, 473 | inx, inx, 474 | 475 | :- 476 | \ addr @ c@ mask c@ and 477 | addr lda, w sta, 478 | addr 1+ lda, w 1+ sta, 479 | 0 ldy,# w lda,(y) 480 | mask and, .scanr -branch beq, 481 | 482 | \ x<=x2? 483 | x2 1+ lda, msb 1+ cmp,x .scanr -branch bcc, 484 | +branch bne, 485 | x2 lda, lsb 1+ cmp,x .scanr -branch bcc, 486 | :+ 487 | 488 | mask lsr, +branch bne, 489 | 80 lda,# mask sta, 490 | clc, addr lda, 8 adc,# addr sta, 491 | 3 bcc, addr 1+ inc, 492 | 493 | :+ \ x++ 494 | lsb 1+ inc,x 2 bne, msb 1+ inc,x 495 | jmp, \ recurse 496 | 497 | : paint ( x y -- ) 498 | 2dup c8 < 0= swap 140 < 0= or 499 | if 2drop exit then 500 | 2dup peek if 2drop exit then 501 | here stk ! 502 | \ push y x x 1 503 | 2dup swap dup 1 spush 504 | \ push y+1 x x -1 505 | 1+ swap dup ffff spush 506 | 507 | kernal-out 508 | begin here stk @ < while 509 | spop dy @ + \ y 510 | 511 | \ left line 512 | x1 @ over \ y x y 513 | 2dup blitloc addr ! mask ! 514 | scanl 515 | over x1 @ \ y x y x x1 516 | < 0= if 517 | branch [ here dy ! 0 , ] \ goto skip 518 | then 519 | \ y x y ... 520 | over 1+ dup l ! 521 | \ y x y l 522 | x1 @ < if \ l < x1? 523 | \ push y,l,x1-1,-dy 524 | dup l @ x1 @ 1- dy @ negate spush 525 | then 526 | \ y x y 527 | nip x1 @ 1+ swap \ x=x1+1 528 | 529 | begin 530 | fillr 531 | \ push y,l,x-1,dy 532 | dup l @ 3 pick 1- dy @ spush 533 | 534 | \ leak on right? 535 | over x2 @ 1+ > if 536 | \ push y,x2+1,x-1,-dy 537 | dup x2 @ 1+ 3 pick 1- dy @ negate spush 538 | then 539 | 540 | \ skip: y x y 541 | [ here dy @ ! ] 542 | 543 | swap 1+ swap 544 | 2dup blitloc scanr 545 | 546 | \ y x y 547 | over x2 @ > until 548 | 549 | 2drop drop repeat kernal-in ; 550 | 551 | here 552 | 80 c, 81 c, 82 c, 83 c, 84 c, 85 c, 86 c, 87 c, \ 0 553 | 88 c, 89 c, 8a c, 8b c, 8c c, 8d c, 8e c, 8f c, 554 | 90 c, 91 c, 92 c, 93 c, 94 c, 95 c, 96 c, 97 c, \ 1 555 | 98 c, 99 c, 9a c, 9b c, 9c c, 9d c, 9e c, 9f c, 556 | 20 c, 21 c, 22 c, 23 c, 24 c, 25 c, 26 c, 27 c, \ 2 557 | 28 c, 29 c, 2a c, 2b c, 2c c, 2d c, 2e c, 2f c, 558 | 30 c, 31 c, 32 c, 33 c, 34 c, 35 c, 36 c, 37 c, \ 3 559 | 38 c, 39 c, 3a c, 3b c, 3c c, 3d c, 3e c, 3f c, 560 | 00 c, 01 c, 02 c, 03 c, 04 c, 05 c, 06 c, 07 c, \ 4 561 | 08 c, 09 c, 0a c, 0b c, 0c c, 0d c, 0e c, 0f c, 562 | 10 c, 11 c, 12 c, 13 c, 14 c, 15 c, 16 c, 17 c, \ 5 563 | 18 c, 19 c, 1a c, 1b c, 1c c, 1d c, 1e c, 1f c, 564 | 40 c, 41 c, 42 c, 43 c, 44 c, 45 c, 46 c, 47 c, \ 6 565 | 48 c, 49 c, 4a c, 4b c, 4c c, 4d c, 4e c, 4f c, 566 | 50 c, 51 c, 52 c, 53 c, 54 c, 55 c, 56 c, 57 c, \ 7 567 | 58 c, 59 c, 5a c, 5b c, 5c c, 5d c, 5e c, 5f c, 568 | c0 c, c1 c, c2 c, c3 c, c4 c, c5 c, c6 c, c7 c, \ 8 569 | c8 c, c9 c, ca c, cb c, cc c, cd c, ce c, cf c, 570 | d0 c, d1 c, d2 c, d3 c, d4 c, d5 c, d6 c, d7 c, \ 9 571 | d8 c, d9 c, da c, db c, dc c, dd c, de c, df c, 572 | 60 c, 61 c, 62 c, 63 c, 64 c, 65 c, 66 c, 67 c, \ a 573 | 68 c, 69 c, 6a c, 6b c, 6c c, 6d c, 6e c, 6f c, 574 | 70 c, 71 c, 72 c, 73 c, 74 c, 75 c, 76 c, 77 c, \ b 575 | 78 c, 79 c, 7a c, 7b c, 7c c, 7d c, 7e c, 7f c, 576 | 40 c, 41 c, 42 c, 43 c, 44 c, 45 c, 46 c, 47 c, \ c 577 | 48 c, 49 c, 4a c, 4b c, 4c c, 4d c, 4e c, 4f c, 578 | 50 c, 51 c, 52 c, 53 c, 54 c, 55 c, 56 c, 57 c, \ d 579 | 58 c, 59 c, 5a c, 5b c, 5c c, 5d c, 5e c, 5f c, 580 | 60 c, 61 c, 62 c, 63 c, 64 c, 65 c, 66 c, 67 c, \ e 581 | 68 c, 69 c, 6a c, 6b c, 6c c, 6d c, 6e c, 6f c, 582 | 70 c, 71 c, 72 c, 73 c, 74 c, 75 c, 76 c, 77 c, \ f 583 | 78 c, 79 c, 7a c, 7b c, 7c c, 7d c, 7e c, 5e c, 584 | : pet>scr literal + c@ ; 585 | 586 | : text ( col row str strlen -- ) 587 | kernal-out 588 | \ addr=dst 589 | rot 140 * addr ! 590 | rot 8 * bmpbase + addr +! 591 | \ disable interrupt,enable char rom 592 | 1 c@ dup >r fb and 1 c! 593 | begin ?dup while 594 | swap dup c@ pet>scr 8 * d800 + 595 | addr @ 8 move 596 | 1+ swap 8 addr +! 1- repeat 597 | r> 1 c! drop kernal-in ; 598 | 599 | : drawchar ( col row srcaddr -- ) 600 | kernal-out 601 | swap 140 * rot 8 * + bmpbase + 602 | 8 move kernal-in ; 603 | base ! 604 | -------------------------------------------------------------------------------- /forth/gfxdemo.fs: -------------------------------------------------------------------------------- 1 | hex 2 | \ examples from c64 step by step 3 | \ programming, gfx book 3, phil cornes 4 | 5 | require gfx 6 | require rnd 7 | require sin 8 | 9 | d020 c@ 10 | 11 | : blkcol rot 2/ 2/ 2/ 12 | rot 2/ 2/ 2/ rot blkcol ; 13 | 14 | .( lineweb..) 15 | : lineweb 16 | 7 clrcol 17 | 5 begin 18 | dup 140 < while 19 | dup 0 plot 96 c8 line 20 | dup c7 plot 96 0 line 21 | a + repeat drop ; 22 | hires lineweb key drop lores 23 | 24 | .( rndline..) 25 | : rndline 26 | hires 10 clrcol 27 | 80 begin ?dup while 28 | rnd 0 ab um/mod nip 20 - 29 | rnd 0 f8 um/mod nip 20 - line 30 | 1- repeat ; 31 | hires rndline key drop lores 32 | 33 | .( radiant..) 34 | : radiant 35 | hires d0 clrcol 36 | 168 begin 37 | ?dup while 38 | 32 64 plot 39 | 12c over *cos 32 + 40 | over 12c swap *sin 64 + 41 | line 42 | 1- repeat ; 43 | hires radiant key drop lores 44 | 45 | .( diamond..) 46 | : diamond 47 | hires 12 clrcol 48 | 2 d020 c! 49 | 0 64 plot 50 | 0 begin 51 | dup c8 < while 52 | a0 over line 53 | 13f 64 line 54 | a0 over c7 swap - line 55 | 0 64 line 56 | 5 + repeat drop ; 57 | hires diamond key drop lores 58 | 59 | .( reccirc..) 60 | : reccircgo ( x r -- ) 61 | dup if 62 | 2dup 64 swap circle 63 | 2dup + over 2/ recurse 64 | 2dup - over 2/ recurse 65 | then 2drop ; 66 | 67 | : reccirc 68 | hires 7 clrcol 69 | a0 50 reccircgo ; 70 | hires reccirc key drop lores 71 | 72 | .( 2reccirc..) 73 | variable yd 74 | 75 | : 2reccircgo ( x r -- ) 76 | dup if 77 | 2dup yd @ swap circle 78 | 2dup c7 yd @ - swap circle 79 | d yd +! 80 | 2dup + over 2/ recurse 81 | 2dup - over 2/ recurse 82 | d negate yd +! 83 | then 2drop ; 84 | 85 | : 2reccirc 86 | hires 7 clrcol 87 | 64 yd ! 88 | a0 50 2reccircgo ; 89 | hires 2reccirc key drop lores 90 | 91 | .( erasecirc..) 92 | : erasecirc 93 | hires 7 clrcol 94 | 0 begin dup 140 < while 95 | dup 0 plot dup c7 line 96 | 14 + repeat drop 97 | 0 begin dup c7 < while 98 | dup 0 swap plot dup 13f swap line 99 | 14 + repeat drop 100 | 2 0 do 168 begin ?dup while 101 | a0 64 plot 102 | dup 64 swap *cos a0 + 103 | over 64 swap *sin 64 + line 104 | 1- repeat 1 pen loop 105 | 0 pen ; 106 | hires erasecirc key drop lores 107 | 108 | .( rotsqr..) 109 | : rotsqr 110 | hires 16 clrcol 111 | 8 d020 c! 1 pen 112 | 2 0 do fa begin ?dup while 113 | dup dup *cos a0 + 114 | over dup *sin 64 + 2dup plot plot 115 | dup dup *sin a0 swap - 116 | over dup *cos 64 + line 117 | dup dup *cos a0 swap - 118 | over dup *sin 64 swap - line 119 | dup dup *sin a0 + 120 | over dup *cos 64 swap - line 121 | dup dup *cos a0 + 122 | over dup *sin 64 + line 123 | 5 - repeat loop 0 pen ; 124 | hires rotsqr key drop lores 125 | 126 | .( seascape..) 127 | : seascape 128 | 0 d020 c! 129 | hires e clrcol 130 | 0 38 plot 10 28 line 30 48 line 131 | 40 40 line 70 98 line 78 8c line 132 | 88 a0 line a0 90 line d0 a8 line 133 | f8 90 line 13f b0 line 134 | 68 88 plot 88 60 line a0 70 line 135 | a8 68 line c8 80 line d8 78 line 136 | e8 88 line 137 | 121 87 plot 138 60 line 13f 68 line 138 | 30 a0 paint 139 | 69 88 plot 13f 88 line 140 | 88 70 paint 138 70 paint 141 | 104 6c f circle 104 6c paint 142 | 143 | 139 68 do 144 | 88 20 do j i be blkcol 8 +loop 145 | c4 88 do j i 6 blkcol 8 +loop 146 | 8 +loop 147 | 148 | 119 e8 do 81 50 do 149 | j i 7e blkcol 150 | 8 +loop 8 +loop ; 151 | hires seascape key drop lores 152 | 153 | .( jungle..) 154 | header jungledata 155 | c , a8 , ffff , 1 , e , 5f , 156 | 2f , 5f , f , 57 , f , 18 , 157 | 1c , 38 , 1c , 26 , 20 , 30 , 158 | 24 , 10 , 30 , 3f , 54 , a8 , 159 | 50 , ac , 44 , a4 , 40 , a8 , 160 | 3d , 9c , 3a , a0 , 35 , 96 , 161 | 30 , a8 , 23 , 9a , 20 , a2 , 162 | 16 , 97 , c , a8 , ffff , 0 , 163 | 64 , a0 , ffff , 1 , 4f , 60 , 164 | 35 , 14 , 38 , 14 , 45 , 21 , 165 | 48 , 14 , 54 , 38 , 58 , 30 , 166 | 5b , 3c , 68 , 2b , 70 , 3c , 167 | 70 , 2c , 78 , 47 , 84 , 42 , 168 | 94 , 47 , 94 , 2c , b8 , 47 , 169 | c0 , 50 , b8 , 60 , 96 , a0 , 170 | 8c , a0 , 88 , 9a , 7e , 94 , 171 | 78 , a0 , 72 , 96 , 72 , 7e , 172 | 6c , 96 , 64 , a0 , ffff , 0 , 173 | a8 , a0 , ffff , 1 , cc , 60 , 174 | e3 , 80 , f4 , a6 , e4 , ac , 175 | d8 , a0 , d0 , a4 , c4 , 94 , 176 | be , a0 , aa , a6 , a8 , a0 , 177 | ffff , 0 , cc , 47 , ffff , 1 , 178 | a0 , 22 , 179 | ac , 11 , b2 , 14 , c4 , b , 180 | cc , 18 , d4 , 18 , d6 , 1e , 181 | e0 , 18 , e4 , 1e , f4 , e , 182 | fa , 16 , cc , 47 , ffff , 0 , 183 | d8 , 54 , ffff , 1 , e7 , 3f , 184 | 10a , 1c , 185 | 10c , 2c , 116 , 20 , 119 , 38 , 186 | 120 , 30 , 124 , 38 , 12a , 28 , 187 | 134 , 22 , 131 , 40 , 110 , 40 , 188 | e8 , 47 , 12f , 47 , 11e , a8 , 189 | 118 , a8 , 110 , a0 , 108 , a8 , 190 | d8 , 54 , ffff , 0 , b7 , 5f , 191 | ffff , 1 , 192 | 50 , 5f , 64 , 58 , 78 , 50 , 193 | 90 , 4a , b7 , 48 , b7 , 5f , 194 | fffe , 0 , 195 | 0 , 138 , 0 , 38 , 6 , 196 | 0 , 138 , 60 , c0 , d , 197 | 0 , 8 , 40 , 58 , 0 , 198 | 10 , 28 , 40 , 58 , d6 , 199 | 30 , 48 , 40 , 58 , 6 , 200 | 50 , b0 , 48 , 58 , d6 , 201 | 50 , e0 , 40 , 40 , 6 , 202 | b8 , 128 , 48 , 58 , d , 203 | e8 , 128 , 40 , 40 , d6 , 204 | 130 , 138 , 40 , 58 , 0 , 205 | 206 | variable line? variable data 207 | 208 | : jcol 209 | data @ @ 2 data +! 210 | data @ @ 2 data +! 211 | data @ @ 2 data +! 212 | data @ @ 2 data +! 213 | data @ @ 2 data +! \ lx ux ly uy c 214 | 4 pick \ lx ux ly uy c x 215 | begin dup 5 pick > 0= while 216 | 3 pick \ lx ux ly uy c x y 217 | begin dup 4 pick > 0= while 218 | 2dup 4 pick blkcol 219 | 8 + repeat drop 8 + repeat 220 | 2drop 2drop 2drop ; 221 | 222 | : jungle 223 | hires 10 clrcol 0 d020 c! 224 | 0 line? ! ['] jungledata data ! 225 | begin 226 | data @ @ 2 data +! 227 | data @ @ 2 data +! \ x y 228 | over ffff = if line? ! drop 229 | else over fffe = if 230 | 2drop a0 50 paint a0 b4 paint 231 | jcol jcol jcol jcol jcol 232 | jcol jcol jcol jcol jcol 233 | exit then 234 | line? @ if line else plot then 235 | then again ; 236 | hires jungle key drop lores 237 | 238 | .( colorchart..) 239 | 240 | create sqr 241 | %00000000 c, 242 | %00000000 c, 243 | %00111100 c, 244 | %00111100 c, 245 | %00111100 c, 246 | %00111100 c, 247 | %00000000 c, 248 | %00000000 c, 249 | 250 | : colorchart 251 | hires 9c clrcol c d020 c! 252 | 80 0 plot 7c 17 line 253 | 94 17 line 96 c line 254 | aa c line ac 17 line 255 | c4 17 line c0 0 line 256 | 60 c7 plot 64 a8 line 257 | 7c a8 line 78 c8 line 258 | c8 c8 line c4 a8 line 259 | dc a8 line e0 c7 line 260 | 78 b4 paint d0 b4 paint a0 1 paint 261 | 262 | \ black board 263 | f9 40 do a1 18 do 264 | j i 10 blkcol 265 | 8 +loop 8 +loop 266 | 267 | b 4 s" 0" text 268 | b 5 s" 1" text 269 | b 6 s" 2" text 270 | b 7 s" 3" text 271 | b 8 s" 4" text 272 | b 9 s" 5" text 273 | b a s" 6" text 274 | b b s" 7" text 275 | b c s" 8" text 276 | b d s" 9" text 277 | a e s" 10" text 278 | a f s" 11" text 279 | a 10 s" 12" text 280 | a 11 s" 13" text 281 | a 12 s" 14" text 282 | a 13 s" 15" text 283 | 284 | 0 begin dup 10 < while 285 | 0 begin dup 10 < while 286 | 2dup 2dup swap 2* 2* 2* 2* or 287 | rot d + 8 * rot 4 + 8 * rot blkcol 288 | 2dup swap d + swap 4 + sqr drawchar 289 | 1+ repeat drop 290 | 1+ repeat drop ; 291 | hires colorchart key drop lores 292 | 293 | d020 c! 294 | -------------------------------------------------------------------------------- /forth/iec.fs: -------------------------------------------------------------------------------- 1 | 2 | code listen ( dv -- ) 3 | here 1+ 4 | $ffff stx, \ dummy address 5 | lsb lda,x \ one byte more but faster 6 | $ffb1 jsr, \ listen 7 | here 1+ swap ! \ actual address 8 | $00 ldx,# inx, \ dummy byte 9 | rts, end-code 10 | 11 | code second ( sa -- ) 12 | here 1+ 13 | $ffff stx, 14 | lsb lda,x 15 | $ff93 jsr, \ second 16 | here 1+ swap ! 17 | $00 ldx,# inx, 18 | rts, end-code 19 | 20 | code talk ( dv -- ) 21 | here 1+ 22 | $ffff stx, 23 | lsb lda,x 24 | $ffb4 jsr, \ talk 25 | here 1+ swap ! 26 | $00 ldx,# inx, 27 | rts, end-code 28 | 29 | code tksa ( sa -- ) 30 | here 1+ 31 | $ffff stx, 32 | lsb lda,x 33 | $ff96 jsr, \ tksa 34 | here 1+ swap ! 35 | $00 ldx,# inx, 36 | rts, end-code 37 | 38 | code unlisten ( -- ) 39 | here 1+ 40 | $ffff stx, 41 | $ffae jsr, \ unlisten 42 | here 1+ swap ! 43 | $00 ldx,# 44 | rts, end-code 45 | 46 | code untalk ( -- ) 47 | here 1+ 48 | $ffff stx, 49 | $ffab jsr, \ untalk 50 | here 1+ swap ! 51 | $00 ldx,# 52 | rts, end-code 53 | 54 | code ciout ( chr -- ) 55 | here 1+ 56 | $ffff stx, 57 | lsb lda,x 58 | $ffa8 jsr, \ ciout 59 | here 1+ swap ! 60 | $00 ldx,# inx, 61 | rts, end-code 62 | 63 | code acptr ( -- chr ) 64 | dex, w stx, 0 lda,# msb sta,x 65 | $ffa5 jsr, \ acptr 66 | w ldx, lsb sta,x 67 | rts, end-code 68 | 69 | require io 70 | 71 | : iqt readst ioabort ; \ legacy of if quit then 72 | 73 | : tfname ( addr len -- ) 74 | over + swap do 75 | i c@ ciout loop ; 76 | 77 | : send-cmd ( addr len -- ) 78 | 0 $90 c! \ always zero ST 79 | ?dup if \ command to be sent? 80 | $ba c@ listen iqt \ Yes 81 | $6f second iqt \ don't require $ff open, 82 | \ error channel always open. 83 | tfname unlisten \ turn around 84 | then \ No 85 | $ba c@ talk iqt \ listener is now talker 86 | $6f tksa iqt \ $6f data channel only 87 | acptr readst begin 88 | 0= while emit 89 | acptr readst repeat 90 | emit untalk cr ; \ no need to close error channel 91 | 92 | : dos source >in @ /string 93 | dup >in +! \ consume buffer 94 | send-cmd ; 95 | 96 | : bsave ( addr addr -- addr ) 97 | 0 $90 c! parse-name \ always zero ST 98 | $ba c@ listen iqt 99 | $f1 second iqt \ $F0 + $01 write prg 100 | tfname unlisten \ always all devices 101 | $ba c@ listen \ if we get here, 102 | $61 second \ the device exists 103 | over split ciout ciout 104 | \ send load addr 105 | over dup 106 | 0 do i + dup c@ ciout loop 107 | 1+ \ keep saveb compatibility 108 | unlisten $ba c@ listen 109 | $e1 second \ $E0 + $01 close 110 | unlisten 111 | ; 112 | 113 | : dir parse-name ?dup if 114 | else drop s" $0" 115 | then 0 $90 c! \ always zero ST 116 | $ba c@ listen iqt 117 | $f0 second iqt \ $F0 OPEN + $00 channel, read as prg 118 | tfname 119 | unlisten $ba c@ talk \ turn around 120 | $60 tksa \ $60 open, opened channel 121 | acptr acptr 2drop \ listener is now talker. drop load address 122 | here begin acptr over c! 1+ \ load HERE loop until EOF 123 | readst until drop untalk 124 | $ba c@ listen $e0 second \ $E0 + $00 close 125 | unlisten 126 | page here rdir ; 127 | -------------------------------------------------------------------------------- /forth/io.fs: -------------------------------------------------------------------------------- 1 | \ Use logical file as input device 2 | \ ioresult is 0 on success, kernal 3 | \ error # on failure. 4 | code chkin ( file# -- ioresult ) 5 | w stx, 6 | lsb lda,x tax, \ x = file# 7 | $ffc6 jsr, \ CHKIN 8 | +branch bcs, \ carry set = error 9 | 0 lda,# \ A is only valid on error 10 | :+ 11 | w ldx, 12 | lsb sta,x 13 | 0 lda,# msb sta,x 14 | rts, end-code 15 | 16 | \ Use logical file as output device 17 | \ ioresult is 0 on success, kernal 18 | \ error # on failure. 19 | code chkout ( file# -- ioresult ) 20 | w stx, 21 | lsb lda,x tax, \ x = file# 22 | $ffc9 jsr, \ CHKOUT 23 | +branch bcs, \ carry set = error 24 | 0 lda,# \ A is only valid on error 25 | :+ 26 | w ldx, 27 | lsb sta,x 28 | 0 lda,# msb sta,x 29 | rts, end-code 30 | 31 | \ Reset input and output to console 32 | code clrchn ( -- ) 33 | txa, pha, 34 | $ffcc jsr, \ CLRCH 35 | pla, tax, 36 | rts, end-code 37 | 38 | \ Read status of last IO operation 39 | code readst ( -- status ) 40 | dex, 0 lda,# msb sta,x 41 | $ffb7 jsr, \ READST 42 | lsb sta,x 43 | rts, end-code 44 | 45 | \ Get a byte from input device 46 | code chrin ( -- chr ) 47 | dex, w stx, 0 lda,# msb sta,x 48 | $ffcf jsr, \ CHRIN 49 | w ldx, lsb sta,x 50 | rts, end-code 51 | -------------------------------------------------------------------------------- /forth/labels.fs: -------------------------------------------------------------------------------- 1 | ( asm local labels. 2 | 3 | n @: = label n 4 | n @@ = branch to label n 5 | 6 | ...where n is in range[0, ff] 7 | 8 | relative branches are resolved by 9 | end-code - this allows for mixed 10 | forward and backward references, 11 | but it is not possible to branch 12 | over end-code. 13 | 14 | -- example -- 15 | code checkers 16 | 7f lda,# 0 ldy,# 1 @: 17 | 400 sta,y 500 sta,y 18 | 600 sta,y 700 sta,y 19 | dey, 1 @@ bne, rts, end-code ) 20 | 21 | ( refs and locs are arrays of 22 | 2-byte address + 1-byte index ) 23 | variable refs 8 3 * 2 - allot \ 8 refs 24 | variable locs 5 3 * 2 - allot \ 5 locs 25 | variable locp variable refp 26 | 27 | locs locp ! refs refp ! \ init 28 | 29 | \ reference 30 | : @@ ( index -- dummy ) 31 | here refp @ ! 32 | 2 refp +! refp @ c! 1 refp +! 0 ; 33 | \ label 34 | : @: ( index -- ) 35 | here locp @ ! 36 | 2 locp +! locp @ c! 1 locp +! ; 37 | : end-code 38 | locs begin dup locp @ < while 39 | refs begin dup refp @ < while 40 | over 2+ c@ over 2+ c@ = if 41 | over @ over @ 2+ - over @ 1+ c! 42 | then 3 + repeat drop 3 + repeat drop 43 | \ reset 44 | locs locp ! refs refp ! ; 45 | 46 | hide locs 47 | hide locp 48 | hide refs 49 | hide refp 50 | -------------------------------------------------------------------------------- /forth/ls.fs: -------------------------------------------------------------------------------- 1 | \ submitted by kevin reno 2 | 3 | : rdir ( addr -- ) 4 | begin ?dup while 5 | more 2+ dup @ . 2+ 6 | begin dup c@ ?dup while 7 | emit 1+ repeat 1+ cr 8 | dup c@ 0= if c@ then 9 | repeat ; 10 | 11 | : ls parse-name ?dup if 12 | else drop s" $" 13 | then here loadb if 14 | page here rdir then ; 15 | -------------------------------------------------------------------------------- /forth/mml.fs: -------------------------------------------------------------------------------- 1 | base @ hex 2 | variable sid 13 allot 3 | variable voice 4 | 5 | \ creates array of 4 bytes. 6 | \ first: current byte 7 | \ 2nd. voice 0 8 | \ 3rd. voice 1 9 | \ 4th. voice 2 10 | : voicedata here 0 , 0 , value ; 11 | voicedata octave 12 | voicedata tie 13 | voicedata default-pause 14 | voicedata pause 15 | 16 | create .voice7* 17 | voice lda, 18 | +branch bne, rts, 19 | :+ 1 cmp,# +branch bne, 20 | 7 lda,# rts, 21 | :+ 7 2* lda,# rts, 22 | 23 | code voice7+ \ voice c@ 7 * + 24 | .voice7* jsr, 25 | clc, lsb adc,x lsb sta,x +branch bcc, 26 | msb inc,x :+ rts, end-code 27 | 28 | create .ctl 29 | sid 4 + split lda,# drop w 1+ sta, 30 | .voice7* jsr, 31 | clc, sid 4 + ff and adc,# w sta, 32 | +branch bcc, w 1+ inc, :+ rts, 33 | code ctl 34 | dex, 35 | .ctl jsr, 36 | w lda, lsb sta,x 37 | w 1+ lda, msb sta,x 38 | rts, end-code 39 | 40 | : sid-cutoff d415 ! ; 41 | : sid-flt d417 c! ; 42 | : sid-vol! d418 c! ; 43 | 44 | ( write adsr ) 45 | : srad! ( SR AD -- ) 46 | [ sid 5 + literal ] voice7+ ! ; 47 | 48 | here \ 95 notes from c0, pal 49 | 116 , 127 , 138 , 14b , 15e , 173 , 50 | 189 , 1a1 , 1ba , 1d4 , 1f0 , 20d , 51 | 22c , 24e , 271 , 296 , 2bd , 2e7 , 52 | 313 , 342 , 374 , 3a8 , 3e0 , 41b , 53 | 459 , 49c , 4e2 , 52c , 57b , 5ce , 54 | 627 , 684 , 6e8 , 751 , 7c0 , 836 , 55 | 8b3 , 938 , 9c4 , a59 , af6 , b9d , 56 | c4e , d09 , dd0 , ea2 , f81 , 106d , 57 | 1167 , 1270 , 1388 , 14b2 , 15ed , 58 | 173a , 189c , 1a13 , 1ba0 , 1d44 , 59 | 1f02 , 20da , 22ce , 24e0 , 2711 , 60 | 2964 , 2bda , 2e75 , 3138 , 3426 , 61 | 3740 , 3a89 , 3e04 , 41b4 , 459c , 62 | 49c0 , 4e22 , 52c8 , 57b4 , 5ceb , 63 | 6271 , 684c , 6e80 , 7512 , 7c08 , 64 | 8368 , 8b38 , 9380 , 9c45 , a590 , 65 | af68 , b9d6 , c4e3 , d098 , dd00 , 66 | ea24 , f810 , 67 | : note! ( i -- ) 68 | 2* literal + @ sid voice7+ ! ; 69 | 70 | code gate-on 71 | .ctl jsr, 0 ldy,# 72 | w lda,(y) 1 eor,# 73 | w sta,(y) rts, end-code 74 | code gate-off 75 | .ctl jsr, 0 ldy,# 76 | w lda,(y) fe and,# 77 | w sta,(y) rts, end-code 78 | 79 | 2b value .str 80 | create .str-pop 81 | txa, tay, 82 | voice lda, asl,a tax, 83 | .str inc,x +branch bne, 84 | .str 1+ inc,x :+ 85 | tya, tax, rts, 86 | code str-pop .str-pop jmp, end-code 87 | 88 | create .strget 89 | w stx, voice lda, asl,a tax, 90 | .str lda,(x) w ldx, rts, 91 | code strget 92 | dex, 0 lda,# msb sta,x 93 | .strget jsr, lsb sta,x rts, end-code 94 | 95 | create notetab ( char -- notediff ) 96 | lsb lda,x 97 | 'c' cmp,# +branch bne, 98 | 0 lda,# lsb sta,x rts, 99 | :+ 'd' cmp,# +branch bne, 100 | 2 lda,# lsb sta,x rts, 101 | :+ 'e' cmp,# +branch bne, 102 | 4 lda,# lsb sta,x rts, 103 | :+ 'f' cmp,# +branch bne, 104 | 5 lda,# lsb sta,x rts, 105 | :+ 'g' cmp,# +branch bne, 106 | 7 lda,# lsb sta,x rts, 107 | :+ 'a' cmp,# +branch bne, 108 | 9 lda,# lsb sta,x rts, 109 | :+ 'b' cmp,# +branch bne, 110 | b lda,# lsb sta,x rts, 111 | :+ 7f lda,# lsb sta,x rts, 112 | 113 | create notrest 114 | lsb lda,x 7f cmp,# +branch beq, 115 | dex, 1 lda,# lsb sta,x rts, end-code 116 | :+ 0 lda,# lsb sta,x msb sta,x 117 | rts, end-code 118 | 119 | code str2note 120 | notetab jsr, 121 | .str-pop jsr, 122 | .strget jsr, 123 | '+' cmp,# +branch bne, 124 | lsb inc,x .str-pop jsr, notrest jmp, 125 | :+ '-' cmp,# +branch bne, 126 | lsb dec,x .str-pop jsr, notrest jmp, 127 | :+ notrest jmp, 128 | 129 | create .read-pause 130 | dex, 0 lda,# msb sta,x 131 | .strget jsr, 132 | '1' cmp,# +branch bne, 133 | .str-pop jsr, .strget jsr, 134 | '6' cmp,# +branch bne, 135 | .str-pop jsr, 60 10 / lda,# lsb sta,x 136 | rts, 137 | :+ 60 lda,# lsb sta,x rts, 138 | :+ '2' cmp,# +branch bne, 139 | .str-pop jsr, .strget jsr, 140 | '4' cmp,# +branch bne, 141 | .str-pop jsr, 60 18 / lda,# lsb sta,x 142 | rts, 143 | :+ 60 2 / lda,# lsb sta,x rts, 144 | :+ '3' cmp,# +branch bne, 145 | .str-pop jsr, .strget jsr, 146 | '2' cmp,# +branch bne, 147 | .str-pop jsr, 60 20 / lda,# lsb sta,x 148 | rts, 149 | :+ 60 3 / lda,# lsb sta,x rts, 150 | :+ '4' cmp,# +branch bne, 151 | .str-pop jsr, 60 4 / lda,# lsb sta,x 152 | rts, 153 | :+ '6' cmp,# +branch bne, 154 | .str-pop jsr, 60 6 / lda,# lsb sta,x 155 | rts, 156 | :+ '8' cmp,# +branch bne, 157 | .str-pop jsr, 60 8 / lda,# lsb sta,x 158 | rts, 159 | :+ 0 lda,# lsb sta,x rts, 160 | 161 | code read-pause 162 | .read-pause jsr, 163 | lsb lda,x +branch bne, 164 | default-pause lda, lsb sta,x 165 | :+ 166 | .strget jsr, 167 | '.' cmp,# +branch bne, 168 | .str-pop jsr, 169 | lsb lda,x lsr,a clc, 170 | lsb adc,x lsb sta,x 171 | :+ 172 | lsb dec,x rts, end-code 173 | 174 | code read-default-pause 175 | .read-pause jsr, 176 | lsb lda,x default-pause sta, 177 | inx, rts, end-code 178 | 179 | : play-note ( -- ) 180 | strget ?dup if 181 | str2note if 182 | octave c@ + note! gate-on then 183 | read-pause pause c! then ; 184 | 185 | code o 186 | .str-pop jsr, 187 | .strget jsr, \ new character in a 188 | sec, '0' sbc,# 189 | \ multiply by c 190 | asl,a asl,a w sta, 191 | asl,a clc, w adc, 192 | octave sta, 193 | .str-pop jmp, end-code 194 | 195 | : do-commands ( -- done ) 196 | strget case 197 | 'l' of str-pop 198 | read-default-pause recurse endof 199 | 'o' of o recurse endof 200 | '<' of str-pop fff4 octave +! 201 | recurse endof 202 | '>' of str-pop c octave +! 203 | recurse endof 204 | '&' of str-pop 1 tie c! 205 | recurse endof 206 | d of str-pop recurse endof 207 | bl of str-pop recurse endof 208 | endcase ; 209 | 210 | code stop-note 211 | tie lda, +branch beq, 212 | 0 lda,# tie sta, rts, end-code 213 | :+ ' gate-off jmp, 214 | 215 | code pause>0 216 | dex, 217 | pause lda, 218 | lsb sta,x msb sta,x rts, end-code 219 | 220 | code decpause1= 221 | dex, 0 ldy,# 222 | pause dec, +branch beq, 223 | lsb sty,x msb sty,x rts, end-code 224 | :+ iny, lsb sty,x rts, end-code 225 | 226 | : voicetick 227 | pause>0 if decpause1= if 228 | do-commands stop-note then 229 | else play-note then ; 230 | 231 | code voice0 232 | 0 lda,# voice sta, 233 | octave 1+ lda, octave sta, 234 | tie 1+ lda, tie sta, 235 | pause 1+ lda, pause sta, 236 | default-pause 1+ lda, 237 | default-pause sta, 238 | rts, end-code 239 | 240 | code voice1 241 | octave lda, octave 1+ sta, 242 | tie lda, tie 1+ sta, 243 | pause lda, pause 1+ sta, 244 | default-pause lda, 245 | default-pause 1+ sta, 246 | 1 lda,# voice sta, 247 | octave 2+ lda, octave sta, 248 | tie 2+ lda, tie sta, 249 | pause 2+ lda, pause sta, 250 | default-pause 2+ lda, 251 | default-pause sta, 252 | rts, end-code 253 | 254 | code voice2 255 | octave lda, octave 2+ sta, 256 | tie lda, tie 2+ sta, 257 | pause lda, pause 2+ sta, 258 | default-pause lda, 259 | default-pause 2+ sta, 260 | 2 lda,# voice sta, 261 | octave 3 + lda, octave sta, 262 | tie 3 + lda, tie sta, 263 | pause 3 + lda, pause sta, 264 | default-pause 3 + lda, 265 | default-pause sta, 266 | rts, end-code 267 | 268 | code voicedone 269 | octave lda, octave 3 + sta, 270 | tie lda, tie 3 + sta, 271 | pause lda, pause 3 + sta, 272 | default-pause lda, 273 | default-pause 3 + sta, 274 | rts, end-code 275 | 276 | code wait 277 | \ visualize lag 278 | \ a2 lda, sec, lsb sbc,x d020 sta, 279 | lsb lda,x 280 | :- a2 cmp, -branch beq, 281 | lsb inc,x rts, end-code 282 | 283 | code apply-sid 284 | 14 ldy,# 285 | :- sid lda,y d400 sta,y 286 | dey, -branch bpl, rts, end-code 287 | 288 | code notdone 289 | dex, 290 | 0 lda,# voice sta, 291 | .strget jsr, pause 1+ ora, +branch bne, 292 | voice inc, 293 | .strget jsr, pause 2+ ora, +branch bne, 294 | voice inc, 295 | .strget jsr, pause 3 + ora, +branch bne, 296 | 0 lda,# lsb sta,x msb sta,x 297 | rts, end-code 298 | :+ :+ :+ 299 | lsb sta,x rts, end-code 300 | 301 | : play 302 | voice0 do-commands 303 | voice1 do-commands 304 | voice2 do-commands voicedone 305 | a2 c@ wait begin notdone while 306 | voice0 voicetick 307 | voice1 voicetick 308 | voice2 voicetick voicedone 309 | wait apply-sid 310 | repeat drop ; 311 | 312 | : init-voices 313 | f sid-vol! 314 | 3 0 do i voice c! 0 pause i + 1+ c! 315 | 10 ctl c! 891a srad! loop ; 316 | 317 | : play-mml ( str1 str2 str3 -- ) 318 | \ init sentinels 319 | over + dup >r dup c@ >r 0 swap c! .str 320 | ! 321 | over + dup >r dup c@ >r 0 swap c! .str 322 | 2+ ! 323 | over + dup >r dup c@ >r 0 swap c! .str 324 | 2+ 2+ ! 325 | 326 | init-voices play 327 | 3 0 do i voice c! gate-off loop 328 | apply-sid 329 | 330 | \ restore sentinels 331 | r> r> c! r> r> c! r> r> c! ; 332 | 333 | :noname 334 | r> 1+ dup 2+ swap @ 2dup + 1- >r ; 335 | : mml" ( -- addr len ) 336 | literal compile, here >r 0 , 337 | begin >in @ '"' parse 338 | tuck here swap move dup allot 339 | dup r@ +! >in @ rot - = while 340 | refill drop repeat r> drop ; immediate 341 | 342 | base ! 343 | -------------------------------------------------------------------------------- /forth/mmldemo.fs: -------------------------------------------------------------------------------- 1 | require mml 2 | 3 | cr .( Frere Jaques) 4 | : frere-jaques 5 | mml" o3l4fgaffgafab->c&cc&cl8cdcl8cdcc&cc&cl8cd 8 | cl8cdcerd4crerd4crercrd4e8frg2&g4r1r1c8
d8cre8drf8ercrc8 37 | c8dre2&e4c8c8
d8crefrde1&e2r4" 40 | play-mml ; sarias-song cr 41 | -------------------------------------------------------------------------------- /forth/open.fs: -------------------------------------------------------------------------------- 1 | \ Open a logical file 2 | \ ioresult is 0 on success, kernal 3 | \ error # on failure. 4 | ( nameaddr namelen file# sa -- 5 | ioresult ) 6 | code open 7 | w stx, 8 | lsb 1+ lda,x \ a = file # 9 | lsb ldy,x \ y = sec. address 10 | $ba ldx, \ x = device 11 | $ffba jsr, \ SETLFS 12 | 13 | w ldx, 14 | lsb 2+ lda,x pha, \ a = namelen 15 | msb 3 + ldy,x 16 | lsb 3 + lda,x tax, pla, \ xy = nameptr 17 | $ffbd jsr, \ SETNAM 18 | 19 | $ffc0 jsr, \ OPEN 20 | +branch bcs, \ carry set = error 21 | 0 lda,# \ A is only valid on error 22 | :+ 23 | w ldx, 24 | inx, inx, inx, 25 | lsb sta,x 26 | 0 lda,# msb sta,x 27 | rts, end-code 28 | 29 | \ Close a logical file 30 | code close ( file# -- ) 31 | txa, pha, 32 | lsb lda,x \ x = file# 33 | $ffc3 jsr, \ CLOSE 34 | pla, tax, inx, 35 | rts, end-code 36 | -------------------------------------------------------------------------------- /forth/require.fs: -------------------------------------------------------------------------------- 1 | : hash ( addr u -- hash ) 2 | over + swap 0 -rot 3 | do $1f * i c@ + loop ; 4 | 5 | : included ( addr u -- ) 6 | 2dup hash (includes) 7 | here to (includes) , , included ; 8 | : include parse-name included ; 9 | 10 | : required ( addr u -- ) 11 | 2dup hash (includes) begin ?dup while 12 | 2dup 2+ @ = if 2drop 2drop exit then 13 | @ repeat drop included ; 14 | 15 | : require parse-name required ; 16 | 17 | hide hash 18 | -------------------------------------------------------------------------------- /forth/rnd.fs: -------------------------------------------------------------------------------- 1 | variable seed 2 | \ Random number generator from 3 | \ Starting Forth. MSB has better 4 | \ randomness than LSB, use split 5 | \ when getting bytes. 6 | : rnd ( -- u ) seed @ 7 | $7abd * $1b0f + dup seed ! ; 8 | -------------------------------------------------------------------------------- /forth/see.fs: -------------------------------------------------------------------------------- 1 | ( decompiles colon definitions 2 | to screen. try "see see". ) 3 | 4 | marker ---see--- 5 | 6 | header see latest 7 | 8 | ( points to a list with format 9 | src, dst, code ) 10 | variable branchptr 11 | 12 | variable my-xt 13 | 14 | \ branch types 15 | 0 constant #if 16 | 1 constant #else 17 | 2 constant #while 18 | 3 constant #leave 19 | 4 constant #repeat 20 | 5 constant #again 21 | 6 constant #until 22 | 23 | : ,branch ( val -- ) 24 | branchptr @ ! 2 branchptr +! ; 25 | : branch! ( src dst -- src ) 26 | over ,branch ,branch 27 | 0 branchptr @ c! 1 branchptr +! ; 28 | : type! ( u -- ) 29 | branchptr @ 1 - c! ; 30 | 31 | : reached-end ( addr -- addr flag ) 32 | 1 branchptr @ here ?do 33 | over i 2+ @ u< if drop 0 leave then 34 | 5 +loop ; 35 | 36 | :noname ( 0 xt nt -- nt? xt flag ) 37 | 2dup >xt = if swap rot then ; 38 | : xt>nt ( xt -- nt | 0 ) 39 | 0 swap literal dowords drop ; 40 | 41 | : 3+ 3 + ; : 4+ 4 + ; : 5+ 5 + ; 42 | 43 | : scan-0branch ( addr -- addr+5 ) 44 | dup 3+ @ 2dup branch! \ src dst src 45 | u> 0= if \ back 46 | #until type! then 5+ ; 47 | 48 | : skip-lits ( addr -- addr ) 49 | 3+ dup c@ + 1+ ; 50 | 51 | : scan-loop ( addr -- addr+5 ) 52 | \ correct #else to #leave 53 | 5+ branchptr @ here ?do 54 | dup i 2+ @ = if #leave i 4+ c! then 55 | 5 +loop ; 56 | 57 | : scan-jsr ( addr -- addr ) 58 | dup 1+ @ case 59 | ['] litc of 4+ endof 60 | ['] lit of 5+ endof 61 | ['] lits of skip-lits endof 62 | ['] (?do) of 5+ endof 63 | ['] (loop) of scan-loop endof 64 | ['] (+loop) of scan-loop endof 65 | ['] (of) of 5+ endof 66 | ['] 0branch of scan-0branch endof 67 | drop 3+ dup endcase ; 68 | 69 | \ it's a while-repeat if... 70 | \ 1) it's a backjump (repeat) 71 | \ 2) followed by dst of a fwd 0branch 72 | \ (while target) 73 | : while? ( jmpaddr -- jmpaddr flag ) 74 | \ backjump? 75 | dup dup 1+ @ u> 0= if 0 exit then 76 | \ 0branch fwd dst? 77 | 0 branchptr @ here ?do 78 | over 3+ i 2+ @ = if \ dst? 79 | #while i 4+ c! 80 | drop 1 leave then 5 +loop ; 81 | 82 | : scan-jmp ( addr -- addr ) 83 | dup 1+ @ dup my-xt @ u< if drop else 84 | 2dup branch! u> if #else else 85 | while? if #repeat else #again then 86 | then type! then ; 87 | 88 | : scan ( nt -- ) 89 | here branchptr ! 90 | >xt dup my-xt ! begin dup c@ case 91 | $20 of scan-jsr endof 92 | $4c of scan-jmp reached-end if 93 | drop exit then 3+ endof 94 | $e8 of 1+ endof \ inx 95 | $60 of reached-end if \ rts 96 | drop exit else 1+ then endof 97 | abort endcase again ; 98 | 99 | : print-xt ( xt -- ) 100 | dup xt>nt ?dup if name>string type drop 101 | else u. ." execute" then space ; 102 | 103 | : print-0branch ( addr -- addr+5 ) 104 | branchptr @ here do 105 | i @ over = if i 4+ c@ case 106 | #if of ." if " endof 107 | #while of ." while " endof 108 | #until of ." until " endof 109 | endcase leave then 110 | 5 +loop 5+ ; 111 | 112 | : print-lits ( addr -- addr ) 113 | 's' emit '"' emit space 114 | 4+ dup 1- c@ begin ?dup while 115 | over c@ emit 1 /string repeat 116 | '"' emit space ; 117 | 118 | : print-unloop ( addr -- addr+3 ) 119 | \ if followed by a leave, skip 120 | 3+ branchptr @ here do 121 | dup i @ = i 4+ c@ #leave = and if 122 | unloop exit then 5 +loop ." unloop " ; 123 | 124 | : print-of ( addr -- addr+5 ) 125 | 5+ ." over = if drop " ; 126 | 127 | : print-jsr ( addr -- addr ) 128 | dup 1 + @ case 129 | ['] lit of 3+ dup @ . 2+ endof 130 | ['] litc of 3+ dup c@ . 1+ endof 131 | ['] lits of print-lits endof 132 | ['] (do) of 3+ ." do " endof 133 | ['] (?do) of 5+ ." ?do " endof 134 | ['] (loop) of 5+ ." loop " endof 135 | ['] (+loop) of 5+ ." +loop " endof 136 | ['] (of) of print-of endof 137 | ['] 0branch of print-0branch endof 138 | ['] unloop of print-unloop endof 139 | print-xt 3+ dup 140 | endcase ; 141 | 142 | : remove-then ( addr -- ) 143 | branchptr @ here do i 2+ @ over = 144 | i 4+ c@ #if = and if 145 | 0 i 2+ ! then 5 +loop drop ; 146 | 147 | : print-jmp ( addr -- addr ) 148 | dup 1+ @ dup my-xt @ u< if print-xt 149 | else drop branchptr @ here ?do 150 | i @ over = if i 4+ c@ case 151 | #else of ." else " 152 | dup 3+ remove-then endof 153 | #leave of ." leave " endof 154 | #repeat of ." repeat " endof 155 | #again of ." again " endof 156 | abort endcase then 5 +loop then ; 157 | 158 | : .then ." then " ; 159 | : .begin ." begin " ; 160 | 161 | : print-to-branch ( addr -- addr ) 162 | branchptr @ here ?do 163 | dup i 2+ @ = if 164 | i 4+ c@ case 165 | #if of .then endof 166 | #else of .then endof 167 | #while of endof 168 | #leave of endof 169 | #repeat of .begin endof 170 | #again of .begin endof 171 | #until of .begin endof 172 | abort endcase then 5 +loop ; 173 | 174 | : print ( nt -- ) 175 | ':' emit space 176 | dup name>string type space 177 | dup c@ $80 and if ." immediate " then 178 | >xt begin 179 | print-to-branch dup c@ case 180 | $20 of print-jsr endof 181 | $4c of print-jmp reached-end if 182 | drop ';' emit cr exit then 3+ endof 183 | $e8 of ." drop " 1+ endof \ inx 184 | $60 of \ rts 185 | reached-end if 186 | drop ';' emit cr exit else 187 | ." exit " 1+ then endof 188 | endcase again ; 189 | 190 | define see 191 | parse-name 2dup find-name \ c-addr u nt 192 | ?dup 0= if notfound then nip nip \ nt 193 | dup scan print ; 194 | 195 | to latest 196 | -------------------------------------------------------------------------------- /forth/sid.fs: -------------------------------------------------------------------------------- 1 | \ low-level sid commands 2 | base @ hex 3 | 4 | 0 value voice 5 | 6 | : voice! 7 * to voice ; 7 | 8 | : freq! d400 voice + ! ; 9 | : pulse! d402 voice + ! ; 10 | : control! d404 voice + c! ; 11 | 12 | : cutoff! d415 ! ; 13 | : filter! d417 c! ; 14 | : volume! d418 c! ; 15 | 16 | ( write adsr ) 17 | : srad! ( SR AD -- ) d405 voice + ! ; 18 | 19 | here \ 95 notes from c0, pal 20 | 116 , 127 , 138 , 14b , 15e , 173 , 21 | 189 , 1a1 , 1ba , 1d4 , 1f0 , 20d , 22 | 22c , 24e , 271 , 296 , 2bd , 2e7 , 23 | 313 , 342 , 374 , 3a8 , 3e0 , 41b , 24 | 459 , 49c , 4e2 , 52c , 57b , 5ce , 25 | 627 , 684 , 6e8 , 751 , 7c0 , 836 , 26 | 8b3 , 938 , 9c4 , a59 , af6 , b9d , 27 | c4e , d09 , dd0 , ea2 , f81 , 106d , 28 | 1167 , 1270 , 1388 , 14b2 , 15ed , 29 | 173a , 189c , 1a13 , 1ba0 , 1d44 , 30 | 1f02 , 20da , 22ce , 24e0 , 2711 , 31 | 2964 , 2bda , 2e75 , 3138 , 3426 , 32 | 3740 , 3a89 , 3e04 , 41b4 , 459c , 33 | 49c0 , 4e22 , 52c8 , 57b4 , 5ceb , 34 | 6271 , 684c , 6e80 , 7512 , 7c08 , 35 | 8368 , 8b38 , 9380 , 9c45 , a590 , 36 | af68 , b9d6 , c4e3 , d098 , dd00 , 37 | ea24 , f810 , 38 | : note! ( i -- ) 39 | 2* literal + @ freq! ; 40 | 41 | : sid-demo 42 | f volume! 43 | 9 srad! 44 | 5f 0 do 45 | 10 control! 46 | i note! 47 | 11 control! 48 | 200 0 do loop 49 | loop ; 50 | 51 | base ! 52 | -------------------------------------------------------------------------------- /forth/sin.fs: -------------------------------------------------------------------------------- 1 | base @ hex 2 | ( cos 0-359 degrees 3 | could be more space optimized ) 4 | header sintab 5 | 7fff , 823b , 8477 , 86b2 , 6 | 88ed , 8b27 , 8d60 , 8f98 , 7 | 91cf , 9405 , 9639 , 986b , 8 | 9a9c , 9cca , 9ef6 , a120 , 9 | a347 , a56b , a78d , a9ab , 10 | abc6 , adde , aff2 , b202 , 11 | b40f , b617 , b81b , ba1b , 12 | bc16 , be0d , bfff , c1ec , 13 | c3d3 , c5b5 , c792 , c96a , 14 | cb3b , cd07 , cecd , d08c , 15 | d246 , d3f8 , d5a5 , d74a , 16 | d8e9 , da81 , dc12 , dd9c , 17 | df1e , e099 , e20c , e378 , 18 | e4dc , e638 , e78c , e8d9 , 19 | ea1c , eb58 , ec8b , edb6 , 20 | eed8 , eff2 , f103 , f20b , 21 | f30a , f400 , f4ee , f5d2 , 22 | f6ac , f77e , f846 , f905 , 23 | f9bb , fa67 , fb09 , fba2 , 24 | fc31 , fcb7 , fd32 , fda4 , 25 | fe0d , fe6b , fec0 , ff0a , 26 | ff4b , ff82 , ffaf , ffd2 , 27 | ffeb , fffa , ffff , fffa , 28 | ffeb , ffd2 , ffaf , ff82 , 29 | ff4b , ff0a , fec0 , fe6b , 30 | fe0d , fda4 , fd32 , fcb7 , 31 | fc31 , fba2 , fb09 , fa67 , 32 | f9bb , f905 , f846 , f77e , 33 | f6ac , f5d2 , f4ee , f400 , 34 | f30a , f20b , f103 , eff2 , 35 | eed8 , edb6 , ec8b , eb58 , 36 | ea1c , e8d9 , e78c , e638 , 37 | e4dc , e378 , e20c , e099 , 38 | df1e , dd9c , dc12 , da81 , 39 | d8e9 , d74a , d5a5 , d3f8 , 40 | d246 , d08c , cecd , cd07 , 41 | cb3b , c96a , c792 , c5b5 , 42 | c3d3 , c1ec , bfff , be0d , 43 | bc16 , ba1b , b81b , b617 , 44 | b40f , b202 , aff2 , adde , 45 | abc6 , a9ab , a78d , a56b , 46 | a347 , a120 , 9ef6 , 9cca , 47 | 9a9c , 986b , 9639 , 9405 , 48 | 91cf , 8f98 , 8d60 , 8b27 , 49 | 88ed , 86b2 , 8477 , 823b , 50 | 7fff , 7dc3 , 7b87 , 794c , 51 | 7711 , 74d7 , 729e , 7066 , 52 | 6e2f , 6bf9 , 69c5 , 6793 , 53 | 6562 , 6334 , 6108 , 5ede , 54 | 5cb7 , 5a93 , 5871 , 5653 , 55 | 5438 , 5220 , 500c , 4dfc , 56 | 4bef , 49e7 , 47e3 , 45e3 , 57 | 43e8 , 41f1 , 3fff , 3e12 , 58 | 3c2b , 3a49 , 386c , 3694 , 59 | 34c3 , 32f7 , 3131 , 2f72 , 60 | 2db8 , 2c06 , 2a59 , 28b4 , 61 | 2715 , 257d , 23ec , 2262 , 62 | 20e0 , 1f65 , 1df2 , 1c86 , 63 | 1b22 , 19c6 , 1872 , 1725 , 64 | 15e2 , 14a6 , 1373 , 1248 , 65 | 1126 , 100c , efb , df3 , 66 | cf4 , bfe , b10 , a2c , 67 | 952 , 880 , 7b8 , 6f9 , 68 | 643 , 597 , 4f5 , 45c , 69 | 3cd , 347 , 2cc , 25a , 70 | 1f1 , 193 , 13e , f4 , 71 | b3 , 7c , 4f , 2c , 72 | 13 , 4 , 0 , 4 , 73 | 13 , 2c , 4f , 7c , 74 | b3 , f4 , 13e , 193 , 75 | 1f1 , 25a , 2cc , 347 , 76 | 3cd , 45c , 4f5 , 597 , 77 | 643 , 6f9 , 7b8 , 880 , 78 | 952 , a2c , b10 , bfe , 79 | cf4 , df3 , efb , 100c , 80 | 1126 , 1248 , 1373 , 14a6 , 81 | 15e2 , 1725 , 1872 , 19c6 , 82 | 1b22 , 1c86 , 1df2 , 1f65 , 83 | 20e0 , 2262 , 23ec , 257d , 84 | 2715 , 28b4 , 2a59 , 2c06 , 85 | 2db8 , 2f72 , 3131 , 32f7 , 86 | 34c3 , 3694 , 386c , 3a49 , 87 | 3c2b , 3e12 , 3fff , 41f1 , 88 | 43e8 , 45e3 , 47e3 , 49e7 , 89 | 4bef , 4dfc , 500c , 5220 , 90 | 5438 , 5653 , 5871 , 5a93 , 91 | 5cb7 , 5ede , 6108 , 6334 , 92 | 6562 , 6793 , 69c5 , 6bf9 , 93 | 6e2f , 7066 , 729e , 74d7 , 94 | 7711 , 794c , 7b87 , 7dc3 , 95 | 96 | : sin #360 mod 2* ['] sintab + @ ; 97 | : cos 5a + sin ; 98 | 99 | \ a = amplitude 100 | \ r = degree [0..359] 101 | \ todo: lerp? 102 | : *cos ( a r -- b ) 103 | cos over 2* 1+ um* nip swap - ; 104 | : *sin ( a r -- b ) 105 | sin over 2* 1+ um* nip swap - ; 106 | base ! 107 | -------------------------------------------------------------------------------- /forth/sprite.fs: -------------------------------------------------------------------------------- 1 | here 2 | $80 c, $40 c, $20 c, $10 c, 3 | 8 c, 4 c, 2 c, 1 c, 4 | : 80lsr literal + c@ ; 5 | : setbit ( n addr -- ) 6 | swap 80lsr over c@ or swap c! ; 7 | : clrbit ( n addr -- ) 8 | swap 80lsr invert over c@ and swap c! ; 9 | 10 | : 7s- 7 swap - ; 11 | 12 | : sp-x! ( x n -- ) 13 | 2dup 2* $d000 + c! \ lsb 14 | swap $100 and if 7s- $d010 setbit 15 | else 7s- $d010 clrbit then ; 16 | 17 | : sp-y! ( y n -- ) 2* $d001 + c! ; 18 | 19 | : sp-xy! ( x y n -- ) 20 | tuck sp-y! sp-x! ; 21 | 22 | ( expand width/height ) 23 | : sp-1w ( n -- ) 7s- $d01d clrbit ; 24 | : sp-2w ( n -- ) 7s- $d01d setbit ; 25 | : sp-1h ( n -- ) 7s- $d017 clrbit ; 26 | : sp-2h ( n -- ) 7s- $d017 setbit ; 27 | 28 | : sp-on ( n -- ) 7s- $d015 setbit ; 29 | : sp-off ( n -- ) 7s- $d015 clrbit ; 30 | 31 | : sp-col! ( c n -- ) $d027 + c! ; 32 | 33 | ( read sprite byte ) 34 | : ks 35 | 2* source drop >in @ + c@ 36 | 1 >in +! '.' <> 1 and or ; 37 | : rdb ( addr -- addr ) 38 | 0 ks ks ks ks ks ks ks ks 39 | over c! 1+ ; 40 | 41 | ( read sprite to address ) 42 | : sp-data ( addr -- ) 43 | #21 0 do refill drop 44 | rdb rdb rdb loop drop ; 45 | -------------------------------------------------------------------------------- /forth/spritedemo.fs: -------------------------------------------------------------------------------- 1 | require rnd 2 | require sprite 3 | 4 | $340 sp-data 5 | DDD..UU.U.RRR..EEEEX...X 6 | DDD..UU.U.RRR..EEEEX...X 7 | D.DD.UU.U.R.RR.E....X.X. 8 | D.DD.UU.U.R.RR.E....X.X. 9 | D..D.UU.U.RRR..EEE...X.. 10 | D..D.UU.U.RRR..EEE...X.. 11 | D..D.UU.U.R.RR.E....X.X. 12 | D..D.UU.U.R.RR.E....X.X. 13 | DDD...UUU.R.RR.EEEEX...X 14 | DDD...UUU.R.RR.EEEEX...X 15 | 16 | FFFF..OO..RRR.TTTTTTH..H 17 | FFFF.OOOO.RRR.TTTTTTH..H 18 | FF...O..O.R.RR..TT..H..H 19 | FF...O..O.R.RR..TT..H..H 20 | FFFF.O..O.RRR...TT..HHHH 21 | FFFF.O..O.RRR...TT..HHHH 22 | FF...O..O.R.RR..TT..H..H 23 | FF...O..O.R.RR..TT..H..H 24 | FF....OO..R.RR..TT..H..H 25 | FF....OO..R.RR..TT..H..H 26 | 27 | : rnds rnd #13 rshift ; 28 | : demo 29 | 7 begin 30 | $340 $40 / over $7f8 + c! 31 | dup sp-on 32 | 1 over + over sp-col! 33 | ?dup while 1- repeat 34 | 35 | begin 36 | rnd rnd rnds sp-xy! 37 | rnds sp-1h rnds sp-2h 38 | rnds sp-1w rnds sp-2w 39 | key? until key drop 40 | 8 0 do i sp-off loop ; 41 | demo 42 | -------------------------------------------------------------------------------- /forth/sys.fs: -------------------------------------------------------------------------------- 1 | ( Calls Basic/Kernal routines. 2 | Uses ar/xr/yr/sr for register I/O. ) 3 | $30c value ar $30d value xr 4 | $30e value yr $30f value sr 5 | code sys ( addr -- ) 6 | lsb lda,x $14 sta, msb lda,x $15 sta, 7 | txa, pha, 8 | $e130 jsr, \ perform [sys] 9 | pla, tax, inx, rts, end-code 10 | -------------------------------------------------------------------------------- /forth/timer.fs: -------------------------------------------------------------------------------- 1 | \ jiffy clock timer 2 | 3 | code start ( -- clk ) 4 | dex, sei, 5 | $a1 lda, msb sta,x 6 | $a2 lda, cli, lsb sta,x 7 | rts, end-code 8 | 9 | \ stop & print elapsed time 10 | : stop ( clk -- ) 11 | start swap - base @ swap decimal 12 | #60 /mod s>d <# '.' hold #s #> type 13 | #1000 #60 */ s>d <# # # # #> type 14 | base ! ; 15 | 16 | ( : timertest ." $1000 loops..." 17 | start $1000 0 do loop stop ." s" cr ; 18 | timertest ) 19 | -------------------------------------------------------------------------------- /forth/turnkey.fs: -------------------------------------------------------------------------------- 1 | marker ---turnkey--- 2 | 3 | $9fff value top 4 | $9fff value oldtop 5 | start @ value oldstart 6 | 7 | : top! ( addr -- ) 8 | latest swap top latest - 9 | 2dup - to latest over to top 10 | swap over - swap 1+ move ; 11 | 12 | : restore-forth 13 | oldtop top! 14 | oldstart start ! 15 | ---turnkey--- ; 16 | 17 | : newstart 18 | restore-forth 19 | start @ execute ; 20 | 21 | : save-pack ( strptr strlen -- ) 22 | start @ to oldstart 23 | top to oldtop 24 | ['] newstart start ! 25 | here $20 + top latest - + top! 26 | $801 top 1+ $d word count saveb 27 | restore-forth ; 28 | 29 | : save-prg ( strptr strlen -- ) 30 | top to latest ['] 0 1+ top! \ constant 0 31 | save-pack ; 32 | 33 | hide oldtop 34 | hide oldstart 35 | hide restore-forth 36 | hide newstart 37 | -------------------------------------------------------------------------------- /forth/turtle.fs: -------------------------------------------------------------------------------- 1 | header init ( -- ) 2 | header forward ( px -- ) 3 | header back ( px -- ) 4 | header left ( deg -- ) 5 | header right ( deg -- ) 6 | header penup ( -- ) 7 | header pendown ( -- ) 8 | header turtle@ ( -- x y deg ) 9 | header turtle! ( x y deg -- ) 10 | header moveto ( x y deg -- ) 11 | 12 | require gfx 13 | require sin 14 | 15 | latest 16 | 17 | variable tx variable ty \ 10.6 fixedpoint 18 | variable ta 0 value tp 19 | 20 | code ls \ left shift x6 21 | lsb asl,x msb rol,x lsb asl,x msb rol,x 22 | lsb asl,x msb rol,x lsb asl,x msb rol,x 23 | lsb asl,x msb rol,x lsb asl,x msb rol,x 24 | rts, end-code 25 | 26 | code rs \ right shift x6 (sign extend) 27 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 28 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 29 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 30 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 31 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 32 | msb lda,x $80 cmp,# msb ror,x lsb ror,x 33 | rts, end-code 34 | 35 | define pendown 36 | 1 to tp tx @ rs ty @ rs plot ; 37 | define penup 0 to tp ; 38 | 39 | define moveto 40 | ta ! ls ty ! ls tx ! 41 | pendown ; 42 | define init hires 7 clrcol 43 | $a0 $64 #270 moveto ; 44 | 45 | define right ta +! ; 46 | define left negate right ; 47 | define forward 48 | ls ta @ 2dup *cos tx +! *sin ty +! 49 | tp if tx @ rs ty @ rs line then ; 50 | define back 51 | #180 right forward #180 right ; 52 | 53 | define turtle@ 54 | tx @ ty @ ta @ ; 55 | define turtle! 56 | ta ! ty ! tx ! pendown ; 57 | 58 | to latest 59 | 60 | ( 61 | \ --- demo - not working :( 62 | 63 | : polyspiral 64 | ." init distance? " interpret 65 | ." angle? " interpret 66 | ." distance step? " interpret 67 | init 68 | $64 >r begin 69 | 2 pick forward 70 | over left 71 | rot over + -rot 72 | r> 1- dup >r 0= until r> 2drop 2drop 73 | 5 $d020 c! key drop lores 0 $d020 c! ; 74 | 75 | : inward 76 | ." distance? " interpret 77 | ." init angle? " interpret 78 | ." angle step? " interpret 79 | init 80 | begin 2 pick forward 81 | over right 82 | tuck + $168 mod swap again ; 83 | ) 84 | -------------------------------------------------------------------------------- /forth/v.fs: -------------------------------------------------------------------------------- 1 | marker ---editor--- 2 | 3 | header v 4 | 5 | latest \ begin hiding words 6 | 7 | $d value lf 8 | 9 | $a001 value bufstart \ use $a000-$cbff 10 | 11 | \ eof points to 0 sentinel 12 | variable eof ( ram eof ) 13 | 0 eof ! 14 | 15 | variable homepos \ screen home position 16 | variable curlinestart 17 | 18 | ( cursor screen pos ) 19 | variable curx 20 | variable cury 21 | 0 value need-refresh 22 | variable line-dirty 23 | 0 value insert \ flag 24 | 25 | : line-dirty! 1 line-dirty c! ; 26 | 27 | \ counted string 28 | variable filename $f allot 29 | 0 filename c! 30 | 31 | : editpos curlinestart @ curx @ + ; 32 | 33 | create foundeol 34 | clc, tya, w adc, lsb sta,x 35 | 2 bcc, msb inc,x rts, end-code 36 | 37 | code print-line ( addr -- addr ) 38 | lsb ldy,x w sty, 39 | msb ldy,x w 1+ sty, 40 | 0 ldy,# 41 | here w lda,(y) 42 | 0 cmp,# foundeol -branch beq, 43 | $e716 jsr, iny, \ putchar 44 | $d cmp,# foundeol -branch beq, jmp, 45 | 46 | \ nb: may return eof 47 | code find-next-line ( addr -- addr ) 48 | lsb ldy,x w sty, 49 | msb ldy,x w 1+ sty, 50 | 0 ldy,# 51 | here 52 | w lda,(y) 53 | iny, 54 | 0 cmp,# 55 | foundeol -branch beq, 56 | $d cmp,# 57 | foundeol -branch beq, 58 | jmp, 59 | : find-next-line ( addr -- addr ) 60 | dup eof @ u< if find-next-line then ; 61 | 62 | : next-line-start 63 | curlinestart @ find-next-line ; 64 | 65 | : linelen 66 | next-line-start 67 | curlinestart @ - 68 | dup if 1- then ; 69 | 70 | : cursor-scr-pos 71 | cury @ $28 * 72 | curx @ linelen min + 73 | $400 + ( addr ) ; 74 | 75 | : sol 0 curx ! ; 76 | 77 | \ ram + io + kernal rom 78 | code rom-kernal 79 | $36 lda,# 1 sta, rts, end-code 80 | \ ram + io + ram 81 | code ram-kernal 82 | $35 lda,# 1 sta, rts, end-code 83 | 84 | : reset-buffer 85 | 0 bufstart 1- c! 86 | bufstart 1+ eof ! 87 | 0 eof @ c! sol 0 cury ! 88 | lf bufstart c! 89 | bufstart homepos ! 90 | bufstart curlinestart ! ; 91 | 92 | $7c0 value status-pos 93 | 94 | : show-page 95 | status-pos c@ page status-pos c! 96 | homepos @ 97 | $18 0 do print-line loop 98 | drop ; 99 | 100 | : clear-status ( -- ) 101 | status-pos $18 bl fill ; 102 | 103 | : set-status ( c -- ) 104 | clear-status status-pos c! ; 105 | 106 | : cleanup ( bordercolor bgcolor 107 | cursorcolor -- ) 108 | 0 $28a c! \ default key repeat 109 | [ lsb lda,x $286 sta, inx, 110 | lsb lda,x $d020 sta, 111 | msb lda,x $d021 sta, inx, ] 112 | page ; 113 | 114 | : fit-curx-in-linelen 115 | linelen curx @ min curx ! ; 116 | 117 | : cur-down 118 | curlinestart @ ( curline ) 119 | find-next-line dup ( 2xnextline ) 120 | eof @ u< 0= if drop exit then 121 | curlinestart ! 122 | cury @ $17 < if 1 cury +! else 123 | homepos @ find-next-line homepos ! 124 | $428 $400 $398 move 125 | line-dirty! 126 | then 127 | fit-curx-in-linelen ; 128 | 129 | : cr= lf = ; 130 | : eol= dup 0= swap cr= or ; 131 | : space= dup cr= swap bl = or ; 132 | : eof= eof @ = ; 133 | 134 | : find-start-of-line ( addr -- addr ) 135 | begin 1- dup c@ eol= until 1+ ; 136 | 137 | : goto ( line ) 138 | sol dup cury ! 139 | homepos @ swap 140 | ?dup if 0 141 | do find-next-line loop then 142 | curlinestart ! ; 143 | 144 | : cur-up 145 | curlinestart @ 146 | 1- 147 | dup c@ 0= if drop exit then 148 | find-start-of-line 149 | curlinestart ! 150 | fit-curx-in-linelen 151 | cury @ 0= if 152 | curlinestart @ homepos ! 153 | $400 $428 $398 move 154 | line-dirty! 155 | else 156 | -1 cury +! 157 | then ; 158 | 159 | : cur-left 160 | curx @ ?dup if 1- curx ! then ; 161 | 162 | : at-eol editpos c@ eol= ; 163 | 164 | : cur-right at-eol editpos 1+ c@ 165 | eol= or if exit then 1 curx +! ; 166 | 167 | : eol 168 | linelen dup if 1- then curx ! ; 169 | 170 | \ left, or up+eol if we're at xpos 0 171 | : rewind-cur 172 | curx @ 0= if bufstart editpos <> if 173 | cur-up eol then else cur-left then ; 174 | 175 | : is-wordstart 176 | editpos 1- c@ space= 177 | editpos c@ space= 0= and ; 178 | 179 | : word-back rewind-cur begin 180 | editpos bufstart = is-wordstart or 181 | 0= while rewind-cur repeat ; 182 | 183 | \ right, or down+sol if we're at EOL. 184 | \ ret 1 if we cant advance 185 | : advance-cur editpos 186 | curx @ linelen 1- = linelen 0= or if 187 | sol cur-down else cur-right then 188 | editpos = ; 189 | 190 | : word-forward 191 | begin editpos eof= editpos c@ space= 192 | or advance-cur or until ; 193 | 194 | : word-end 195 | begin advance-cur editpos 1+ dup 196 | eof= swap c@ space= or or until ; 197 | 198 | : setcur ( x y -- ) 199 | xr ! yr ! $e50c sys ; 200 | 201 | : refresh-line 202 | cury @ $28 * $400 + $28 bl fill 203 | 0 cury @ setcur 204 | curlinestart @ print-line drop ; 205 | 206 | 0 value !"mode \ not quote-mode 207 | 208 | : ins-start 209 | -1 editpos curlinestart @ ?do 210 | i c@ '"' = xor loop to !"mode 211 | 1 to insert 'i' set-status ; 212 | 213 | : repl-start 214 | 2 to insert 'r' set-status ; 215 | 216 | : force-right 217 | linelen if 1 curx +! then ; 218 | 219 | : ins-stop cur-left 0 to insert 220 | clear-status ; 221 | 222 | : need-refresh! 1 to need-refresh ; 223 | 224 | : show-loc ( addr -- ) 225 | dup find-start-of-line dup homepos ! 226 | dup curlinestart ! - curx ! 0 cury ! 227 | need-refresh! clear-status ; 228 | 229 | : nipchar 230 | editpos 1+ eof= if exit then 231 | editpos 1+ editpos 232 | eof @ editpos - move 233 | -1 eof +! ; 234 | 235 | : join-lines 236 | \ too long to join? 237 | curlinestart @ 238 | find-next-line find-next-line 239 | curlinestart @ - $28 > 240 | if exit then 241 | need-refresh! 242 | linelen 0= if nipchar exit then 243 | 244 | cury @ curx @ curlinestart @ 245 | 246 | editpos 247 | cur-down 248 | editpos = if 2drop drop exit then 249 | sol 250 | linelen if 251 | bl editpos 1- c! \ cr => space 252 | else nipchar then 253 | 254 | curlinestart ! curx ! cury ! ; 255 | 256 | : backspace 257 | curx @ if cur-left nipchar line-dirty! 258 | then ; 259 | 260 | : del-char 261 | at-eol if exit then 262 | force-right backspace ; 263 | 264 | : repl-char 265 | editpos c! line-dirty! ; 266 | 267 | : ins-char 268 | dup lf <> linelen $26 > and if 269 | drop exit then 270 | 271 | editpos 272 | editpos 1+ 273 | eof @ editpos - 274 | move 275 | editpos c! 276 | 1 curx +! 277 | 1 eof +! 278 | 0 eof @ c! 279 | line-dirty! ; 280 | 281 | $9d value left 282 | $11 value down 283 | $91 value up 284 | $1d value right 285 | 286 | : ins-right 287 | curx @ linelen 1- = if 288 | force-right else cur-right then ; 289 | 290 | : do-insert 291 | [ \ nbsp => space 292 | lsb lda,x $a0 cmp,# +branch bne, 293 | $20 lda,# lsb sta,x 294 | \ shift+return => return 295 | :+ $8d cmp,# +branch bne, 296 | $d lda,# lsb sta,x :+ ] 297 | 298 | dup case 299 | '"' of !"mode 0= to !"mode endof 300 | $5f of ins-stop drop exit endof \ <- 301 | $14 of backspace drop exit endof \ inst 302 | $94 of del-char drop exit endof \ del 303 | lf of ins-char cur-down sol show-page 304 | exit endof endcase 305 | 306 | \ handles control chars outside quotes 307 | dup $7f and $20 < !"mode and if 308 | dup case 309 | left of cur-left drop exit endof 310 | right of ins-right drop exit endof 311 | up of cur-up drop exit endof 312 | down of cur-down drop exit endof 313 | endcase drop exit then 314 | 315 | insert 2 = if at-eol if 316 | ins-start ins-char else repl-char 317 | 1 curx +! then 318 | else ins-char then ; 319 | 320 | : del-word 321 | line-dirty! 322 | begin at-eol if exit then 323 | editpos c@ del-char space= 324 | until ; 325 | 326 | variable clip $26 allot 327 | variable clip-count 328 | 0 clip-count ! 329 | 330 | : yank-line linelen clip-count ! 331 | curlinestart @ clip linelen move ; 332 | 333 | : del-between ( addr ) 334 | 2dup swap - -rot ( off a1 a2 ) 335 | eof @ over - move eof +! 336 | eof @ editpos = if 337 | 0 eof @ ! 1 eof +! then 338 | need-refresh! ; 339 | 340 | : del-line 341 | sol yank-line 342 | ( contract buffer ) 343 | next-line-start curlinestart @ 344 | del-between ; 345 | 346 | : del-to-eol 347 | next-line-start 1- editpos 348 | del-between ; 349 | 350 | create fbuf #39 allot 351 | 0 fbuf c! 352 | 353 | : match? ( addr -- found? ) 354 | fbuf c@ fbuf + 1+ fbuf 1+ do dup c@ i 355 | c@ <> if unloop drop 0 exit 356 | then 1+ loop ; 357 | 358 | : do-match ( -- ) 359 | eof @ editpos 1+ ?do i match? if 360 | i show-loc unloop exit then loop 361 | editpos bufstart ?do i match? if 362 | i show-loc unloop exit then loop 363 | ." not found" ; 364 | 365 | : word-len ( -- ) 366 | 1 begin dup editpos + dup c@ space= 0= 367 | swap eof @ < AND 368 | while 1+ repeat ; 369 | 370 | : write-file filename c@ 0= if 371 | ." no filename" exit then 372 | 373 | rom-kernal 374 | page 375 | 376 | \ scratch old file 377 | here 378 | 's' over c! 1+ 379 | '0' over c! 1+ 380 | ':' over c! 1+ 381 | filename 1+ over filename c@ move 382 | filename c@ + lf swap c! 383 | here filename c@ 4 + 384 | $f $f open ioabort $f close 385 | 386 | bufstart eof @ 387 | filename count saveb 388 | key to need-refresh ; 389 | 390 | : open-line 391 | sol lf ins-char sol 392 | ins-start 393 | need-refresh! ; 394 | 395 | : paste-line 396 | open-line ins-stop 397 | ( make room for clip contents ) 398 | curlinestart @ 399 | dup clip-count @ + 400 | eof @ 1+ curlinestart @ - move 401 | ( copy from clip ) 402 | clip 403 | curlinestart @ 404 | clip-count @ move 405 | ( update eof ) 406 | clip-count @ eof +! ; 407 | 408 | : force-down editpos cur-down editpos = 409 | if eol force-right lf ins-char cur-down 410 | then ; 411 | 412 | : append force-right ins-start ; 413 | 414 | : append-line eol append ; 415 | 416 | : delete-enter 417 | 'd' set-status 418 | key case 419 | 'w' of del-word endof 420 | 'd' of del-line endof 421 | endcase clear-status ; 422 | 423 | : find-enter 424 | 0 $18 setcur clear-status '/' emit 425 | fbuf 1+ #38 accept fbuf c! 426 | do-match ; 427 | 428 | : find-under 429 | 0 $18 setcur clear-status '/' emit 430 | is-wordstart 0= if word-back then 431 | editpos fbuf 1+ word-len dup fbuf c! 432 | move 433 | fbuf 1+ fbuf c@ type bl emit 434 | do-match ; 435 | 436 | : page-up 437 | $c 0 do cur-up refresh-line loop ; 438 | 439 | : page-down 440 | $c 0 do cur-down refresh-line loop ; 441 | 442 | : go-enter 443 | sol 0 cury ! 444 | bufstart dup homepos ! curlinestart ! 445 | need-refresh! ; 446 | : go-sof 447 | \ can be much optimized... 448 | bufstart eof= if exit then 449 | eof @ 1- find-start-of-line 450 | dup curlinestart ! homepos ! 451 | sol 452 | $17 begin 453 | homepos @ 1- find-start-of-line 454 | homepos ! 455 | 1- dup 0= 456 | homepos @ bufstart = or 457 | until 458 | $17 swap - dup cury ! 0 swap setcur 459 | need-refresh! ; 460 | 461 | : repl-under key repl-char ; 462 | 463 | : line-down 464 | next-line-start 465 | eof= if exit then homepos @ 466 | find-next-line homepos ! 467 | next-line-start curlinestart ! 468 | sol need-refresh! ; 469 | 470 | : go-home 0 goto ; 471 | 472 | : line-up cury @ next-line-start 473 | go-home cur-up curlinestart ! cury ! 474 | need-refresh! ; 475 | 476 | : yank key 'y' = if yank-line then ; 477 | 478 | : open-line-down force-down 479 | open-line ; 480 | 481 | : paste-line-down force-down 482 | paste-line ; 483 | 484 | : change-word key 'w' = if 485 | del-word bl ins-char cur-left 486 | ins-start then ; 487 | 488 | : substitute-char del-char ins-start ; 489 | 490 | : substitute-line del-line open-line 491 | ins-start ; 492 | 493 | : go-last $17 goto ; 494 | 495 | : go-mid $c goto ; 496 | 497 | : change-line del-to-eol ins-start ; 498 | 499 | : findchar ( dir ) 500 | curx @ swap key begin 501 | over editpos + c@ eol= invert while 502 | over curx +! dup editpos c@ = if 503 | 2drop drop exit then repeat 504 | 2drop curx ! ; 505 | 506 | : findchar-fwd 1 findchar ; 507 | 508 | : findchar-back -1 findchar ; 509 | 510 | \ key handler table 511 | \ semi-ordered by most-used 512 | header keytab 513 | left c, ' cur-left , 514 | right c, ' cur-right , 515 | up c, ' cur-up , 516 | down c, ' cur-down , 517 | 'h' c, ' cur-left , 518 | 'l' c, ' cur-right , 519 | 'k' c, ' cur-up , 520 | 'j' c, ' cur-down , 521 | '$' c, ' eol , 522 | '0' c, ' sol , 523 | $13 c, ' sol , 524 | 'i' c, ' ins-start , 525 | 'R' c, ' repl-start , 526 | 'a' c, ' append , 527 | 'A' c, ' append-line , 528 | 's' c, ' substitute-char , 529 | 'S' c, ' substitute-line , 530 | 'J' c, ' join-lines , 531 | 'O' c, ' open-line , 532 | 'P' c, ' paste-line , 533 | 'X' c, ' backspace , 534 | 'x' c, ' del-char , 535 | 'D' c, ' del-to-eol , 536 | 'C' c, ' change-line , 537 | 'b' c, ' word-back , 538 | 'e' c, ' word-end , 539 | 'd' c, ' delete-enter , 540 | 'g' c, ' go-enter , 541 | 'r' c, ' repl-under , 542 | 'w' c, ' word-forward , 543 | 'y' c, ' yank , 544 | 'o' c, ' open-line-down , 545 | 'p' c, ' paste-line-down , 546 | 'c' c, ' change-word , 547 | 'n' c, ' do-match , 548 | '+' c, ' line-down , 549 | '-' c, ' line-up , 550 | $15 c, ' page-up , \ ctrl+u 551 | 4 c, ' page-down , \ ctrl+d 552 | $17 c, ' del-word , \ ctrl+w 553 | '*' c, ' find-under , 554 | '/' c, ' find-enter , 555 | 'G' c, ' go-sof , 556 | 'H' c, ' go-home , 557 | 'L' c, ' go-last , 558 | 'M' c, ' go-mid , 559 | 'f' c, ' findchar-fwd , 560 | 'F' c, ' findchar-back , 561 | 0 c, 562 | \ --- key handlers end 563 | 564 | : do-main ( key -- quit? ) 565 | dup ['] keytab begin 2dup c@ = if 566 | 1+ nip @ execute drop 0 exit then 567 | 3 + dup c@ 0= until 2drop 568 | 569 | case \ keys that can quit 570 | 'Z' of key case 571 | 'Z' of write-file -1 exit endof 572 | endcase endof 573 | ':' of 574 | ':' set-status 575 | key case 576 | 'w' of 577 | 1 $18 setcur 'w' emit key case 578 | lf of write-file endof 579 | '!' of 580 | need-refresh! 581 | '!' emit here $f accept 582 | dup 0= if clear-status exit 583 | then 584 | filename c! here 585 | filename count move 586 | write-file 587 | endof endcase 588 | endof 589 | 'q' of -1 exit endof 590 | clear-status 591 | endcase 592 | endof 593 | endcase 0 ; 594 | 595 | : main-loop 596 | \ init colors -- border bgcol curscol 597 | [ dex, $d020 lda, lsb sta,x 598 | $d021 lda, msb sta,x 599 | dex, $286 lda, lsb sta,x 600 | 601 | 2 lda,# $d021 sta, 602 | $a lda,# $d020 sta, 603 | 1 lda,# $286 sta, ] 604 | $d800 $400 1 fill 605 | 606 | show-page 607 | 608 | begin ram-kernal 609 | 0 to need-refresh 610 | 0 line-dirty c! 611 | 612 | depth \ stack check[ 613 | 614 | \ show cursor 615 | insert 0= if curx @ 616 | linelen dup if 1- then min 617 | curx c! then cursor-scr-pos 618 | dup @ $80 xor swap c! 619 | 620 | key 621 | 622 | \ hide cursor 623 | cursor-scr-pos dup @ $80 xor 624 | swap c! 625 | 626 | \ f7 627 | dup $88 = if 2drop cleanup rom-kernal 628 | bufstart eof @ bufstart - 1- 629 | evaluate quit then 630 | 631 | insert if do-insert else do-main if 632 | drop rom-kernal cleanup exit then then 633 | 634 | need-refresh if show-page else 635 | line-dirty c@ if refresh-line then then 636 | 637 | depth 1- <> abort" stk" \ stack check] 638 | bufstart 1- c@ abort" sof" 639 | eof @ c@ abort" eof" 640 | curlinestart @ bufstart eof @ within 641 | 0= abort" cl" again ; 642 | 643 | define v 644 | $ba c@ 8 < abort" bad device#" 645 | 646 | \ modifies kernal to change kbd prefs 647 | ram-kernal $eaea @ $8ca <> if 648 | rom-kernal 649 | $e000 dup $2000 move \ rom => ram 650 | $f $eaea c! \ repeat delay 651 | 4 $eb1d c! \ repeat speed 652 | then 653 | 654 | 0 to insert 655 | $80 $28a c! \ key repeat on 656 | clear-status 657 | 658 | lf word count dup 0= if \ no param? 659 | eof @ if \ something in buffer? 660 | 2drop main-loop exit \ yes - cont. edit 661 | then then 662 | 663 | filename c! filename 1+ $f move 664 | 665 | reset-buffer 666 | filename c@ if \ load file 667 | rom-kernal 668 | 669 | \ Abort if the file is too big to load. 670 | '$' here c! ':' here 1+ c! 671 | filename 1+ here 2+ $f move 672 | here filename c@ 2+ here loadb drop 673 | here $22 + @ $2020 = \ found? 674 | here $20 + @ #44 > and \ 44=$2c00/254 675 | abort" too big" 676 | 677 | filename count bufstart loadb 678 | ?dup 0= if reset-buffer else 679 | eof ! 0 eof @ c! then then main-loop ; 680 | 681 | to latest \ end hiding words 682 | -------------------------------------------------------------------------------- /forth/viceutil.fs: -------------------------------------------------------------------------------- 1 | require io 2 | 3 | $12 emit .( dump-labels) $92 emit 4 | .( writes VICE emulator) cr 5 | .( labels to the PRG file 'words') cr cr 6 | .( When written, extract the file from) 7 | cr 8 | .( .d64 using c1541 command) cr 9 | .( 'read words'.) cr 10 | .( Then, load the file from VICE) cr 11 | .( monitor using 'll "words"') cr 12 | 13 | \ print a VICE label definition for a 14 | \ given nametoken. returns 1, for use 15 | \ with dowords 16 | : (label) ( nametoken -- 1 ) 17 | ." al " dup >xt u. '.' emit 18 | name>string 19 | over + swap do i c@ 20 | dup 'a' < over 'z' > or if case 21 | \ escape forbidden chars 22 | '0' of ." :zero:" endof 23 | '1' of ." :one:" endof 24 | '2' of ." :two:" endof 25 | '3' of ." :three:" endof 26 | '4' of ." :four:" endof 27 | '5' of ." :five:" endof 28 | '6' of ." :six:" endof 29 | '7' of ." :seven:" endof 30 | '8' of ." :eight:" endof 31 | '9' of ." :nine:" endof 32 | '-' of ." :minus:" endof 33 | '+' of ." :plus:" endof 34 | '#' of ." :hash:" endof 35 | '*' of ." :star:" endof 36 | '/' of ." :slash:" endof 37 | '\' of ." :backslash:" endof 38 | '=' of ." :equals:" endof 39 | ',' of ." :comma:" endof 40 | '.' of ." :dot:" endof 41 | '$' of ." :dollar:" endof 42 | '<' of ." :lt:" endof 43 | '>' of ." :gt:" endof 44 | '!' of ." :store:" endof 45 | '@' of ." :fetch:" endof 46 | ';' of ." :semicolon:" endof 47 | '[' of ." :lbracket:" endof 48 | ']' of ." :rbracket:" endof 49 | '(' of ." :lparen:" endof 50 | ')' of ." :rparen:" endof 51 | ''' of ." :tick:" endof 52 | '"' of ." :quote:" endof 53 | dup emit endcase 54 | else emit then loop 55 | $a emit 1 ; 56 | 57 | : dump-labels base @ >r hex 58 | s" words,w" 1 1 open ioabort 59 | 1 chkout ioabort 60 | ['] (label) dowords 61 | clrchn 1 close r> base ! ; 62 | -------------------------------------------------------------------------------- /forth/wordlist.fs: -------------------------------------------------------------------------------- 1 | : hide ( "name" -- ) 2 | parse-name find-name ?dup if 3 | dup latest - ( nt size ) 4 | >r c@ $1f and 3 + ( off ) 5 | latest swap over + ( srca dsta ) 6 | dup to latest 7 | r> move then ; 8 | : defcode ( "name" -- ) 9 | parse-name 2dup find-name ?dup 0= 10 | if notfound then nip nip 11 | count $1f and + here swap ! ; 12 | : define defcode ] ; 13 | -------------------------------------------------------------------------------- /manual/.lvimrc: -------------------------------------------------------------------------------- 1 | :map :w:!./make.sh 2 | -------------------------------------------------------------------------------- /manual/Makefile: -------------------------------------------------------------------------------- 1 | C1541 = c1541 2 | AS = acme 3 | TAG := $(shell git describe --tags --abbrev=0 || svnversion --no-newline) 4 | REV_TAG_P := $(shell git describe --tags --abbrev=0 --dirty=-M || svnversion --no-newline) 5 | REV_TAG_DOC := $(shell git describe --tags --long --dirty=_MODIFIED | sed 's/-g[0-9a-f]\+//' | tr _- -.) 6 | REV_DATE := $(shell git log -1 --format=%ai) 7 | 8 | # generic rules 9 | 10 | all: durexforth.pdf durexforth.html durexforth.epub 11 | 12 | SECTIONS = release_license.tex \ 13 | intro.tex tutorial.tex editor.tex words.tex gfx.tex sid.tex mml.tex \ 14 | asm.tex mnemonics.tex memmap.tex anatomy.tex 15 | GENERATED = params-g.tex 16 | 17 | durexforth.pdf: manual.tex $(SECTIONS) manual.ist 18 | cp manual.ist durexforth.mst 19 | pdflatex -jobname=durexforth manual.tex 20 | pdflatex -jobname=durexforth manual.tex 21 | pdflatex -jobname=durexforth manual.tex 22 | rm durexforth.mst 23 | 24 | durexforth.html durexforth.css: manual.tex $(SECTIONS) 25 | make4ht -e manual.mk4 -j durexforth $< 26 | 27 | durexforth.epub: manual.tex $(SECTIONS) 28 | tex4ebook -f epub3 -e manual.mk4 -j durexforth $< 29 | 30 | release_license.tex: params-g.tex 31 | diff -q $^ $^.tmp; if [ $$? -eq 1 ]; then touch $@; fi 32 | rm $^.tmp 33 | 34 | params-g.tex: 35 | touch $@ 36 | cp $@ $@.tmp 37 | printf %s\\n "\\def\\revisiontagdoc{$(REV_TAG_DOC)}" > $@ 38 | printf %s\\n "\\def\\revisiondate{$(REV_DATE)}" >> $@ 39 | 40 | clean: 41 | rm -f *.pdf $(GENERATED) 42 | 43 | .PHONY: $(GENERATED) 44 | 45 | -------------------------------------------------------------------------------- /manual/anatomy.adoc: -------------------------------------------------------------------------------- 1 | Let us define a word and see what it gets compiled to. 2 | 3 | ---- 4 | : bg $d020 c! ; 5 | ---- 6 | 7 | Information about the word is split into two areas of memory, the dictionary and the code/data space. Code and data are placed in an upward-growing segment starting at $801, and the dictionary grows downward from `top`. `latest` points to the last dictionary record. A dictionary record consists of a counted string with flags, and an execution token (_xt_). 8 | 9 | To inspect the dictionary entry, type `latest dump`. You should see something like this: 10 | 11 | ---- 12 | 6228 02 42 47 fd 39 28 39 01 .bg.9(9. 13 | ... 14 | ---- 15 | For this run, the name token of `bg` is placed at address $6228. The first byte, `02`, is the name length (`bg` has two characters). After that, the string `bg` follows. ($42 = `b`, $47 = `g`). The final two bytes contain the execution token of `bg`, starting at $39fd. 16 | 17 | The name length byte is also used to store special attributes of the word. Bit 7 is "immediate" flag, which means that the word should execute immediately instead of being compiled into word definitions. (``(`` is such an example of an immediate word that does not get compiled.) Bit 6 is the "no-tail-call-elimination" flag, which makes sure that tail call elimination (the practice of replacing jsr/rts with jmp) is not performed if this word is the jsr target. Since `bg` does not have these flags set, bits 7 and 6 are both clear. 18 | 19 | We saw that the `bg` execution token is $39fd. To inspect the code, type `$39fd dump` or `latest >xt dump`. 20 | 21 | The code section contains pure 6502 machine code. 22 | 23 | ---- 24 | 39fd 20 15 11 20 d0 4c 0e 09 .. Pl.. 25 | ... 26 | ---- 27 | 20 15 11 :: `jsr $1115`. $1115 is the address of the `lit` code. `lit` copies the two following bytes to parameter stack. 28 | 20 d0 :: `$d020`. The parameter to the `lit` word. When executed, `lit` will add $d020 to the parameter stack. 29 | 4c 0e 09 :: `jmp $90e`. $90e is the address of the `c!` code. 30 | -------------------------------------------------------------------------------- /manual/asm.adoc: -------------------------------------------------------------------------------- 1 | DurexForth features a simple but useful 6510 assembler with support for branches and labels. Assembly code is typically used within a `code` word, as in the tutorial example: 2 | 3 | ---- 4 | code flash 5 | here ( push current addr ) 6 | $d020 inc, ( inc $d020 ) 7 | jmp, ( jump to pushed addr ) 8 | end-code 9 | ---- 10 | 11 | It is also possible to inline assembly code into a regular Forth word, as seen in the tutorial: 12 | 13 | ---- 14 | : flash begin [ $d020 inc, ] again ; 15 | ---- 16 | 17 | === Variables 18 | 19 | DurexForth has a few variables that are specifically meant to be used within code words. 20 | 21 | ((lsb)) _( -- addr )_ :: _addr_ points to the top of the LSB parameter stack. Together with the `x` register, it can be used to access stack contents. 22 | ((msb)) _( -- addr )_ :: _addr_ points to the top of the MSB parameter stack. Together with the `x` register, it can be used to access stack contents. 23 | ((w)) _( -- addr )_ :: A zero-page cell that code words may use freely as work area. 24 | ((w2)) _( -- addr )_ :: Second zero-page work area cell. 25 | ((w3)) _( -- addr )_ :: Third zero-page work area cell. 26 | 27 | Example usage of `lsb` and `msb`: 28 | 29 | ---- 30 | code + ( n1 n2 -- sum ) 31 | clc, ( clear carry ) 32 | lsb 1+ lda,x ( load n1 lsb ) 33 | lsb adc,x ( add n2 lsb ) 34 | lsb 1+ sta,x ( store to n1 lsb ) 35 | msb 1+ lda,x ( load n1 msb ) 36 | msb adc,x ( add n2 msb ) 37 | msb 1+ sta,x ( store to n2 msb ) 38 | inx, ( drop n2; n1 = sum ) 39 | rts, ( return ) 40 | end-code 41 | ---- 42 | 43 | === Branches 44 | 45 | The assembler supports forward and backward branches. These branches cannot overlap each other, so their usage is limited to simple cases. 46 | 47 | ((+branch)) _( -- addr )_ :: Forward branch. 48 | ((:+)) _( addr -- )_ :: Forward branch target. 49 | ((:-)) _( -- addr )_ :: Backward branch target. 50 | ((-branch)) _( addr -- )_ :: Backward branch. 51 | 52 | Example of a forward branch: 53 | 54 | ---- 55 | foo lda, 56 | +branch beq, 57 | bar inc, :+ 58 | ---- 59 | 60 | Example of a backward branch: 61 | 62 | ---- 63 | :- $d014 lda, f4 cmp,# 64 | -branch bne, 65 | ---- 66 | 67 | === Labels 68 | 69 | The `labels` module adds support for more complicated flows where branches can overlap freely. These branches are resolved by the `end-code` word, so it is not possible to branch past it. 70 | 71 | ((@:)) _( n -- )_ :: Create the assembly label _n_, where _n_ is a number in range [0, 255]. 72 | ((@@)) _( n -- )_ :: Compile a branch to the label _n_. 73 | 74 | Example: 75 | 76 | ---- 77 | code checkers 78 | $7f lda,# 0 ldy,# 'l' @: 79 | $400 sta,y $500 sta,y 80 | $600 sta,y $700 sta,y 81 | dey, 'l' @@ bne, rts, 82 | end-code 83 | ---- 84 | -------------------------------------------------------------------------------- /manual/config.adoc: -------------------------------------------------------------------------------- 1 | === Stripping Modules 2 | 3 | By default, durexForth boots up with these modules pre-compiled in RAM: 4 | 5 | asm:: The assembler. (Required and may not be stripped.) 6 | format:: Numerical formatting words. (Also required.) 7 | wordlist:: Wordlist manipulation. (Required by some modules.) 8 | labels:: Assembler labels. 9 | doloop:: Do-loop words. 10 | sys:: System calls. 11 | debug:: Words for debugging. 12 | ls:: List disk contents. 13 | require:: The words `require` and `required`. 14 | v:: The text editor. 15 | 16 | To reduce RAM usage, you may make a stripped-down version of durexForth. Do this by following these steps: 17 | 18 | . Issue `---modules---` to unload all modules, or `---editor---` to unload the editor only. 19 | . One by one, load the modules you want included with your new Forth. (E.g. `include labels`) 20 | . Save the new system with e.g. `save-forth acmeforth`. 21 | 22 | === Custom Start-Up 23 | 24 | You may launch a word automatically at start-up by setting the variable `start` to the execution token of the word. Example: `' megademo start !` To save the new configuration to disk, type e.g. `save-forth megademo`. 25 | 26 | When writing a new program using a PC text editor, it is practical to configure durexForth to compile and execute the program at startup. That can be set up using the following snippet: 27 | 28 | ---- 29 | $a000 value buf 30 | : go buf s" myprogramfile" buf 31 | loadb buf - evaluate ; 32 | ' go start ! 33 | save-forth @0:durexforth 34 | ---- 35 | 36 | === Turn-key Operation 37 | 38 | Durexforth offers utilities to save your program in a turn-key fashion by including the `turnkey` module once the program is ready to be saved. 39 | 40 | Programs can be saved in a compacted state using `save-pack`. These programs are stored with 32 bytes between `here` and `latest`. When they are first loaded, they will restore the header space to its original `top`. 41 | 42 | If you have developed a program that has no further need of the interpreter, you can eliminate the dictionary headers entirely when saving with `save-prg`. This allows your program to use memory down to `here` plus 32 bytes for safety. 43 | 44 | After either of these words have saved the file to disk, they will restore forth to the unpacked state, and strip the `turnkey` module from the dictionary. This allows you to continue to use forth interactively in the case of `save-pack`. As `save-prg` has stripped the dictionary headers from the system, it will no longer be usable. If you wish to test your program after saving, you can compile a call to `save-prg` instead: 45 | ---- 46 | : build save-prg mydemo start @ execute ; 47 | build 48 | ---- 49 | This will simulate the start-up sequence after saving the packed program. 50 | -------------------------------------------------------------------------------- /manual/cover/durexForth-Vintage1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jkotlinski/durexforth/93e68ac1054d47f4fc018bcf1fe556b3a53fa963/manual/cover/durexForth-Vintage1.jpg -------------------------------------------------------------------------------- /manual/cover/durexForth_omslag-1.0.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jkotlinski/durexforth/93e68ac1054d47f4fc018bcf1fe556b3a53fa963/manual/cover/durexForth_omslag-1.0.pdf -------------------------------------------------------------------------------- /manual/editor.adoc: -------------------------------------------------------------------------------- 1 | The editor is a vi clone. Launch it by entering +v foo+ in the interpreter (+foo+ being the file you want to edit). You can also enter +v+ without argument to create an unnamed buffer. For more info about vi style editing, see https://www.vim.org[the Vim web site]. 2 | 3 | === Inserting Text 4 | 5 | At startup, the editor is in command mode. These commands start insert mode, which allows you to enter text. Return to command mode with kbd:[←]. 6 | 7 | i:: Insert text. 8 | R:: Replace text. 9 | a:: Append text. 10 | A:: Append text at end of line. 11 | C:: Change rest of line. 12 | S:: Substitute line. 13 | s:: Substitute character. 14 | o:: Open new line after cursor line. 15 | O:: Open new line on cursor line. 16 | cw:: Change word. 17 | 18 | === Navigation 19 | 20 | hjkl _or_ ⇐⇑⇓⇒ :: Move cursor left, down, up, right. 21 | -:: Scroll 1 line up. 22 | +:: Scroll 1 line down. 23 | Ctrl+u:: Half page up. 24 | Ctrl+d:: Half page down. 25 | b:: Go to previous word. 26 | w:: Go to next word. 27 | e:: Go to end of word. 28 | fx:: Find char +x+ forward. 29 | Fx:: Find char +x+ backward. 30 | 0 _or_ Home:: Go to line start. 31 | $:: Go to line end. 32 | g:: Go to start of file. 33 | G:: Go to end of file. 34 | H:: Go to home window line. 35 | L:: Go to last window line. 36 | M:: Go to middle window line. 37 | /__string__:: Search forward for the next occurrence of the string. 38 | *:: Search forward for the next occurrence of the word under the cursor. 39 | n:: Repeat the latest search. 40 | 41 | === Saving and Quitting 42 | 43 | After quitting, the editor can be re-opened by entering +v+, and it will resume operations with the edit buffer preserved. 44 | 45 | ZZ:: Save and exit. 46 | :q:: Exit. 47 | :w:: Save. (Must be followed by return.) 48 | :w!filename:: Save as. 49 | F7:: Compile and run editor contents. On completion, enter +v+ to return to editor. To terminate a running program, press kbd:[RESTORE]. 50 | 51 | === Text Manipulation 52 | r:: Replace character under cursor. 53 | x:: Delete character. 54 | X:: Backspace-delete character. 55 | dw:: Delete word. 56 | dd:: Cut line. 57 | D:: Delete rest of line. 58 | yy:: Yank (copy) line. 59 | p:: Paste line below cursor position. 60 | P:: Paste line on cursor position. 61 | J:: Join lines. 62 | -------------------------------------------------------------------------------- /manual/exceptions.adoc: -------------------------------------------------------------------------------- 1 | The following exception numbers are used by durexForth. 2 | 3 | -1 :: ((abort)) 4 | -2 :: ((abort")) 5 | -4 :: stack underflow 6 | -8 :: dictionary overflow (out of memory) 7 | -10 :: division by zero 8 | -13 :: undefined word 9 | -16 :: attempt to use an empty string as a name 10 | -28 :: user interrupt (triggered by kbd:[RESTORE] or `brk` instruction) 11 | -37 :: file I/O exception 12 | -------------------------------------------------------------------------------- /manual/gfx.adoc: -------------------------------------------------------------------------------- 1 | === Turtle Graphics 2 | 3 | Turtle graphics are mostly known from LOGO, a 1970s programming language. 4 | It enables control of a turtle that can move and turn while holding a pen. 5 | The turtle graphics library is loaded with `include turtle`. 6 | 7 | ((init)) _( -- )_ :: Initialize turtle graphics. 8 | ((forward)) _( px -- )_ :: Move the turtle `px` pixels forward. 9 | ((back)) _( px -- )_ :: Move the turtle `px` pixels back. 10 | ((left)) _( deg -- )_ :: Rotate the turtle `deg` degrees left. 11 | ((right)) _( deg -- )_ :: Rotate the turtle `deg` degrees right. 12 | ((penup)) _( -- )_ :: Pen up (disables drawing). 13 | ((pendown)) _( -- )_ :: Pen down (enables drawing). 14 | ((turtle@)) _( -- state )_ :: Remember turtle state. 15 | ((turtle!)) _( state -- )_ :: Restore turtle state as earlier read by `turtle@`. 16 | ((moveto)) _( x y deg -- )_ :: Move turtle to _x y_ with angle _deg_. 17 | 18 | === High-Resolution Graphics 19 | 20 | The high-resolution graphics library is loaded with `include gfx`. 21 | It is inspired by "Step-by-Step Programming Commodore 64: Graphics Book 3." 22 | Some demonstrations can be found in `gfxdemo`. 23 | 24 | ((hires)) _( -- )_ :: Enter the high-resolution drawing mode. 25 | ((lores)) _( -- )_ :: Switch back to low-resolution text mode. 26 | ((clrcol)) _( colors -- )_ :: Clear the high-resolution display using _colors_. 27 | _Colors_ is a byte value with foreground color in high nibble, background color in low nibble. 28 | E.g. `15 clrcol` clears the screen with green background, white foreground. 29 | ((blkcol)) _( col row colors -- )_ :: Change colors of the 8x8 block at given position. 30 | ((plot)) _( x y -- )_ :: Set the pixel at _x_, _y_. 31 | ((peek)) _( x y -- p )_ :: Get the pixel at _x_, _y_. 32 | ((line)) _( x y -- )_ :: Draw a line to _x_, _y_. 33 | ((circle)) _( x y r -- )_ :: Draw a circle with radius _r_ around _x_, _y_. 34 | ((pen)) _( mode -- )_ :: Change line drawing method. 35 | `1 pen` inverts color, `0 pen` switches back to normal mode. 36 | ((paint)) _( x y -- )_ :: Paint the area at _x_, _y_. 37 | ((text)) _( column row str strlen -- )_ :: Draw a text string at the given position. 38 | E.g. `10 8 parse-name hallo text` draws the message `hallo` at column 16, row 8. 39 | ((drawchar)) _( column row addr -- )_ :: Draw a custom character at given column and row, using the 8 bytes long data starting at addr. 40 | -------------------------------------------------------------------------------- /manual/index.adoc: -------------------------------------------------------------------------------- 1 | = durexForth: Operators Manual 2 | Johan Kotlinski; Kevin Lee Reno; Poindexter Frink; Richard Halkyard 3 | :toc: preamble 4 | :doctype: book 5 | :experimental: 6 | // experimental enables the kbd: macro https://docs.asciidoctor.org/asciidoc/latest/macros/keyboard-macro/ 7 | 8 | This manual is for durexForth, a modern Forth system for the Commodore 64. 9 | 10 | == Introduction 11 | include::intro.adoc[] 12 | 13 | == Tutorial 14 | include::tutorial.adoc[] 15 | 16 | == Editor 17 | include::editor.adoc[] 18 | 19 | == Forth Words 20 | include::words.adoc[] 21 | 22 | == Graphics 23 | include::gfx.adoc[] 24 | 25 | == SID 26 | include::sid.adoc[] 27 | 28 | == Music 29 | include::mml.adoc[] 30 | 31 | == Assembler 32 | include::asm.adoc[] 33 | 34 | == Configuring durexForth 35 | include::config.adoc[] 36 | 37 | [appendix] 38 | == Assembler Mnemonics 39 | include::mnemonics.adoc[] 40 | 41 | [appendix] 42 | == Memory Map 43 | include::memmap.adoc[] 44 | 45 | [appendix] 46 | == System Exceptions 47 | include::exceptions.adoc[] 48 | 49 | [appendix] 50 | == Word Anatomy 51 | include::anatomy.adoc[] 52 | 53 | [appendix] 54 | == Avoiding Stack Crashes 55 | include::stack.adoc[] 56 | 57 | [appendix] 58 | == Internet Resources 59 | include::links.adoc[] 60 | 61 | [appendix] 62 | == License 63 | include::../LICENSE.txt[] 64 | 65 | // asciidoctor 2.0.16 HTML backend lacks index support. 66 | ifeval::["{backend}" == "pdf"] 67 | [index] 68 | == Word Index 69 | endif:: 70 | -------------------------------------------------------------------------------- /manual/intro.adoc: -------------------------------------------------------------------------------- 1 | === Why Forth? 2 | 3 | Forth is a unique language. What is so special about it? It is a small, low-level language, which can easily be extended to a high-level, domain-specific language that does anything you want it to. Compared to C64 Basic, Forth is more attractive in almost every way. It is a lot faster, more memory effective, and more powerful. 4 | 5 | Compared to C, the nice thing about Forth is that you can run the full development environment on your C64, 6 | with text editor, compiler, assembler and debugger. It makes for a more interactive and fun experience than running a cross-compiler on PC. 7 | 8 | For a Forth introduction, refer to the excellent http://www.forth.com/starting-forth/[Starting Forth] by Leo Brodie. 9 | 10 | === Comparing to other Forths 11 | 12 | There are other Forths for C64, most notably Blazin' Forth. Blazin' Forth is excellent, but durexForth has some advantages: 13 | 14 | - durexForth uses text files instead of a custom block file system. 15 | - durexForth is smaller. 16 | - durexForth is faster. 17 | - durexForth can boot from cartridge. 18 | - durexForth implements the Forth 2012 core standard. 19 | - The durexForth editor is a vi clone. 20 | - durexForth is open source (available at https://github.com/jkotlinski/durexforth[Github]). 21 | 22 | === Package Contents === 23 | 24 | durexForth is packaged as a 16-kByte .crt cartridge file and a .d64 disk image. Booting from cartridge is equivalent to booting from disk, except that cartridge is faster. The disk contains various optional Forth modules, as well as some appetizer demonstration programs, as follows: 25 | 26 | ==== Graphics ==== 27 | 28 | The gfxdemo package demonstrates the high-resolution graphics, with some examples adapted from the book "Step-By-Step Programming C64 Graphics" by Phil Cornes. 29 | Show the demos by entering: 30 | 31 | ---- 32 | include gfxdemo 33 | ---- 34 | 35 | When an image has finished drawing, press space to continue. 36 | 37 | ==== Fractals ==== 38 | 39 | The fractals package demonstrates turtle graphics by generating fractal images. Run it by entering: 40 | 41 | ---- 42 | include fractals 43 | demo 44 | ---- 45 | 46 | When an image has finished drawing, press space to continue. 47 | 48 | ==== Music ==== 49 | 50 | The mmldemo package demonstrates the MML music capabilities. To play some music: 51 | 52 | ---- 53 | include mmldemo 54 | ---- 55 | 56 | ==== Sprites ==== 57 | 58 | The sprite package adds functionality for defining and displaying sprites. To run the demo: 59 | 60 | ---- 61 | include spritedemo 62 | ---- 63 | -------------------------------------------------------------------------------- /manual/links.adoc: -------------------------------------------------------------------------------- 1 | Forth Books and Papers:: 2 | - https://www.forth.com/starting-forth/[Starting Forth] 3 | - http://thinking-forth.sourceforge.net/[Thinking Forth] 4 | - https://www.bradrodriguez.com/papers/[Moving Forth: a series on writing Forth kernels] 5 | - http://forth.org/[Forth Interest Group] 6 | - https://archive.org/details/transactor-magazines-v7-i05/page/n59/mode/2up[Blazin' Forth --- An inside look at the Blazin' Forth compiler] 7 | - https://www.drdobbs.com/architecture-and-design/the-evolution-of-forth-an-unusual-langua/228700557[The Evolution of FORTH, an unusual language] 8 | - https://galileo.phys.virginia.edu/classes/551.jvn.fall01/primer.htm[A Beginner's Guide to Forth] 9 | 10 | Other Forths:: 11 | - https://colorforth.github.io/[colorForth] 12 | - https://gforth.org/[Gforth] 13 | - https://github.com/nornagon/jonesforth[jonesforth] 14 | - https://github.com/chitselb/pettil[PETTIL] 15 | - https://github.com/forth-ev/VolksForth[volksFORTH] 16 | 17 | Forth Standards:: 18 | - https://forth-standard.org/[Forth 2012 Standard] 19 | - https://www.taygeta.com/forth/dpans.html[ANS Forth] 20 | - http://forth.sourceforge.net/standard/fst83/[FORTH-83 STANDARD] 21 | - https://atariwiki.org/wiki/attach/Forth79/Forth-79-OCR.pdf[FORTH-79 STANDARD] 22 | 23 | C64 References:: 24 | - https://sourceforge.net/projects/acme-crossass/[ACME Cross-Assembler] 25 | - https://codebase64.org/[Codebase 64] 26 | - http://unusedino.de/ec64/technical/aay/c64/[All About Your C64] 27 | - https://project64.c64.org/Software/mapc6411.txt[Mapping the Commodore 64] 28 | -------------------------------------------------------------------------------- /manual/memmap.adoc: -------------------------------------------------------------------------------- 1 | 3 - $3a :: Parameter stack, `lsb` section. 2 | $3b - $72 :: Parameter stack, `msb` section. 3 | $8b - $8c :: `w` (work area for code words). 4 | $8d - $8e :: `w2` (work area for code words). 5 | $9e - $9f :: `w3` (work area for code words). 6 | $100 - $1ff :: Return stack. 7 | $200 - $258 :: Text input buffer. 8 | $33c - $35a :: `find` buffer. 9 | $35b - $3d9 :: `pad` Scratch pad memory, Cassette Buffer, untouched by durexForth. 10 | $3da - $3fb :: `#>` buffer. 11 | $801 - here :: Forth Kernel followed by code and data space. 12 | latest - $9fff :: Dictionary. Grows downwards as needed. 13 | $a000 - $cbff :: Editor text buffer. 14 | $cc00 - $cfff :: Hi-res graphics colors. 15 | $d000 - $dfff :: I/O area. 16 | $e000 - $ffff :: Kernal / hi-res graphics bitmap. 17 | -------------------------------------------------------------------------------- /manual/mml.adoc: -------------------------------------------------------------------------------- 1 | === Music Macro Language 2 | 3 | Music Macro Language (MML) has been used since the 1970s to sequence music on computer and video game systems. The MML package is loaded with `include mml`. Two demonstration songs can be found in the `mmldemo` package. 4 | 5 | MML songs are played using the Forth word ((play-mml)) which takes three MML strings, one MML melody for each of the three SID voices. An example song is as follows: 6 | 7 | ---- 8 | : frere-jaques 9 | mml" o3l4fgaffgafab->c&cc&cl8cdcl8cdcc&cc&cl8cdcl8cdc :: Used to step down or up one octave. 25 | l :: Followed by a number, specifies the default length used by notes or rests which do not explicitly specify one. 26 | & :: Ties two notes together. 27 | -------------------------------------------------------------------------------- /manual/mnemonics.adoc: -------------------------------------------------------------------------------- 1 | // TODO can this list be put in (say 5) columns? 2 | 3 | [cols="1,1,1,1,1,1"] 4 | [frame=none] 5 | [grid=none] 6 | |=== 7 | 8 | |adc,# | adc, | adc,x | adc,y | adc,(x) | adc,(y) 9 | 10 | |and,# | and, | and,x | and,y | and,(x) | and,(y) 11 | 12 | |asl,a | asl, | asl,x ||| 13 | 14 | |bcc, |bcs, |beq, |bmi,|| 15 | |bne, |bpl, |bvc, |bvs,|| 16 | 17 | |bit, 18 | |brk, 19 | |||| 20 | 21 | |clc, |cld, |cli, |clv,|| 22 | 23 | |cmp,# | cmp, | cmp,x | cmp,y | cmp,(x) | cmp,(y) 24 | 25 | |cpx,# | cpx, |cpy,# | cpy,|| 26 | 27 | |dec, | dec,x |dex, |dey,|| 28 | 29 | |eor,# | eor, | eor,x | eor,y | eor,(x) | eor,(y) 30 | 31 | |inc, | inc,x |inx, |iny,|| 32 | 33 | |jmp, | (jmp), |jsr,||| 34 | 35 | |lda,# | lda, | lda,x | lda,y | lda,(x) | lda,(y) 36 | 37 | |ldx,# | ldx, || ldx,y|| 38 | 39 | |ldy,# | ldy, | ldy,x||| 40 | 41 | |lsr,a | lsr, | lsr,x|| 42 | 43 | |nop, 44 | 45 | |ora,# | ora, | ora,x | ora,y | ora,(x) | ora,(y) 46 | 47 | |pha, |php, |pla, |plp,|| 48 | 49 | |rol,a | rol, | rol,x||| 50 | |ror,a | ror, | ror,x||| 51 | 52 | |rti, |rts,|||| 53 | 54 | |sbc,# | sbc, | sbc,x | sbc,y | sbc,(x) | sbc,(y) 55 | 56 | |sec, |sed, |sei,||| 57 | 58 | |sta, || sta,x | sta,y | sta,(x) | sta,(y) 59 | 60 | |stx, | stx,y |sty, | sty,x|| 61 | 62 | |tax, |tay, |tsx, |txa, |txs, |tya, 63 | |=== 64 | -------------------------------------------------------------------------------- /manual/sid.adoc: -------------------------------------------------------------------------------- 1 | The `sid` module contains low-level words for controlling the SID chip. To load it, type `include sid`. To test that it works, run `sid-demo`. 2 | 3 | === Voice Control 4 | ((voice!)) _( n -- )_ :: Select SID voice 0-2. 5 | ((freq!)) _( n -- )_ :: Write 16-bit frequency. 6 | ((pulse!)) _( n -- )_ :: Write 16-bit pulse value. 7 | ((control!)) _( n -- )_ :: Write 8-bit control value. 8 | ((srad!)) _( srad -- )_ :: Write 16-bit ADSR value. (Bytes are swapped.) 9 | ((note!)) _( n -- )_ :: Play note in range [0, 94], where 0 equals C-0. The tuning is correct for PAL. 10 | 11 | === SID Control 12 | ((cutoff!)) _( n -- )_ :: Write 16-bit filter cutoff value. 13 | ((filter!)) _( n -- )_ :: Write 8-bit filter value. 14 | ((volume!)) _( n -- )_ :: Write 8-bit volume. 15 | -------------------------------------------------------------------------------- /manual/stack.adoc: -------------------------------------------------------------------------------- 1 | Stack overflow and underflow are common causes for errors and crashes. 2 | Simply put, the data stack must not contain too many or too few items. 3 | This section describes some techniques to avoid such errors. 4 | 5 | One helpful technique to avoid stack crashes is to add comments about stack usage. 6 | In this example, we imagine a graphics word "drawbox" that draws a black box. 7 | +( color -- )+ indicates that it takes one argument on stack, and on exit it should 8 | leave nothing on the stack. 9 | The comments inside the word (starting with £) indicate what the stack 10 | looks like after the line has executed. 11 | 12 | ---- 13 | : drawbox ( color -- ) 14 | 10 begin dup 20 < while £ color x 15 | 10 begin dup 20 < while £ color x y 16 | 2dup £ color x y x y 17 | 4 pick £ color x y x y color 18 | blkcol £ color x y 19 | 1+ repeat drop £ color x 20 | 1+ repeat 2drop ; 21 | ---- 22 | 23 | Once the word is working as supposed, it may be nice to again remove the comments, as 24 | they are no longer very interesting to read. 25 | 26 | NOTE: The Forth standard defines backslash (\) as the line comment character, but the C64 lacks a real backslash. 27 | Moreover, ASCII \ and PETSCII £ both map to $5c. 28 | Therefore, the £ character is used as a substitution on the C64. 29 | 30 | Another useful technique during development is to check at the end of your main loop 31 | that the stack depth is what you expect it to. This will catch stack underflows 32 | and overflows. 33 | 34 | ---- 35 | : mainloop begin 36 | ( do stuff here... ) 37 | depth abort" depth not 0" 38 | again ; 39 | ---- 40 | -------------------------------------------------------------------------------- /manual/tutorial.adoc: -------------------------------------------------------------------------------- 1 | === Meet the Interpreter 2 | 3 | Start up durexForth. 4 | The system will greet you with a blinking yellow cursor, waiting for your input. 5 | This is the interpreter, which allows you to enter Forth code interactively. 6 | 7 | Let us try the traditional first program: Type in `.( Hello, world! )` (and press kbd:[Return]). 8 | The system will reply `Hello, world! ok`. 9 | The `ok` means that the system is healthy and ready to accept more input. 10 | 11 | Now, let us try some mathematics. 12 | `1 1 +` (followed by kbd:[Return]) will add 1 and 1, leaving 2 on the stack. 13 | This can be verified by entering `.s` to print the stack contents. 14 | Now enter `.` to pop the 2 and print it to screen, followed by another `.s` to verify that the stack is empty. 15 | 16 | Let us define a word `bg!` for setting the border color... 17 | 18 | ---- 19 | : bg! $d020 c! ; 20 | ---- 21 | 22 | Now try entering `1 bg!` to change the border color to white. 23 | Then, try changing it back again with `0 bg!`. 24 | 25 | === Introducing the Editor 26 | 27 | The v editor is convenient for editing larger pieces of code. With it, you keep an entire source file loaded in RAM, and you can recompile and test it easily. 28 | 29 | Start the editor by typing `v`. You will enter the red editor screen. To enter text, first press kbd:[i] to enter insert mode. This mode allows you to insert text into the buffer. You can see that it's active on the `I` that appears in the lower left corner. This is a good start for creating a program! 30 | 31 | Now, enter the following lines... 32 | 33 | ---- 34 | : flash begin 1 $d020 +! again ; flash 35 | ---- 36 | 37 | ...and then press ← to leave insert mode. 38 | Press kbd:[F7] to compile and run. If everything is entered right, you will see a beautiful color cycle. 39 | 40 | When you finished watching, press kbd:[RESTORE] to quit your program, then enter `v` to reopen the editor. 41 | 42 | === Assembler 43 | 44 | If you want to color cycle as fast as possible, it is possible to use the durexForth assembler to generate machine code. `code` and `end-code` define a code word, just like `:` and `;` define Forth words. Within a code word, you can use assembler mnemonics. 45 | 46 | ---- 47 | code flash 48 | here ( push current addr ) 49 | $d020 inc, 50 | jmp, ( jump to pushed addr ) 51 | end-code 52 | flash 53 | ---- 54 | 55 | It is also possible to use inline assembly within regular Forth words: 56 | 57 | ---- 58 | : flash begin [ $d020 inc, ] again ; 59 | flash 60 | ---- 61 | 62 | IMPORTANT: As the +x+ register contains the parameter stack depth, your assembly code must leave it unchanged. 63 | 64 | === Console I/O Example 65 | 66 | This piece of code reads from keyboard and sends back the chars to screen: 67 | 68 | ---- 69 | : foo key emit recurse ; 70 | foo 71 | ---- 72 | 73 | === Printer Example 74 | 75 | This piece of code prints a message to a printer on device #4, and then prints a message to the screen: 76 | 77 | ---- 78 | include io 79 | 80 | : print-hello 81 | 4 device ( use device 4 ) 82 | 0 0 47 7 open ioabort ( open address 7 as file 47, abort on failure ) 83 | 47 chkout ioabort ( redirect output to file 47, abort on failure ) 84 | ." Hello, printer!" cr 85 | clrchn ( stop input and output redirection ) 86 | ." Hello, screen!" cr 87 | 47 close ( close file 47 ) ; 88 | 89 | print-hello 90 | ---- 91 | 92 | The device number and address may differ between printer models. Commodore MPS series printers use address 0 to print in their uppercase/graphics font, and address 7 to print in their lowercase/uppercase font. 93 | -------------------------------------------------------------------------------- /test/1.fs: -------------------------------------------------------------------------------- 1 | 1 \ used by include-test 2 | -------------------------------------------------------------------------------- /test/test.fs: -------------------------------------------------------------------------------- 1 | : fakekeys ( n -- ) $c6 c! ; 2 | 3 | marker ---test--- 4 | 5 | .( gfxdemo ) 6 | $b fakekeys \ skips demos 7 | parse-name gfx included 8 | parse-name gfxdemo included 9 | 10 | .( fractals ) 11 | 4 fakekeys \ skips demos 12 | parse-name fractals included 13 | demo 14 | 15 | .( mmldemo ) 16 | parse-name mmldemo included 17 | 18 | .( siddemo ) 19 | parse-name sid included sid-demo 20 | 21 | .( spritedemo ) 22 | 1 fakekeys \ exits demo 23 | parse-name spritedemo included 24 | 25 | .( see ) 26 | parse-name testsee included 27 | 28 | .( include ) 29 | :noname s" include 1 2" evaluate 30 | 2 <> abort" not 2" 31 | 1 <> abort" not 1" ; execute 32 | 33 | ---test--- 34 | 35 | : x depth abort" depth" ; x 36 | 37 | parse-name compat included 38 | parse-name tester included 39 | parse-name testcore included 40 | parse-name testcoreplus included 41 | parse-name testcoreext included 42 | parse-name testexception included 43 | 44 | \ ----- 45 | 46 | ( Finally: Using v F7 compile & run, 47 | write an "ok" dummy file to indicate 48 | that tests passed, then exit Vice. ) 49 | 50 | : push ( ch -- ) 51 | $c6 c@ $277 + c! 52 | 1 $c6 +! ; 53 | 54 | : x 55 | 0 1 s" ok" saveb 56 | 0 $d7ff c! ; \ exit vice 57 | 58 | .( v ) 59 | \ The FIFO is only 10 bytes. 60 | \ Don't add more. 61 | 'i' push 'x' push 62 | $5f push \ leftarrow 63 | $88 push \ f7 64 | v 65 | -------------------------------------------------------------------------------- /test/testcoreplus.fs: -------------------------------------------------------------------------------- 1 | DECIMAL 2 | 3 | TESTING DO +LOOP with run-time increment, negative increment, infinite loop 4 | \ Contributed by Reinhold Straub 5 | 6 | VARIABLE ITERATIONS 7 | VARIABLE INCREMENT 8 | : GD7 ( LIMIT START INCREMENT -- ) 9 | INCREMENT ! 10 | 0 ITERATIONS ! 11 | DO 12 | 1 ITERATIONS +! 13 | I 14 | ITERATIONS @ 6 = IF LEAVE THEN 15 | INCREMENT @ 16 | +LOOP ITERATIONS @ 17 | ; 18 | 19 | T{ 4 4 -1 GD7 -> 4 1 }T 20 | T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T 21 | T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T 22 | T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T 23 | T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T 24 | T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T 25 | T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T 26 | T{ 4 1 1 GD7 -> 1 2 3 3 }T 27 | T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T 28 | T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T 29 | T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T 30 | T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T 31 | T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T 32 | T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T 33 | T{ 2 -1 1 GD7 -> -1 0 1 3 }T 34 | T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T 35 | T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T 36 | T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T 37 | 38 | \ ------------------------------------------------------------------------------ 39 | TESTING DO +LOOP with large and small increments 40 | 41 | \ Contributed by Andrew Haley 42 | 43 | MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP 44 | USTEP NEGATE CONSTANT -USTEP 45 | MAX-INT 7 RSHIFT 1+ CONSTANT STEP 46 | STEP NEGATE CONSTANT -STEP 47 | 48 | VARIABLE BUMP 49 | 50 | T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T 51 | 52 | T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T 53 | T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T 54 | 55 | T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T 56 | T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T 57 | 58 | \ Two's complement arithmetic, wraps around modulo wordsize 59 | \ Only tested if the Forth system does wrap around, use of conditional 60 | \ compilation deliberately avoided 61 | 62 | MAX-INT 1+ MIN-INT = CONSTANT +WRAP? 63 | MIN-INT 1- MAX-INT = CONSTANT -WRAP? 64 | MAX-UINT 1+ 0= CONSTANT +UWRAP? 65 | 0 1- MAX-UINT = CONSTANT -UWRAP? 66 | 67 | : GD9 ( n limit start step f result -- ) 68 | >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T 69 | ; 70 | 71 | T{ 0 0 0 USTEP +UWRAP? 256 GD9 72 | T{ 0 0 0 -USTEP -UWRAP? 1 GD9 73 | T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 74 | T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 75 | 76 | \ ------------------------------------------------------------------------------ 77 | TESTING DO +LOOP with maximum and minimum increments 78 | 79 | : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; 80 | (-MI) CONSTANT -MAX-INT 81 | 82 | T{ 0 1 0 MAX-INT GD8 -> 1 }T 83 | T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T 84 | 85 | T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T 86 | T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T 87 | T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T 88 | T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T 89 | 90 | T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T 91 | T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T 92 | T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T 93 | T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T 94 | 95 | \ ------------------------------------------------------------------------------ 96 | \ TESTING +LOOP setting I to an arbitrary value 97 | 98 | \ The specification for +LOOP permits the loop index I to be set to any value 99 | \ including a value outside the range given to the corresponding DO. 100 | 101 | \ SET-I is a helper to set I in a DO ... +LOOP to a given value 102 | \ n2 is the value of I in a DO ... +LOOP 103 | \ n3 is a test value 104 | \ If n2=n3 then return n1-n2 else return 1 105 | : SET-I ( n1 n2 n3 -- n1-n2 | 1 ) 106 | OVER = IF - ELSE 2DROP 1 THEN 107 | ; 108 | 109 | : -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) 110 | SET-I DUP 1 = IF NEGATE THEN 111 | ; 112 | 113 | : PL1 20 1 DO I 18 I 3 SET-I +LOOP ; 114 | T{ PL1 -> 1 2 3 18 19 }T 115 | : PL2 20 1 DO I 20 I 2 SET-I +LOOP ; 116 | T{ PL2 -> 1 2 }T 117 | : PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; 118 | T{ PL3 -> 5 6 0 1 2 19 }T 119 | : PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; 120 | T{ PL4 -> 1 2 3 4 }T 121 | : PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; 122 | T{ PL5 -> -1 -2 -3 -19 -20 }T 123 | : PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; 124 | T{ PL6 -> -1 -2 -3 -4 }T 125 | : PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; 126 | T{ PL7 -> -1 -2 -3 -4 -5 }T 127 | : PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; 128 | T{ PL8 -> -5 -6 0 -1 -2 -20 }T 129 | 130 | \ ------------------------------------------------------------------------------ 131 | TESTING multiple RECURSEs in one colon definition 132 | 133 | : ACK ( m n -- u ) \ Ackermann function, from Rosetta Code 134 | OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 135 | SWAP 1- SWAP ( -- m-1 n ) 136 | DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) 137 | 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) 138 | ; 139 | 140 | T{ 0 0 ACK -> 1 }T 141 | T{ 3 0 ACK -> 5 }T 142 | T{ 2 4 ACK -> 11 }T 143 | 144 | \ ------------------------------------------------------------------------------ 145 | TESTING multiple ELSE's in an IF statement 146 | \ Discussed on comp.lang.forth and accepted as valid ANS Forth 147 | 148 | : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; 149 | T{ 0 MELSE -> 2 4 }T 150 | T{ -1 MELSE -> 1 3 5 }T 151 | 152 | \ ------------------------------------------------------------------------------ 153 | TESTING manipulation of >IN in interpreter mode 154 | 155 | T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T 156 | T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T 157 | 158 | \ ------------------------------------------------------------------------------ 159 | TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] 160 | 161 | T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T 162 | T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T 163 | T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T 164 | T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T 165 | T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T 166 | T{ CREATE IW5 456 , IMMEDIATE -> }T 167 | T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T 168 | T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T 169 | T{ 111 IW6 IW7 IW7 -> 112 }T 170 | T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T 171 | T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T 172 | : FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) 173 | T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate 174 | T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate 175 | 176 | \ ------------------------------------------------------------------------------ 177 | TESTING that IMMEDIATE doesn't toggle a flag 178 | 179 | VARIABLE IT1 0 IT1 ! 180 | : IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE 181 | T{ : IT3 IT2 ; IT1 @ -> 1234 }T 182 | 183 | \ ------------------------------------------------------------------------------ 184 | TESTING parsing behaviour of S" ." and ( 185 | \ which should parse to just beyond the terminating character no space needed 186 | 187 | T{ : GC5 S" A string"2DROP ; GC5 -> }T 188 | T{ ( A comment)1234 -> 1234 }T 189 | T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T 190 | 191 | \ ------------------------------------------------------------------------------ 192 | TESTING number prefixes # $ % and 'c' character input 193 | \ Adapted from the Forth 200X Draft 14.5 document 194 | 195 | VARIABLE OLD-BASE 196 | DECIMAL BASE @ OLD-BASE ! 197 | T{ #1289 -> 1289 }T 198 | T{ #-1289 -> -1289 }T 199 | T{ $12eF -> 4847 }T 200 | T{ $-12eF -> -4847 }T 201 | T{ %10010110 -> 150 }T 202 | T{ %-10010110 -> -150 }T 203 | T{ 'z' -> 90 }T \ PETSCII 204 | T{ 'Z' -> 218 }T \ PETSCII 205 | \ Check BASE is unchanged 206 | T{ BASE @ OLD-BASE @ = -> }T 207 | 208 | \ Repeat in Hex mode 209 | 16 OLD-BASE ! 16 BASE ! 210 | T{ #1289 -> 509 }T 211 | T{ #-1289 -> -509 }T 212 | T{ $12eF -> 12EF }T 213 | T{ $-12eF -> -12EF }T 214 | T{ %10010110 -> 96 }T 215 | T{ %-10010110 -> -96 }T 216 | T{ 'z' -> 5a }T \ PETSCII 217 | T{ 'Z' -> da }T \ PETSCII 218 | \ Check BASE is unchanged 219 | T{ BASE @ OLD-BASE @ = -> }T \ 2 220 | 221 | DECIMAL 222 | \ Check number prefixes in compile mode 223 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T 224 | 225 | \ ------------------------------------------------------------------------------ 226 | TESTING definition names 227 | \ should support {1..31} graphical characters 228 | : !"#$%&'()*+,-./0123456789:;<=>? 1 ; 229 | T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T 230 | : @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; 231 | T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T 232 | : _`abcdefghijklmnopqrstuvwxyz{|} 3 ; 233 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 234 | : _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different 235 | T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T 236 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 237 | 238 | \ ------------------------------------------------------------------------------ 239 | TESTING FIND with a zero length string and a non-existent word 240 | 241 | CREATE EMPTYSTRING 0 C, 242 | : EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) 243 | DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN 244 | 0= SWAP EMPTYSTRING = = ; 245 | T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T 246 | 247 | CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth 248 | 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, 249 | CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, 250 | CHAR $ C, CHAR $ C, 251 | T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T 252 | 253 | \ ------------------------------------------------------------------------------ 254 | TESTING IF ... BEGIN ... REPEAT (unstructured) 255 | 256 | T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T 257 | T{ -6 UNS1 -> -6 }T 258 | T{ 1 UNS1 -> 9 4 }T 259 | 260 | \ ------------------------------------------------------------------------------ 261 | TESTING DOES> doesn't cause a problem with a CREATEd address 262 | 263 | : MAKE-2CONST DOES> 2@ ; 264 | T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T 265 | 266 | \ ------------------------------------------------------------------------------ 267 | TESTING ALLOT ( n -- ) where n <= 0 268 | 269 | T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T 270 | T{ HERE 0 ALLOT HERE = -> }T 271 | 272 | \ ------------------------------------------------------------------------------ 273 | 274 | CR .( End of additional Core tests) CR 275 | 276 | -------------------------------------------------------------------------------- /test/tester.fs: -------------------------------------------------------------------------------- 1 | HEX 2 | 3 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 4 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 5 | VARIABLE VERBOSE 6 | 0 VERBOSE ! 7 | 8 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 9 | DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 10 | 11 | VARIABLE #ERRORS 0 #ERRORS ! 12 | 13 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 14 | \ THE LINE THAT HAD THE ERROR. 15 | CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR 16 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 17 | #ERRORS @ 1 + #ERRORS ! 18 | QUIT \ *** Uncomment this line to QUIT on an error 19 | ; 20 | 21 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 22 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 23 | 24 | : T{ \ ( -- ) SYNTACTIC SUGAR. 25 | ; 26 | 27 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 28 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 29 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 30 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 31 | THEN ; 32 | 33 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 34 | \ (ACTUAL) CONTENTS. 35 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 36 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 37 | 0 DO \ FOR EACH STACK ITEM 38 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 39 | = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN 40 | LOOP 41 | THEN 42 | ELSE \ DEPTH MISMATCH 43 | S" WRONG NUMBER OF RESULTS: " ERROR 44 | THEN ; 45 | 46 | : TESTING \ ( -- ) TALKING COMMENT. 47 | SOURCE VERBOSE @ 48 | IF DUP >R TYPE CR R> >IN ! 49 | ELSE >IN ! DROP [CHAR] * EMIT 50 | THEN ; 51 | 52 | 53 | -------------------------------------------------------------------------------- /test/testexception.fs: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth Exception word set and extension words 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.13 13 Nov 2015 C6 rewritten to avoid use of CASE etc and hence 15 | \ dependence on the Core extension word set. 16 | \ 0.4 1 April 2012 Tests placed in the public domain. 17 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 18 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 19 | \ 0.1 Oct 2006 First version released 20 | 21 | \ ------------------------------------------------------------------------------ 22 | \ The tests are based on John Hayes test program for the core word set 23 | \ 24 | \ Words tested in this file are: 25 | \ CATCH THROW ABORT ABORT" 26 | \ 27 | \ ------------------------------------------------------------------------------ 28 | \ Assumptions and dependencies: 29 | \ - the forth system under test throws an exception with throw 30 | \ code -13 for a word not found by the text interpreter. The 31 | \ undefined word used is $$qweqweqwert$$, if this happens to be 32 | \ a valid word in your system change the definition of t7 below 33 | \ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been 34 | \ included prior to this file 35 | \ - the Core word set available and tested 36 | \ - CASE, OF, ENDOF and ENDCASE from the core extension wordset 37 | \ are present and work correctly 38 | \ ------------------------------------------------------------------------------ 39 | TESTING CATCH THROW 40 | 41 | DECIMAL 42 | 43 | : T1 9 ; 44 | : C1 1 2 3 ['] T1 CATCH ; 45 | T{ C1 -> 1 2 3 9 0 }T \ No THROW executed 46 | 47 | : T2 8 0 THROW ; 48 | : C2 1 2 ['] T2 CATCH ; 49 | T{ C2 -> 1 2 8 0 }T \ 0 THROW does nothing 50 | 51 | : T3 7 8 9 99 THROW ; 52 | : C3 1 2 ['] T3 CATCH ; 53 | T{ C3 -> 1 2 99 }T \ Restores stack to CATCH depth 54 | 55 | : T4 1- DUP 0> IF RECURSE ELSE 999 THROW -222 THEN ; 56 | : C4 3 4 5 10 ['] T4 CATCH -111 ; 57 | T{ C4 -> 3 4 5 0 999 -111 }T \ Test return stack unwinding 58 | 59 | : T5 2DROP 2DROP 9999 THROW ; 60 | : C5 1 2 3 4 ['] T5 CATCH \ Test depth restored correctly 61 | DEPTH >R DROP 2DROP 2DROP R> ; \ after stack has been emptied 62 | T{ C5 -> 5 }T 63 | 64 | \ ------------------------------------------------------------------------------ 65 | TESTING ABORT ABORT" 66 | 67 | -1 CONSTANT EXC_ABORT 68 | -2 CONSTANT EXC_ABORT" 69 | -13 CONSTANT EXC_UNDEF 70 | : T6 ABORT ; 71 | 72 | \ The 77 in T10 is necessary for the second ABORT" test as the data stack 73 | \ is restored to a depth of 2 when THROW is executed. The 77 ensures the top 74 | \ of stack value is known for the results check 75 | 76 | : T10 77 SWAP ABORT" This should not be displayed" ; 77 | : C6 CATCH 78 | >R R@ EXC_ABORT = IF 11 79 | ELSE R@ EXC_ABORT" = IF 12 80 | ELSE R@ EXC_UNDEF = IF 13 81 | THEN THEN THEN R> DROP 82 | ; 83 | 84 | T{ 1 2 ' T6 C6 -> 1 2 11 }T \ Test that ABORT is caught 85 | T{ 3 0 ' T10 C6 -> 3 77 }T \ ABORT" does nothing 86 | T{ 4 5 ' T10 C6 -> 4 77 12 }T \ ABORT" caught, no message 87 | 88 | \ ------------------------------------------------------------------------------ 89 | TESTING a system generated exception 90 | 91 | : T7 S" 333 $$QWEQWEQWERT$$ 334" EVALUATE 335 ; 92 | : T8 S" 222 T7 223" EVALUATE 224 ; 93 | : T9 S" 111 112 T8 113" EVALUATE 114 ; 94 | 95 | T{ 6 7 ' T9 C6 3 -> 6 7 13 3 }T \ Test unlinking of sources 96 | 97 | \ ------------------------------------------------------------------------------ 98 | 99 | \ EXCEPTION-ERRORS SET-ERROR-COUNT 100 | 101 | CR .( End of Exception word tests) CR 102 | 103 | 104 | -------------------------------------------------------------------------------- /test/testsee.fs: -------------------------------------------------------------------------------- 1 | marker ---testsee--- 2 | 3 | include see 4 | 5 | : gives page see 6 | 4 $d6 c@ do cr loop \ move to row 4 7 | refill drop source tuck 8 | type 0 do $400 i + c@ $4a0 i + c@ 9 | <> abort" ko" loop ; immediate 10 | 11 | : x ; immediate gives x 12 | : x immediate ; 13 | 14 | : x , . ; gives x 15 | : x , . ; 16 | 17 | : x 12 ; gives x 18 | : x 12 ; 19 | 20 | : x 1234 ; gives x 21 | : x 1234 ; 22 | 23 | : x drop ; gives x 24 | : x drop ; 25 | 26 | : x s" hai" ; gives x 27 | : x s" hai" ; 28 | 29 | : x if then ; gives x 30 | : x if then ; 31 | 32 | : x if else then ; gives x 33 | : x if else then ; 34 | 35 | : x if else 1 then ; gives x 36 | : x if else 1 then ; 37 | 38 | : x if exit then ; gives x 39 | : x if exit then ; 40 | 41 | : x begin again ; gives x 42 | : x begin again ; 43 | 44 | : x begin until ; gives x 45 | : x begin until ; 46 | 47 | : x begin 1 while 2 repeat ; gives x 48 | : x begin 1 while 2 repeat ; 49 | 50 | : x do loop ; gives x 51 | : x do loop ; 52 | 53 | : x do +loop ; gives x 54 | : x do +loop ; 55 | 56 | : x ?do loop ; gives x 57 | : x ?do loop ; 58 | 59 | : x do leave loop ; gives x 60 | : x do leave loop ; 61 | 62 | : x case 1 of 2 endof 3 of 4 endof 5 endcase ; gives x 63 | : x 1 over = if drop 2 else 3 over = if drop 4 else 5 drop then then ; 64 | 65 | page .( see ok) cr 66 | 67 | ---testsee--- 68 | --------------------------------------------------------------------------------