├── .gitignore ├── .gitmodules ├── AAS_Data ├── Ring.raw └── bla.mod ├── LICENSE ├── Makefile ├── README.md ├── README.txt ├── assets ├── apartment-map-tiled.png ├── apartment-map.json ├── apartment-map.png ├── apartment-map.tmx ├── apartment-tiles.ase ├── apartment-tiles.png ├── apartment.ase ├── apartment.png ├── ball.raw ├── end.png ├── end.xcf ├── pal1.pal ├── pal2.pal ├── pal3.pal ├── phone.ase ├── phone.png ├── snaggle.ase ├── snaggle.png ├── splash.png └── splash.xcf ├── buildall.bat ├── demo.bat ├── demo.sh ├── forth ├── demo │ ├── a_gba.pf │ └── z_demo.pf ├── lib │ └── e-lib-routines.fth └── to-asm │ └── d-lib-constants.fth ├── shell ├── dpansf.py └── rath.el ├── source ├── PF.s ├── PFD.asm ├── PFH.asm ├── beany-sheet.s ├── cam80-12 │ ├── CAMEL80.AZM │ ├── CAMEL80D.AZM │ ├── CAMEL80H.AZM │ ├── CAMELTST.AZM │ ├── CAMLDUMP.AZM │ ├── GLOSSHI.TXT │ ├── GLOSSLO.TXT │ └── README.Z80 ├── gba_font.c ├── gbfs.h ├── libgbfs.c └── main.c └── tools ├── compiler.py └── tiled2bin.py /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | libgba/build 3 | *.elf 4 | *.sav 5 | *.gbfs 6 | *.gba 7 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "deps/apex-audio-system"] 2 | path = deps/apex-audio-system 3 | url = git@github.com:stuij/apex-audio-system.git 4 | [submodule "deps/gba-serial-adventures"] 5 | path = deps/gba-serial-adventures 6 | url = git@github.com:stuij/gba-serial-adventures.git 7 | -------------------------------------------------------------------------------- /AAS_Data/Ring.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/AAS_Data/Ring.raw -------------------------------------------------------------------------------- /AAS_Data/bla.mod: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/AAS_Data/bla.mod -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Ties Stuij 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #--------------------------------------------------------------------------------- 2 | .SUFFIXES: 3 | #--------------------------------------------------------------------------------- 4 | 5 | #--------------------------------------------------------------------------------- 6 | # TARGET is the name of the output, if this ends with _mb generates a multiboot image 7 | # BUILD is the directory where object files & intermediate files will be placed 8 | # SOURCES is a list of directories containing source code 9 | # INCLUDES is a list of directories containing extra header files 10 | #--------------------------------------------------------------------------------- 11 | TARGET := rath 12 | BUILD := build 13 | SOURCES := source 14 | INCLUDES := include 15 | 16 | RATH_HOME := $${HOME}/code/rath 17 | ASSETS := $(RATH_HOME)/assets 18 | AAS_HOME := $(RATH_HOME)/deps/apex-audio-system 19 | AAS_BUILD := $(AAS_HOME)/build 20 | UART_HOME := $(RATH_HOME)/deps/gba-serial-adventures 21 | UART_LIB := $(UART_HOME)/build/libuart 22 | 23 | #--------------------------------------------------------------------------------- 24 | # Link Mode : NONE, MBV2, XBOO, UART 25 | #--------------------------------------------------------------------------------- 26 | 27 | LINKMODE := UART 28 | 29 | #--------------------------------------------------------------------------------- 30 | # options for code generation 31 | #--------------------------------------------------------------------------------- 32 | ARCH := -marm -mthumb-interwork -mlong-calls 33 | 34 | CFLAGS := -Wall -O3\ 35 | -mcpu=arm7tdmi -mtune=arm7tdmi\ 36 | -fomit-frame-pointer\ 37 | -ffast-math \ 38 | $(ARCH) 39 | 40 | CFLAGS += $(INCLUDE) -DLINK_$(LINKMODE) -DTARGET_$(TARGET) 41 | 42 | AFLAGS := $(ARCH) 43 | LDFLAGS = $(ARCH) -Wl,-Map,$(notdir $@).map 44 | 45 | #--------------------------------------------------------------------------------- 46 | # path to tools - this can be deleted if you set the path in windows 47 | #--------------------------------------------------------------------------------- 48 | # export PATH := /c/devkitARM_r11/bin:/bin:/c/bin 49 | 50 | CONV2AAS := $(AAS_BUILD)/conv2aas/conv2aas 51 | FCOMP := $(RATH_HOME)/tools/compiler.py 52 | TILED2BIN := $(RATH_HOME)/tools/tiled2bin.py 53 | 54 | #--------------------------------------------------------------------------------- 55 | # absolute path required since this makefile uses the build directory 56 | # as the working directory 57 | #--------------------------------------------------------------------------------- 58 | TONCLIB := $(DEVKITARM)/../libtonc 59 | AAS := $(AAS_BUILD)/aas 60 | LIBUART := $(UART_LIB) 61 | 62 | #--------------------------------------------------------------------------------- 63 | # the prefix on the compiler executables 64 | #--------------------------------------------------------------------------------- 65 | PREFIX := arm-none-eabi- 66 | #--------------------------------------------------------------------------------- 67 | # any extra libraries we wish to link with the project 68 | #--------------------------------------------------------------------------------- 69 | LIBS := -ltonc -lAAS -luart 70 | 71 | #--------------------------------------------------------------------------------- 72 | # list of directories containing libraries, this must be the top level containing 73 | # include and lib 74 | #--------------------------------------------------------------------------------- 75 | LIBDIRS := $(TONCLIB) $(AAS) $(LIBUART) 76 | 77 | #--------------------------------------------------------------------------------- 78 | # no real need to edit anything past this point unless you need to add additional 79 | # rules for different file extensions 80 | #--------------------------------------------------------------------------------- 81 | ifneq ($(BUILD),$(notdir $(CURDIR))) 82 | #--------------------------------------------------------------------------------- 83 | 84 | export OUTPUT := $(CURDIR)/$(TARGET) 85 | 86 | export VPATH := $(foreach dir,$(SOURCES),$(CURDIR)/$(dir)) 87 | 88 | export CC := $(PREFIX)gcc 89 | export CXX := $(PREFIX)g++ 90 | export AR := $(PREFIX)ar 91 | export OBJCOPY := $(PREFIX)objcopy 92 | #--------------------------------------------------------------------------------- 93 | # use CXX for linking C++ projects, CC for standard C 94 | #--------------------------------------------------------------------------------- 95 | #export LD := $(CXX) 96 | export LD := $(CC) 97 | 98 | CFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.c))) 99 | CPPFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.cpp))) 100 | SFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.s))) 101 | PCXFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.pcx))) 102 | BINFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.bin))) 103 | 104 | ifneq ("$(wildcard source/AAS_Data.s)","") 105 | SFILES := $(SFILES) 106 | else 107 | SFILES := $(SFILES) AAS_Data.s 108 | endif 109 | 110 | export OFILES := $(BINFILES:.bin=.o) $(PCXFILES:.pcx=.o)\ 111 | $(CPPFILES:.cpp=.o) $(CFILES:.c=.o) $(SFILES:.s=.o) 112 | 113 | export INCLUDE := $(foreach dir,$(INCLUDES),-I$(CURDIR)/$(dir)) \ 114 | $(foreach dir,$(LIBDIRS),-I$(dir)/include) \ 115 | -I$(CURDIR)/$(BUILD) 116 | 117 | export LIBPATHS := $(foreach dir,$(LIBDIRS),-L$(dir)/lib) 118 | 119 | .PHONY: $(BUILD) clean 120 | 121 | #--------------------------------------------------------------------------------- 122 | $(BUILD): music 123 | @[ -d $@ ] || mkdir -p $@ 124 | @make --no-print-directory -C $(UART_HOME) 125 | @make --no-print-directory -C $(BUILD) -f $(CURDIR)/Makefile 126 | 127 | #--------------------------------------------------------------------------------- 128 | clean: 129 | @echo clean ... 130 | @rm -fr $(BUILD) *.elf source/AAS_Data* 131 | @make --no-print-directory -C $(UART_HOME) clean 132 | @make --no-print-directory -C $(AAS_HOME) clean 133 | 134 | #--------------------------------------------------------------------------------- 135 | music: 136 | @make --no-print-directory -C $(AAS_HOME) 137 | $(CONV2AAS) $(RATH_HOME)/AAS_Data 138 | mv AAS_Data.* $(RATH_HOME)/source 139 | 140 | #--------------------------------------------------------------------------------- 141 | else 142 | 143 | DEPENDS := $(OFILES:.o=.d) 144 | 145 | #--------------------------------------------------------------------------------- 146 | # main targets 147 | #--------------------------------------------------------------------------------- 148 | $(OUTPUT).gba : $(OUTPUT).elf 149 | 150 | $(OUTPUT).elf : $(OFILES) 151 | 152 | #--------------------------------------------------------------------------------- 153 | %.gba: %.elf 154 | @echo built ... $(notdir $@) 155 | @$(OBJCOPY) -O binary $< $@ 156 | @gbafix $@ 157 | padbin 0x100 $(RATH_HOME)/rath.gba 158 | gbfs boot.gbfs $(RATH_HOME)/forth/lib/* 159 | cat $(RATH_HOME)/rath.gba boot.gbfs > $(RATH_HOME)/covid_adventure.gba 160 | 161 | #--------------------------------------------------------------------------------- 162 | %_mb.elf: 163 | @echo linking multiboot 164 | @$(LD) -specs=gba_mb.specs $(LDFLAGS) $(OFILES) $(LIBPATHS) $(LIBS) -o $@ 165 | 166 | #--------------------------------------------------------------------------------- 167 | %.elf: ass 168 | @echo linking cartridge 169 | @$(LD) $(LDFLAGS) -specs=gba.specs $(OFILES) $(LIBPATHS) $(LIBS) -o $@ 170 | 171 | #--------------------------------------------------------------------------------- 172 | ass: 173 | $(FCOMP) $(RATH_HOME)/forth/to-asm/d-lib-constants.fth -o ass.asm 174 | $(TILED2BIN) $(ASSETS)/apartment-map.json -o apt-toi.bin # things of interest 175 | convert $(ASSETS)/apartment-map.png apartment-map.png 176 | convert $(ASSETS)/phone.png phone.png 177 | grit apartment-map.png phone.png -ftb -mR8 -mLs -pS -O shared 178 | grit $(ASSETS)/snaggle.png -ftb -gB8 -gT 000000 -Mw 2 -Mh 4 179 | grit $(ASSETS)/splash.png -gb -gB16 -ftb 180 | grit $(ASSETS)/end.png -gb -gB16 -ftb 181 | 182 | #--------------------------------------------------------------------------------- 183 | # Compile Targets for C/C++ 184 | #--------------------------------------------------------------------------------- 185 | 186 | #--------------------------------------------------------------------------------- 187 | %.o : %.cpp 188 | @echo $(notdir $<) 189 | @$(CXX) -MM $(CFLAGS) -o $*.d $< 190 | @$(CXX) $(CFLAGS) -c $< -o$@ 191 | 192 | #--------------------------------------------------------------------------------- 193 | %.o : %.c 194 | @echo $(notdir $<) 195 | @$(CC) -MM $(CFLAGS) -o $*.d $< 196 | @$(CC) $(CFLAGS) -c $< -o$@ 197 | 198 | #--------------------------------------------------------------------------------- 199 | %.o : %.s 200 | @echo $(notdir $<) 201 | @$(CC) -MM $(CFLAGS) -o $*.d $< 202 | @$(CC) $(ASFLAGS) -c $< -o$@ 203 | 204 | define bin2o 205 | cp $(<) $(*).tmp 206 | $(OBJCOPY) -I binary -O elf32-littlearm -B arm \ 207 | --rename-section .data=.rodata,readonly,data,contents \ 208 | --redefine-sym _binary_$*_tmp_start=$*\ 209 | --redefine-sym _binary_$*_tmp_end=$*_end\ 210 | --redefine-sym _binary_$*_tmp_size=$*_size\ 211 | $(*).tmp $(@) 212 | echo "extern const u8" $(*)"[];" > $(*).h 213 | echo "extern const u32" $(*)_size[]";" >> $(*).h 214 | rm $(*).tmp 215 | endef 216 | 217 | #--------------------------------------------------------------------------------- 218 | %.o : %.pcx 219 | #--------------------------------------------------------------------------------- 220 | @echo $(notdir $<) 221 | @$(bin2o) 222 | 223 | #--------------------------------------------------------------------------------- 224 | %.o : %.bin 225 | #--------------------------------------------------------------------------------- 226 | @echo $(notdir $<) 227 | @$(bin2o) 228 | 229 | -include $(DEPENDS) 230 | 231 | #--------------------------------------------------------------------------------------- 232 | endif 233 | #--------------------------------------------------------------------------------------- 234 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Rath - civilized Game Boy Advance development from the comfort of your own editor 2 | 3 | ## what is it 4 | 5 | Rath is an interactive development environment for the Gameboy Advance using the 6 | Forth programming language. This means that you can send code and assets from 7 | your editor to your GBA while it is running. Either by typing on an interactive 8 | terminal (REPL), or by sending snippets of code straight from your 9 | files. Besides this you can of course compile whole GBA binaries as well, which 10 | you can run on a real GBA or in an emulator. 11 | 12 | The main programming language is Forth (Pandaforth), but you can also call from 13 | Forth into C, or whatever language can interface with the Arm ABI. Forth is a 14 | pretty awesome low-level programming language. This implementation/flavor is 15 | currently about 2000 lines of Arm assembly, including an interactive shell with 16 | which you can poke the environment and create new language constructs like 17 | functions and arrays, etc on the fly. As 2000 lines is not that much, you can 18 | feel pretty confident you can actually be in full control of your programming 19 | language. 20 | 21 | Using the [forth-mode Emacs 22 | package](https://github.com/larsbrinkhoff/forth-mode), you can send commands, 23 | files or file snippets straight from Emacs, never having to leave your editor 24 | ever again to repeat that pesky slow and soul-draining cycle of compiling, 25 | loading binaries on pesky flash carts, turning on your GBA and seeing things go 26 | up in flames yet again (your mileage may vary). 27 | 28 | [Youtube demo video](https://www.youtube.com/watch?v=tLI-5SVOY5A): 29 | 30 | [![youtube demo 31 | vid](https://img.youtube.com/vi/tLI-5SVOY5A/sddefault.jpg)](https://www.youtube.com/watch?v=tLI-5SVOY5A) 32 | 33 | ## history 34 | 35 | This is a fork of a Pandaforth repo I found online which is an unmodified 36 | version of the sources Torlus published in 2005. Which itself is a port of 37 | Camelforth for the Z80, first published by Bradford J. Rodriguez in 1994. 38 | 39 | For the original Pandaforth readme, which contains interesting technical 40 | information, see the readme.txt file in this repo. 41 | 42 | ## example game 43 | 44 | I created an [entry](https://klomp.itch.io/covid-adventure) for the [itch.io GBA Jam 45 | 2021](https://itch.io/jam/gbajam21), which is a very simple top-down 2D tile 46 | background based intro to a possible adventure/RPG. 47 | 48 | [Youtube video](https://www.youtube.com/watch?v=sxgEoEmLS8s): 49 | 50 | [![youtube demo 51 | vid](https://img.youtube.com/vi/sxgEoEmLS8s/sddefault.jpg)](https://www.youtube.com/watch?v=sxgEoEmLS8s) 52 | 53 | 54 | The main code is in `/forth/to-asm/d-lib-constants.fth` file. All the game 55 | logic is in Forth. We use C for system bootstrap, serial communication and for 56 | glue code between Forth, the music engine and the interrupt routines. The latter 57 | two are written in assembly. 58 | 59 | ## features 60 | 61 | ### library 62 | 63 | There's a decent amount of library code: 64 | - constants for memory locations and IO registers 65 | - shadow OAM that updates the OAM data on vblank 66 | - key press detection 67 | - abstract sprite object that tracks various properties 68 | - player movement 69 | - sprite direction logic 70 | - text boxes 71 | - collision detection 72 | - 'things of interest' map overlay that can be queried at tile granularity 73 | - layer blending 74 | - interrupts, which are handled by tonclib, interfaced through C 75 | - sound: Apex Audio System 76 | 77 | The big issue currently with the library is that it's quite intertwined with the 78 | game that I wrote it for. Hopefully I will find some time to disentangle the 79 | two. Which for the majority of the library code shouldn't be too hard. 80 | 81 | The library code is still a far cry from general and flexible. The only way it 82 | will move towards this ideal is if it will actually need to evolve because of 83 | real-world demand. But I must say that Forth is lends itself quite well to 84 | refactoring if need be. 85 | 86 | 87 | ### serial communication 88 | 89 | Back in 2005, computers still came standard with serial ports, and the prevaling 90 | methods to connect to your GBA were mbv2 and Xboo cables. It turns out you can 91 | also use USB UART cables. I made a repo with code and a tutorial on how to make 92 | one: [gba-serial-adventures](https://github.com/stuij/gba-serial-adventures) 93 | 94 | I concocted a (very simple) custom communication protocol between computer and 95 | GBA that does checksums of data the computer sends. Also the GBA receives data 96 | async in a ring buffer so we can blast at 115200 baud, without spinning when 97 | waiting on data while waiting on input (perhaps Xboo and MBv2 did this too, I 98 | have no idea). In any case, this makes sending binary data at reasonable speeds 99 | possible, without having to worry if we dropped a bit somewhere. 100 | 101 | I've added a (hopefully cross-platform) Python shell script to interface with 102 | the GBA from a computer. 103 | 104 | ### some modernizations and breaking changes from the original Pandaforth 105 | 106 | - builds expect a modern devkitPro. 107 | - switched from libgba to libtonc 108 | - converted all Forth words to lowercase 109 | - removed mbv2 and Xboo support, added own serial protocol 110 | - added halfword memory access words 111 | - for speed added byte access words that use ldrb instead of ldrh 112 | - for speed rewrote `move` and `fill` functions in assembly. 113 | - moved Forth base system from ewram to iwram 114 | 115 | For the game I needed a cross-compiler, as compiling code at runtime is way to 116 | slow for a game. Very quickly I was running up against compile times of half a 117 | minute. What I have now is something quite hackish and simplistic. We can 118 | compile but we don't really understand the Forth code. The cross-compiler isn't 119 | strong enough to handle `immediate mode`. Some immediate words like loop 120 | constructs are handled by specialized Python code. Ideally we would rewrite the 121 | compiler to interpret all the Forth primitives in some abstract way. Hopefully 122 | I'll find the time for this some day. 123 | 124 | ## how to build/use 125 | 126 | This repo contains submodules, so when you pull from Github, make sure to pull 127 | the submodules as well: 128 | 129 | git clone --recurse-submodules git@github.com:stuij/rath.git 130 | 131 | Install devkitARM, libtonc, and make sure the binaries are in your exec 132 | path. Also make sure the $(DEVKITARM) env variable is set to your devkitARM 133 | folder. 134 | 135 | Run `make` in the root of the repo. This creates two binaries called `rath.gba`, 136 | and `covid-adventures.gba`. The former is the Forth base system, which you can 137 | interact with through a serial cable. The latter is the demo game. 138 | 139 | For interactive development, flash the binary on a cart, put the cart in a Game 140 | Boy Advance, and start it. `rath.gba` will put you in repl 141 | mode. `covid-adventures.gba` should start a game loop with a little sprite you 142 | can control with the direction pad. To jump out of the game loop and into the 143 | repl, press select. Currently, I temporarily broke the interactivity in 144 | `covid-adventures.gba` as I ran up against a deadline of a game jam. I hope to 145 | reinstate it soon. 146 | 147 | To connect to said binary with a UART cable: 148 | `/shell/shell.py --gbaser /dev/ttyUSB0` 149 | 150 | For a simple shell.py help text: 151 | `/shell/shell.py --help` 152 | 153 | And then type Forth code, one line at a time. 154 | 155 | To load files into the GBA from the REPL, type: 156 | `include ` 157 | 158 | To use Rath with Emacs (see video above), use the [forth-mode Emacs 159 | package](https://github.com/larsbrinkhoff/forth-mode). It looked like the 160 | package doesn't allow arguments to the Forth program it asks for, so I've 161 | wrapped the above cmdline invocation in a one-liner script. 162 | 163 | You can also run the PFdemo.gba file in an emulator, if you want to move the 164 | little sprite around. Not too exciting to all, but I think it's quite cool :D 165 | 166 | 167 | ## attribution and licensing 168 | 169 | Forth programming language: 170 | 171 | The underlying Forth system was originally written by Bradford J. Rodriguez in 172 | 1994 for the Z80. This Forth flavor is known as CamelForth. 173 | 174 | - license: see /source/cam80-12/README.Z80 in this repo 175 | - site: http://www.camelforth.com 176 | 177 | Camelforth was ported to armv4 by Torlus, with no explicit copyright statement 178 | other than a (c) after their name in /README.txt in this repo. 179 | 180 | I myself have made some modifications to the Forth sources, and I've added a 181 | simplistic cross compiler. 182 | 183 | For the original code by Torlus, see the first commit in this repo, which was 184 | put on Github by user `iansharkey`: https://github.com/iansharkey/pandaforth 185 | 186 | 187 | Assets used for the example game: 188 | 189 | intro/continue screen Covid virus impression: 190 | - credit: Alissa Eckert, MSMI; Dan Higgins, MAMS 191 | - license: public domain 192 | - site: https://phil.cdc.gov/Details.aspx?pid=23311 193 | 194 | ring tone: "phone ringing.wav" 195 | - credit: `Tomlija`, on freesound.org 196 | - license: Creative Commons, Attribution 197 | https://creativecommons.org/licenses/by/3.0/ 198 | - site: https://freesound.org/s/98023 199 | 200 | piano note: pianos/roland_grand_piano/C6.WAV 201 | - credit: the WaveWorld sample library 202 | - license: public domain 203 | - site: https://modarchive.org/forums/index.php?topic=2406.0 204 | 205 | The font came with Pandaforth. 206 | 207 | For the IO register naming conventions and the key input logic, I've adapted the 208 | code in the headers of [libtonc](https://github.com/devkitPro/libtonc). 209 | 210 | The rest of the assets and code for the example game was made by me: 211 | - pixelart for apartment, phone and player sprite-work 212 | - dialog, text 213 | - music 214 | - programming 215 | 216 | 217 | The license for any modifications, additions to existing work and also all the 218 | original work by me in any medium falls under the repo-wide license, which can 219 | be found in /LICENSE. 220 | 221 | Please let me know if I've overlooked anything asset or license related. 222 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | PandaForth by Torlus (c) 2005 - http://torlus.com/ 2 | Based on Bradford J. Rodriguez's CamelForth for the Z80 (c) 1994 3 | 4 | =============================================================================== 5 | 6 | 1. About Forth 7 | 2. About PandaForth 8 | 3. Contents 9 | 4. Running the demos 10 | 5. Building PandaForth 11 | 6. Writing your own code 12 | 7. Advanced topics 13 | 8. Credits 14 | 15 | =============================================================================== 16 | 1. About Forth 17 | =============================================================================== 18 | 19 | If you don't know what Forth is, http://www.forth.org/ is a good starting point. 20 | 21 | Basically Forth is a stack-based language using "reverse polish" notation. 22 | It provides an interpreter which is able to be extended with new definitions. 23 | 24 | Unlike BASIC interpreters, new "definitions" (or "functions", Forth users 25 | generally talk about "words") are _compiled_ which means that there is no 26 | difference in performance between newly created words, and the original ones 27 | provided by the interpreter (except for those few written in assembly). 28 | 29 | Forth is a kind of (unmanaged) virtual machine. Unlike Java virtual machines, 30 | a Forth engine is very simple and will usually fit in less than 10Kb 31 | (yes, "ten. kilo. bytes." :)). For design considerations about Forth, I highly 32 | recommend Bradford J. Rodriguez's publications about them. 33 | Check his site at http://www.zetetics.com/bj/papers/. 34 | 35 | =============================================================================== 36 | 2. About PandaForth 37 | =============================================================================== 38 | 39 | PandaForth is a Direct-Threaded-Code 32-bits Forth, written in ARM assembly. 40 | A few part of the source is in C, in order to use WinterMute's libgba functions, 41 | but not for Forth implementation itself. It should be not too far from ANS-Forth 42 | compliance, for the wordset at least. 43 | 44 | One of its funniest features is that you can use the interpreter directly from 45 | your computer if you have a MBV2 cable, by using the "console mode" of the tool 46 | bundled with it. 47 | (see http://www.devrs.com/gba/files/mbv2faqs.php if you don't know what it is) 48 | 49 | If you don't have such a cable, you can still test the interpreter features on 50 | hardware on in an emulator, as PandaForth is able to "embed" source with the 51 | help of Damian Yerrick's GBFS library for GBA. 52 | 53 | =============================================================================== 54 | 3. Contents 55 | =============================================================================== 56 | 57 | The archive contains the following folders : 58 | source/ PandaForth source (C,asm) and libgbfs 59 | source/cam80-12 CamelForth for Z80 60 | libgba/ headers,lib and source for libgba 61 | res/ some resources used by the demo 62 | tools/ Windows/Linux build of GBFS tools, with source 63 | forth/ Forth source : gba-related, demo 64 | 65 | At the root of the archive, you will find : 66 | demo.bat to build and run the demo (on emulator) 67 | demoMBV2.bat to build a multiboot image and run it 68 | through a MBV2 cable 69 | buildall.bat script to build all the different configurations 70 | Makefile 71 | PFdemo.gba a ready-to-run cartridge build of the demo 72 | *.gba other builds (without embedded source) 73 | 74 | =============================================================================== 75 | 4. Running the demos 76 | =============================================================================== 77 | 78 | For the impatient, there is a "PFdemo.gba" ready to run on emulator or hardware. 79 | 80 | You will see the interpreter in action, parsing some text, and after a while, 81 | a silly little demo will run for a while. This file has been generated by running 82 | "demo.bat". 83 | 84 | If you have a look at the "demo.bat" file, you will notice that it uses GBFS.exe 85 | to append some source files (located in "forth" directory) to an image. 86 | If you are familiar with Forth, you can add your own stuff in these files, re-run 87 | "demo.bat" to test the interpreter. 88 | 89 | For the happy few that have a MBV2 cable, then run "demoMBV2.bat". 90 | It will upload PandaForth to your GBA, then switch the PC in console mode, 91 | allowing you then to communicate directly with the interpreter :) 92 | In my configuration, I always get not-so-random "noise" from the PC side, but 93 | the output from PC to GBA is working fine, so you can use the interpreter quite 94 | easily. 95 | 96 | =============================================================================== 97 | 5. Building PandaForth 98 | =============================================================================== 99 | 100 | If you didn't unpack the archive to C:\Forth as I suggested on my website, do it, 101 | as some paths are absolute. 102 | 103 | You will need to have the DevkitARM toolchain (I used r11), and MSYS. All these 104 | items can be found at WinterMute's site at http://www.devkit.tk/. 105 | With a PATH variable properly set up (C:\DevkitARM_r11\bin;C:\msys at the 106 | beginning), you can run the "buildall.bat" script to build the different 107 | configurations. 108 | 109 | Note that there is support for XBOO cable, partially tested : the interpreter is 110 | able to output characters to the PC, but for the moment there is no software 111 | supporting a "console mode", as does MBV2's MB.exe. 112 | 113 | The "buildall.bat" script will generate 3 files : 114 | - PF.gba, that can run from a cartridge but has no link cable support. 115 | - PFmbv2.gba, that can run from a cartridge and has mbv2 cable link support. 116 | In this case, just run "mb.exe -c -x 255" before powering up the GBA to 117 | enable console mode. 118 | - PFmbv2_mb.gba, that is a multiboot image with mbv2 link support. This is the 119 | one used in the "demoMBV2.bat" script. It uploads to your GBA via the mbv2, 120 | then switch to console mode once it's done. 121 | 122 | =============================================================================== 123 | 6. Writing your own code 124 | =============================================================================== 125 | 126 | The easier way is to edit or add files into the "forth" folder, so you'll be 127 | able to use the "demo.bat" or "demoMBV2.bat" scripts. 128 | 129 | One thing you need to know about file naming : GBFS tool "GBFS.exe" sorts the 130 | files in alphabetical order, so the files will be interpreted by PandaForth 131 | in this order. That's the reason why, for the demo, there is a "a_gba.pf" and 132 | a "z_demo.pf", as the second source needs that the first one to be interpreted 133 | before. 134 | 135 | PandaForth is case-sensitive, so be careful when defining/using words :) 136 | 137 | Useful commands : 138 | - WORDS that returns the list of available Forth words. 139 | - .S that shows the contents of the stack. 140 | 141 | =============================================================================== 142 | 7. Advanced topics 143 | =============================================================================== 144 | 145 | * Emedding resources. 146 | 147 | To make some resources (bitmaps, etc.) available to PandaForth, a simple and dirty 148 | way is to create a VARIABLE pointing to them, and use .incbin to include them. 149 | Open the "PF.s" source file, and go at the end of it. 150 | You will see the following lines : 151 | 152 | 8<----------------------------------------------------------------------------- 153 | head PAL_BALL3,9,"PAL_BALL3",dovar,PAL_BALL2 154 | .incbin "C:/Forth/PF4ARM/res/pal3.pal" 155 | .align 156 | 157 | .set lastword, link_PAL_BALL3 /* last word */ 158 | 8<----------------------------------------------------------------------------- 159 | 160 | You can insert your declaration like this : 161 | 162 | 8<----------------------------------------------------------------------------- 163 | head PAL_BALL3,9,"PAL_BALL3",dovar,PAL_BALL2 164 | .incbin "C:/Forth/PF4ARM/res/pal3.pal" 165 | .align 166 | 167 | head SMILE,3,"8=]",dovar,PAL_BALL3 168 | .incbin "C:/absolute/path/to/your/file.bin" 169 | .align 170 | 171 | .set lastword, link_SMILE /* last word */ 172 | enddict: 173 | 8<----------------------------------------------------------------------------- 174 | 175 | the "head" macro adds an entry to Forth dictionary. The parameters are : 176 | - label name (a name which format is correct as a label name for the assembler) 177 | here : SMILE 178 | - the length of your word (here : 8=] which is 3 characters long) 179 | - the name that will be used within Forth (here : 8=] ) 180 | - the name of the previous label (here PAL_BALL3, that was previously the last word). 181 | 182 | The "lastword" definition needs also to be changed to point to link_SMILE. 183 | 184 | In PandaForth, executing 8=] will push the address of the beginning of your 185 | resource onto the parameter stack. 186 | 187 | This solution isn't very good, a better solution can be achieved by extending 188 | PandaForth (see below). 189 | 190 | * Extending PandaForth. 191 | 192 | PandaForth is very close to CamelForth. I kept the BDOS word (CP/M function call), 193 | which is hooked up to a C function called "service" (see the file "main.c"). 194 | BDOS take two parameters : one "service number" and one parameter. 195 | 196 | Two service numbers are currently defined : 197 | - 6, used for reading and writing to the console (used by the interpreter). 198 | - 1, that waits for a vblank interrupt. 199 | 200 | It's easy to add new functions here. The return value of the function will be 201 | available from Forth in the parameter stack. 202 | 203 | =============================================================================== 204 | 8. Credits 205 | =============================================================================== 206 | 207 | Many thanks to : 208 | - Bradford J. Rodriguez, for his CamelForth and articles about Forth. 209 | http://www.zetetics.com/bj/papers/ 210 | - WinterMute, for DevkitARM, libgba, xboo, and clean Makefile. 211 | http://www.devit.tk/ 212 | - Damian Yerrick, for GBFS. 213 | http://www.pineight.com/ 214 | - DaLK, for the gfx used in the demo. 215 | - krb, for gba-tt tool I used for the demo. 216 | http://www.pascalorama.com/ 217 | - BigRedPimp, for testing. 218 | http://www.bigredpimp.com/ 219 | - All infomation sites about GBA, as usual... 220 | http://www.gbadev.org/ 221 | http://www.devrs.com/ 222 | http://www.work.de/nocash/gbatek.htm 223 | 224 | And greetings to people on EFNET #gbadev and #gbadevfr ! 225 | 226 | Enjoy, 227 | 228 | Torlus 229 | 230 | -------------------------------------------------------------------------------- /assets/apartment-map-tiled.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment-map-tiled.png -------------------------------------------------------------------------------- /assets/apartment-map.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment-map.png -------------------------------------------------------------------------------- /assets/apartment-tiles.ase: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment-tiles.ase -------------------------------------------------------------------------------- /assets/apartment-tiles.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment-tiles.png -------------------------------------------------------------------------------- /assets/apartment.ase: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment.ase -------------------------------------------------------------------------------- /assets/apartment.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/apartment.png -------------------------------------------------------------------------------- /assets/ball.raw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/ball.raw -------------------------------------------------------------------------------- /assets/end.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/end.png -------------------------------------------------------------------------------- /assets/end.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/end.xcf -------------------------------------------------------------------------------- /assets/pal1.pal: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/pal1.pal -------------------------------------------------------------------------------- /assets/pal2.pal: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/pal2.pal -------------------------------------------------------------------------------- /assets/pal3.pal: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/pal3.pal -------------------------------------------------------------------------------- /assets/phone.ase: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/phone.ase -------------------------------------------------------------------------------- /assets/phone.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/phone.png -------------------------------------------------------------------------------- /assets/snaggle.ase: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/snaggle.ase -------------------------------------------------------------------------------- /assets/snaggle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/snaggle.png -------------------------------------------------------------------------------- /assets/splash.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/splash.png -------------------------------------------------------------------------------- /assets/splash.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuij/rath/89b6f0eb1fe8160632ae219862a753c64b790e36/assets/splash.xcf -------------------------------------------------------------------------------- /buildall.bat: -------------------------------------------------------------------------------- 1 | @echo OFF 2 | @echo Building CARTRIDGE - NO CABLE SUPPORT 3 | make clean 4 | make -r TARGET=PF LINKMODE=NONE 5 | @echo Done [ PF.gba ] 6 | @echo Building MULTIBOOT - MBV2 7 | make clean 8 | make -r TARGET=PFmbv2_mb LINKMODE=MBV2 9 | @echo Done [ PFmbv2_mb.gba ] 10 | make clean 11 | -------------------------------------------------------------------------------- /demo.bat: -------------------------------------------------------------------------------- 1 | @echo OFF 2 | @echo Adding source files to ROM... 3 | padbin 0x100 rath.gba 4 | gbfs boot.gbfs forth\lib\* 5 | copy /B rath.gba + boot.gbfs rath-demo.gba 6 | @echo Done! [ rath-demo.gba ] created. 7 | mgba rath-demo.gba 8 | -------------------------------------------------------------------------------- /demo.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ROOT="$( cd "$( dirname "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )" 4 | 5 | echo Adding source files to ROM... 6 | 7 | padbin 0x100 $ROOT/rath.gba 8 | gbfs boot.gbfs $ROOT/forth/lib/* 9 | cat $ROOT/rath.gba boot.gbfs > $ROOT/covid_adventure.gba 10 | 11 | echo Done! [ covid_adventure.gba ] created. 12 | -------------------------------------------------------------------------------- /forth/demo/a_gba.pf: -------------------------------------------------------------------------------- 1 | hex 2 | 3 | ( usual definitions ) 4 | 06000000 constant mem_vram 5 | 07000000 constant mem_oam 6 | mem_vram 10000 + constant mem_vram_obj 7 | 05000200 constant mem_pal_obj 8 | 9 | ( example of a create .. does> definition ) 10 | : sprite create 8 * mem_oam + , does> @ ; ( n -- ) 11 | 12 | ( some utility functions for sprites ) 13 | : sy@ c@ ; ( spr -- y ) 14 | : sy! ch! ; ( y spr -- ) 15 | : sx@ @ 01ff0000 and 10 rshift ; ( spr -- x ) 16 | : sx! dup @ fe00ffff and rot 1ff and 10 lshift or swap ! ; ( x spr -- ) 17 | 18 | : spal@ 4 + @ 0000f000 and c rshift ; ( spr -- pal ) 19 | : spal! 4 + dup @ ffff0fff and rot f and c lshift or swap ! ; ( pal spr -- ) 20 | 21 | ( wait for vblank interrupt ) 22 | : vsync 1 1 bdos drop ; 23 | -------------------------------------------------------------------------------- /forth/demo/z_demo.pf: -------------------------------------------------------------------------------- 1 | decimal 2 | 3 | ( load resources into vram ) 4 | gfx_ball mem_vram_obj 32 wmove 5 | pal_ball1 mem_pal_obj 32 hmove 6 | pal_ball2 mem_pal_obj 32 + 32 cmove 7 | pal_ball3 mem_pal_obj 64 + 32 move 8 | 9 | ( ball sprites ) 10 | 0 sprite first_ball 11 | 1 sprite second_ball 12 | 2 sprite third_ball 13 | 14 | ( assign palettes ) 15 | 0 first_ball spal! 16 | 1 second_ball spal! 17 | 2 third_ball spal! 18 | 19 | ( structure holding ball direction ) 20 | : direction create 2 cells allot ; 21 | : d>dx ; 22 | : d>dy cell+ ; 23 | 24 | direction first_ball_dir 25 | direction second_ball_dir 26 | direction third_ball_dir 27 | 28 | : init_direction >r r@ d>dy ! r> d>dx ! ; ( dx dy pos -- ) 29 | : init_position >r r@ sy! r> sx! ; ( x y spr -- ) 30 | 31 | : invert_dx d>dx dup @ negate swap ! ; ( dir -- ) 32 | : invert_dy d>dy dup @ negate swap ! ; ( dir -- ) 33 | 34 | : test_north sy@ 0= if invert_dy else drop then ; ( dir spr -- ) 35 | : test_south sy@ 152 = if invert_dy else drop then ; ( dir spr -- ) 36 | : test_west sx@ 0= if invert_dx else drop then ; ( dir spr -- ) 37 | : test_east sx@ 232 = if invert_dx else drop then ; ( dir spr -- ) 38 | 39 | : test_bounds 2dup test_north 2dup test_south 2dup test_west test_east ; ( dir spr -- ) 40 | 41 | : move_x swap d>dx @ over sx@ + swap sx! ; ( dir spr -- ) 42 | : move_y swap d>dy @ over sy@ + swap sy! ; ( dir spr -- ) 43 | 44 | : move 2dup move_x move_y ; ( dir spr -- ) 45 | 46 | : demo 47 | 1 1 first_ball_dir init_direction 15 15 first_ball init_position 48 | 1 -1 second_ball_dir init_direction 180 98 second_ball init_position 49 | -1 1 third_ball_dir init_direction 230 140 third_ball init_position 50 | 1024 51 | ." demo started, " dup . ." cycles to go" cr 52 | 1 do 53 | i 255 and 0= if 54 | ." ..." i . 55 | then 56 | first_ball_dir first_ball 2dup move test_bounds 57 | second_ball_dir second_ball 2dup move test_bounds 58 | third_ball_dir third_ball 2dup move test_bounds 59 | vsync 60 | loop 61 | ." done." cr 62 | ; ( -- ) 63 | 64 | demo 65 | -------------------------------------------------------------------------------- /forth/lib/e-lib-routines.fth: -------------------------------------------------------------------------------- 1 | hex 2 | 3 | ( oam shadow list algos ) 4 | 5 | init 6 | -------------------------------------------------------------------------------- /shell/dpansf.py: -------------------------------------------------------------------------------- 1 | words = { 2 | "CORE" : { 3 | "!" : "6.1.0010", 4 | "#" : "6.1.0030", 5 | "'" : "6.1.0070", 6 | "(" : "6.1.0080", 7 | "*" : "6.1.0090", 8 | "+" : "6.1.0120", 9 | "," : "6.1.0150", 10 | "-" : "6.1.0160", 11 | "." : "6.1.0180", 12 | "/" : "6.1.0230", 13 | ":" : "6.1.0450", 14 | ";" : "6.1.0460", 15 | "<" : "6.1.0480", 16 | "=" : "6.1.0530", 17 | ">" : "6.1.0540", 18 | "@" : "6.1.0650", 19 | "I" : "6.1.1680", 20 | "J" : "6.1.1730", 21 | "[" : "6.1.2500", 22 | "]" : "6.1.2540", 23 | "#>" : "6.1.0040", 24 | "#S" : "6.1.0050", 25 | "*/" : "6.1.0100", 26 | "+!" : "6.1.0130", 27 | '."' : "6.1.0190", 28 | "0<" : "6.1.0250", 29 | "0=" : "6.1.0270", 30 | "1+" : "6.1.0290", 31 | "1-" : "6.1.0300", 32 | "2!" : "6.1.0310", 33 | "2*" : "6.1.0320", 34 | "2/" : "6.1.0330", 35 | "2@" : "6.1.0350", 36 | "<#" : "6.1.0490", 37 | ">R" : "6.1.0580", 38 | "BL" : "6.1.0770", 39 | "C!" : "6.1.0850", 40 | "C," : "6.1.0860", 41 | "C@" : "6.1.0870", 42 | "CR" : "6.1.0990", 43 | "DO" : "6.1.1240", 44 | "IF" : "6.1.1700", 45 | "M*" : "6.1.1810", 46 | "OR" : "6.1.1980", 47 | "R>" : "6.1.2060", 48 | "R@" : "6.1.2070", 49 | 'S"' : "6.1.2165", 50 | "U." : "6.1.2320", 51 | "U<" : "6.1.2340", 52 | ">IN" : "6.1.0560", 53 | "ABS" : "6.1.0690", 54 | "AND" : "6.1.0720", 55 | "DUP" : "6.1.1290", 56 | "KEY" : "6.1.1750", 57 | "MAX" : "6.1.1870", 58 | "MIN" : "6.1.1880", 59 | "MOD" : "6.1.1890", 60 | "ROT" : "6.1.2160", 61 | "S>D" : "6.1.2170", 62 | "UM*" : "6.1.2360", 63 | "XOR" : "6.1.2490", 64 | "[']" : "6.1.2510", 65 | "/MOD" : "6.1.0240", 66 | "2DUP" : "6.1.0380", 67 | "?DUP" : "6.1.0630", 68 | "BASE" : "6.1.0750", 69 | "CHAR" : "6.1.0895", 70 | "DROP" : "6.1.1260", 71 | "ELSE" : "6.1.1310", 72 | "EMIT" : "6.1.1320", 73 | "EXIT" : "6.1.1380", 74 | "FILL" : "6.1.1540", 75 | "FIND" : "6.1.1550", 76 | "HERE" : "6.1.1650", 77 | "HOLD" : "6.1.1670", 78 | "LOOP" : "6.1.1800", 79 | "MOVE" : "6.1.1900", 80 | "OVER" : "6.1.1990", 81 | "QUIT" : "6.1.2050", 82 | "SIGN" : "6.1.2210", 83 | "SWAP" : "6.1.2260", 84 | "THEN" : "6.1.2270", 85 | "TYPE" : "6.1.2310", 86 | "WORD" : "6.1.2450", 87 | "*/MOD" : "6.1.0110", 88 | "+LOOP" : "6.1.0140", 89 | "2DROP" : "6.1.0370", 90 | "2OVER" : "6.1.0400", 91 | "2SWAP" : "6.1.0430", 92 | ">BODY" : "6.1.0550", 93 | "ABORT" : "6.1.0670", 94 | "ALIGN" : "6.1.0705", 95 | "ALLOT" : "6.1.0710", 96 | "BEGIN" : "6.1.0760", 97 | "CELL+" : "6.1.0880", 98 | "CELLS" : "6.1.0890", 99 | "CHAR+" : "6.1.0897", 100 | "CHARS" : "6.1.0898", 101 | "COUNT" : "6.1.0980", 102 | "DEPTH" : "6.1.1200", 103 | "DOES>" : "6.1.1250", 104 | "LEAVE" : "6.1.1760", 105 | "SPACE" : "6.1.2220", 106 | "STATE" : "6.1.2250", 107 | "UNTIL" : "6.1.2390", 108 | "WHILE" : "6.1.2430", 109 | 'ABORT"' : "6.1.0680", 110 | "ACCEPT" : "6.1.0695", 111 | "CREATE" : "6.1.1000", 112 | "FM/MOD" : "6.1.1561", 113 | "INVERT" : "6.1.1720", 114 | "LSHIFT" : "6.1.1805", 115 | "NEGATE" : "6.1.1910", 116 | "REPEAT" : "6.1.2140", 117 | "RSHIFT" : "6.1.2162", 118 | "SM/REM" : "6.1.2214", 119 | "SOURCE" : "6.1.2216", 120 | "SPACES" : "6.1.2230", 121 | "UM/MOD" : "6.1.2370", 122 | "UNLOOP" : "6.1.2380", 123 | "[CHAR]" : "6.1.2520", 124 | ">NUMBER" : "6.1.0570", 125 | "ALIGNED" : "6.1.0706", 126 | "DECIMAL" : "6.1.1170", 127 | "EXECUTE" : "6.1.1370", 128 | "LITERAL" : "6.1.1780", 129 | "RECURSE" : "6.1.2120", 130 | "CONSTANT" : "6.1.0950", 131 | "EVALUATE" : "6.1.1360", 132 | "POSTPONE" : "6.1.2033", 133 | "VARIABLE" : "6.1.2410", 134 | "IMMEDIATE" : "6.1.1710", 135 | "ENVIRONMENT?" : "6.1.1345", 136 | }, 137 | 'CORE-EXT' : { 138 | "\\" : "6.2.2535", 139 | ".(" : "6.2.0200", 140 | ".R" : "6.2.0210", 141 | "0>" : "6.2.0280", 142 | "<>" : "6.2.0500", 143 | 'C"' : "6.2.0855", 144 | "OF" : "6.2.1950", 145 | "TO" : "6.2.2295", 146 | "U>" : "6.2.2350", 147 | "0<>" : "6.2.0260", 148 | "2>R" : "6.2.0340", 149 | "2R>" : "6.2.0410", 150 | "2R@" : "6.2.0415", 151 | "?DO" : "6.2.0620", 152 | "HEX" : "6.2.1660", 153 | "NIP" : "6.2.1930", 154 | "PAD" : "6.2.2000", 155 | "TIB" : "6.2.2290", 156 | "U.R" : "6.2.2330", 157 | "#TIB" : "6.2.0060", 158 | "CASE" : "6.2.0873", 159 | "PICK" : "6.2.2030", 160 | "ROLL" : "6.2.2150", 161 | "SPAN" : "6.2.2240", 162 | "TRUE" : "6.2.2298", 163 | "TUCK" : "6.2.2300", 164 | "AGAIN" : "6.2.0700", 165 | "ENDOF" : "6.2.1343", 166 | "ERASE" : "6.2.1350", 167 | "FALSE" : "6.2.1485", 168 | "PARSE" : "6.2.2008", 169 | "QUERY" : "6.2.2040", 170 | "VALUE" : "6.2.2405", 171 | "EXPECT" : "6.2.1390", 172 | "MARKER" : "6.2.1850", 173 | "REFILL" : "6.2.2125", 174 | "UNUSED" : "6.2.2395", 175 | "WITHIN" : "6.2.2440", 176 | ":NONAME" : "6.2.0455", 177 | "CONVERT" : "6.2.0970", 178 | "ENDCASE" : "6.2.1342", 179 | "COMPILE," : "6.2.0945", 180 | "SOURCE-ID" : "6.2.2218", 181 | "[COMPILE]" : "6.2.2530", 182 | "SAVE-INPUT" : "6.2.2182", 183 | "RESTORE-INPUT" : "6.2.2148", 184 | }, 185 | 'DOUBLE' : { 186 | "D+" : "8.6.1.1040", 187 | "D-" : "8.6.1.1050", 188 | "D." : "8.6.1.1060", 189 | "D<" : "8.6.1.1110", 190 | "D=" : "8.6.1.1120", 191 | "M+" : "8.6.1.1830", 192 | "D.R" : "8.6.1.1070", 193 | "D0<" : "8.6.1.1075", 194 | "D0=" : "8.6.1.1080", 195 | "D2*" : "8.6.1.1090", 196 | "D2/" : "8.6.1.1100", 197 | "D>S" : "8.6.1.1140", 198 | "M*/" : "8.6.1.1820", 199 | "DABS" : "8.6.1.1160", 200 | "DMAX" : "8.6.1.1210", 201 | "DMIN" : "8.6.1.1220", 202 | "DNEGATE" : "8.6.1.1230", 203 | "2LITERAL" : "8.6.1.0390", 204 | "2CONSTANT" : "8.6.1.0360", 205 | "2VARIABLE" : "8.6.1.0440", 206 | }, 207 | 'DOUBLE-EXT' : { 208 | "DU<" : "8.6.2.1270", 209 | "2ROT" : "8.6.2.0420", 210 | }, 211 | 'FACILITY' : { 212 | "KEY?" : "10.6.1.1755", 213 | "PAGE" : "10.6.1.2005", 214 | "AT-XY" : "10.6.1.0742", 215 | }, 216 | 'FACILITY-EXT' : { 217 | "MS" : "10.6.2.1905", 218 | "EKEY" : "10.6.2.1305", 219 | "EKEY?" : "10.6.2.1307", 220 | "EMIT?" : "10.6.2.1325", 221 | "EKEY>CHAR" : "10.6.2.1306", 222 | "TIME&DATE" : "10.6.2.2292", 223 | }, 224 | 'STRING' : { 225 | "BLANK" : "17.6.1.0780", 226 | "CMOVE" : "17.6.1.0910", 227 | "CMOVE>" : "17.6.1.0920", 228 | "SEARCH" : "17.6.1.2191", 229 | "/STRING" : "17.6.1.0245", 230 | "COMPARE" : "17.6.1.0935", 231 | "SLITERAL" : "17.6.1.2212", 232 | "-TRAILING" : "17.6.1.0170", 233 | }, 234 | 'TOOLS' : { 235 | "?" : "15.6.1.0600", 236 | ".S" : "15.6.1.0220", 237 | "SEE" : "15.6.1.2194", 238 | "DUMP" : "15.6.1.1280", 239 | "WORDS" : "15.6.1.2465", 240 | }, 241 | 'TOOLS-EXT' : { 242 | "BYE" : "15.6.2.0830", 243 | "CODE" : "15.6.2.0930", 244 | "[IF]" : "15.6.2.2532", 245 | ";CODE" : "15.6.2.0470", 246 | "AHEAD" : "15.6.2.0702", 247 | "STATE" : "15.6.2.2250", 248 | "EDITOR" : "15.6.2.1300", 249 | "FORGET" : "15.6.2.1580", 250 | "[ELSE]" : "15.6.2.2531", 251 | "[THEN]" : "15.6.2.2533", 252 | "CS-PICK" : "15.6.2.1015", 253 | "CS-ROLL" : "15.6.2.1020", 254 | "ASSEMBLER" : "15.6.2.0740", 255 | }, 256 | 'EXCEPTION' : { 257 | "CATCH" : "9.6.1.0875", 258 | "THROW" : "9.6.1.2275", 259 | }, 260 | 'EXCEPTION-EXT' : { 261 | "ABORT" : "9.6.2.0670", 262 | 'ABORT"' : "9.6.2.0680", 263 | }, 264 | } 265 | 266 | # Human-friendlier names of wordsets 267 | ws = { 268 | 'CORE' : 'Core', 269 | 'CORE-EXT' : 'Core Extensions', 270 | 'DOUBLE' : 'Double-Number', 271 | 'DOUBLE-EXT' : 'Double-Number Extensions', 272 | 'EXCEPTION' : 'Exception', 273 | 'EXCEPTION-EXT' : 'Exception Extensions', 274 | 'FACILITY' : 'Facility', 275 | 'FACILITY-EXT' : 'Facility Extensions', 276 | 'FILE' : 'File Access', 277 | 'FILE-EXT' : 'File Access Extensions', 278 | 'FLOATING' : 'Floating-Point', 279 | 'FLOATING-EXT' : 'Floating-Point Extensions', 280 | 'MEMORY' : 'Memory-Allocation', 281 | 'SEARCH' : 'Search-Order', 282 | 'SEARCH-EXT' : 'Search-Order Extensions', 283 | 'STRING' : 'String', 284 | 'TOOLS' : 'Programming-Tools', 285 | 'TOOLS-EXT' : 'Programming-Tools Extensions', 286 | } 287 | 288 | # BLOCK "BLK" : "7.6.1.0790", 289 | # BLOCK "LOAD" : "7.6.1.1790", 290 | # BLOCK "BLOCK" : "7.6.1.0800", 291 | # BLOCK "FLUSH" : "7.6.1.1559", 292 | # BLOCK "BUFFER" : "7.6.1.0820", 293 | # BLOCK "UPDATE" : "7.6.1.2400", 294 | # BLOCK "EVALUATE" : "7.6.1.1360", 295 | # BLOCK "SAVE-BUFFERS" : "7.6.1.2180", 296 | # BLOCK-EXT "\" : "7.6.2.2535", 297 | # BLOCK-EXT "SCR" : "7.6.2.2190", 298 | # BLOCK-EXT "LIST" : "7.6.2.1770", 299 | # BLOCK-EXT "THRU" : "7.6.2.2280", 300 | # BLOCK-EXT "REFILL" : "7.6.2.2125", 301 | # BLOCK-EXT "EMPTY-BUFFERS" : "7.6.2.1330", 302 | # FILE "(" : "11.6.1.0080", 303 | # FILE "S"" : "11.6.1.2165", 304 | # FILE "BIN" : "11.6.1.0765", 305 | # FILE "R/O" : "11.6.1.2054", 306 | # FILE "R/W" : "11.6.1.2056", 307 | # FILE "W/O" : "11.6.1.2425", 308 | # FILE "INCLUDED" : "11.6.1.1718", 309 | # FILE "FILE-SIZE" : "11.6.1.1522", 310 | # FILE "OPEN-FILE" : "11.6.1.1970", 311 | # FILE "READ-FILE" : "11.6.1.2080", 312 | # FILE "READ-LINE" : "11.6.1.2090", 313 | # FILE "SOURCE-ID" : "11.6.1.2218", 314 | # FILE "CLOSE-FILE" : "11.6.1.0900", 315 | # FILE "WRITE-FILE" : "11.6.1.2480", 316 | # FILE "WRITE-LINE" : "11.6.1.2485", 317 | # FILE "CREATE-FILE" : "11.6.1.1010", 318 | # FILE "DELETE-FILE" : "11.6.1.1190", 319 | # FILE "RESIZE-FILE" : "11.6.1.2147", 320 | # FILE "INCLUDE-FILE" : "11.6.1.1717", 321 | # FILE "FILE-POSITION" : "11.6.1.1520", 322 | # FILE "REPOSITION-FILE" : "11.6.1.2142", 323 | # FILE-EXT "REFILL" : "11.6.2.2125", 324 | # FILE-EXT "FLUSH-FILE" : "11.6.2.1560", 325 | # FILE-EXT "FILE-STATUS" : "11.6.2.1524", 326 | # FILE-EXT "RENAME-FILE" : "11.6.2.2130", 327 | # FLOATING "F!" : "12.6.1.1400", 328 | # FLOATING "F*" : "12.6.1.1410", 329 | # FLOATING "F+" : "12.6.1.1420", 330 | # FLOATING "F-" : "12.6.1.1425", 331 | # FLOATING "F/" : "12.6.1.1430", 332 | # FLOATING "F<" : "12.6.1.1460", 333 | # FLOATING "F@" : "12.6.1.1472", 334 | # FLOATING "D>F" : "12.6.1.1130", 335 | # FLOATING "F0<" : "12.6.1.1440", 336 | # FLOATING "F0=" : "12.6.1.1450", 337 | # FLOATING "F>D" : "12.6.1.1470", 338 | # FLOATING "FDUP" : "12.6.1.1510", 339 | # FLOATING "FMAX" : "12.6.1.1562", 340 | # FLOATING "FMIN" : "12.6.1.1565", 341 | # FLOATING "FROT" : "12.6.1.1610", 342 | # FLOATING "FDROP" : "12.6.1.1500", 343 | # FLOATING "FLOOR" : "12.6.1.1558", 344 | # FLOATING "FOVER" : "12.6.1.1600", 345 | # FLOATING "FSWAP" : "12.6.1.1620", 346 | # FLOATING ">FLOAT" : "12.6.1.0558", 347 | # FLOATING "FALIGN" : "12.6.1.1479", 348 | # FLOATING "FDEPTH" : "12.6.1.1497", 349 | # FLOATING "FLOAT+" : "12.6.1.1555", 350 | # FLOATING "FLOATS" : "12.6.1.1556", 351 | # FLOATING "FROUND" : "12.6.1.1612", 352 | # FLOATING "FNEGATE" : "12.6.1.1567", 353 | # FLOATING "FALIGNED" : "12.6.1.1483", 354 | # FLOATING "FLITERAL" : "12.6.1.1552", 355 | # FLOATING "FCONSTANT" : "12.6.1.1492", 356 | # FLOATING "FVARIABLE" : "12.6.1.1630", 357 | # FLOATING "REPRESENT" : "12.6.1.2143", 358 | # FLOATING-EXT "F." : "12.6.2.1427", 359 | # FLOATING-EXT "F~" : "12.6.2.1640", 360 | # FLOATING-EXT "DF!" : "12.6.2.1203", 361 | # FLOATING-EXT "DF@" : "12.6.2.1204", 362 | # FLOATING-EXT "F**" : "12.6.2.1415", 363 | # FLOATING-EXT "FE." : "12.6.2.1513", 364 | # FLOATING-EXT "FLN" : "12.6.2.1553", 365 | # FLOATING-EXT "FS." : "12.6.2.1613", 366 | # FLOATING-EXT "SF!" : "12.6.2.2202", 367 | # FLOATING-EXT "SF@" : "12.6.2.2203", 368 | # FLOATING-EXT "FABS" : "12.6.2.1474", 369 | # FLOATING-EXT "FCOS" : "12.6.2.1493", 370 | # FLOATING-EXT "FEXP" : "12.6.2.1515", 371 | # FLOATING-EXT "FLOG" : "12.6.2.1557", 372 | # FLOATING-EXT "FSIN" : "12.6.2.1614", 373 | # FLOATING-EXT "FTAN" : "12.6.2.1625", 374 | # FLOATING-EXT "FACOS" : "12.6.2.1476", 375 | # FLOATING-EXT "FALOG" : "12.6.2.1484", 376 | # FLOATING-EXT "FASIN" : "12.6.2.1486", 377 | # FLOATING-EXT "FATAN" : "12.6.2.1488", 378 | # FLOATING-EXT "FCOSH" : "12.6.2.1494", 379 | # FLOATING-EXT "FLNP1" : "12.6.2.1554", 380 | # FLOATING-EXT "FSINH" : "12.6.2.1617", 381 | # FLOATING-EXT "FSQRT" : "12.6.2.1618", 382 | # FLOATING-EXT "FTANH" : "12.6.2.1626", 383 | # FLOATING-EXT "FACOSH" : "12.6.2.1477", 384 | # FLOATING-EXT "FASINH" : "12.6.2.1487", 385 | # FLOATING-EXT "FATAN2" : "12.6.2.1489", 386 | # FLOATING-EXT "FATANH" : "12.6.2.1491", 387 | # FLOATING-EXT "FEXPM1" : "12.6.2.1516", 388 | # FLOATING-EXT "DFALIGN" : "12.6.2.1205", 389 | # FLOATING-EXT "DFLOAT+" : "12.6.2.1208", 390 | # FLOATING-EXT "DFLOATS" : "12.6.2.1209", 391 | # FLOATING-EXT "FSINCOS" : "12.6.2.1616", 392 | # FLOATING-EXT "SFALIGN" : "12.6.2.2204", 393 | # FLOATING-EXT "SFLOAT+" : "12.6.2.2207", 394 | # FLOATING-EXT "SFLOATS" : "12.6.2.2208", 395 | # FLOATING-EXT "DFALIGNED" : "12.6.2.1207", 396 | # FLOATING-EXT "PRECISION" : "12.6.2.2035", 397 | # FLOATING-EXT "SFALIGNED" : "12.6.2.2206", 398 | # FLOATING-EXT "SET-PRECISION" : "12.6.2.2200", 399 | # LOCAL "TO" : "13.6.1.2295", 400 | # LOCAL "(LOCAL)" : "13.6.1.0086", 401 | # LOCAL-EXT "LOCALS|" : "13.6.2.1795", 402 | # MEMORY "FREE" : "14.6.1.1605", 403 | # MEMORY "RESIZE" : "14.6.1.2145", 404 | # MEMORY "ALLOCATE" : "14.6.1.0707", 405 | # SEARCH "FIND" : "16.6.1.1550", 406 | # SEARCH "WORDLIST" : "16.6.1.2460", 407 | # SEARCH "GET-ORDER" : "16.6.1.1647", 408 | # SEARCH "SET-ORDER" : "16.6.1.2197", 409 | # SEARCH "DEFINITIONS" : "16.6.1.1180", 410 | # SEARCH "GET-CURRENT" : "16.6.1.1643", 411 | # SEARCH "SET-CURRENT" : "16.6.1.2195", 412 | # SEARCH "FORTH-WORDLIST" : "16.6.1.1595", 413 | # SEARCH "SEARCH-WORDLIST" : "16.6.1.2192", 414 | # SEARCH-EXT "ALSO" : "16.6.2.0715", 415 | # SEARCH-EXT "ONLY" : "16.6.2.1965", 416 | # SEARCH-EXT "FORTH" : "16.6.2.1590", 417 | # SEARCH-EXT "ORDER" : "16.6.2.1985", 418 | # SEARCH-EXT "PREVIOUS" : "16.6.2.2037", 419 | -------------------------------------------------------------------------------- /shell/rath.el: -------------------------------------------------------------------------------- 1 | ;;; rath --- emacs <-> rath communication 2 | ;;; Code: 3 | 4 | (defun send-string (string) 5 | (let* ((size (length string)) 6 | (send (concat (byte-to-string size) 7 | string))) 8 | (process-send-string process send))) 9 | 10 | (defun region-bytes (start end) 11 | "Return the number of bytes used by the region." 12 | (interactive "r") 13 | (message "Region has %d bytes" 14 | (- (bufferpos-to-filepos end 'exact) 15 | (bufferpos-to-filepos start 'exact)))) 16 | 17 | 18 | (setq process (make-serial-process :port "/dev/ttyUSB2" 19 | :speed 115200 20 | :flowcontrol 'hw 21 | :bytesize 8 22 | )) 23 | 24 | (dotimes (i 500) 25 | (send-string "The rain in spain falls mainly on the plain. The rain in spain falls mainly on the plain. The rain in spain falls mainly on the plain. The rain in spain falls mainly on the plain. The rain in spain falls mainly on the plain. ") 26 | (usleep 100)) 27 | 28 | (dotimes (i 2) 29 | (send-string "T")) 30 | ; (usleep 1000)) 31 | 32 | 33 | (length "bla") 34 | 35 | (setq cont 1) 36 | 37 | (dolist (char (append "The rain in spain falls mainly on the plain" nil)) 38 | (process-send-string process char)) 39 | 40 | (dotimes (i 500) 41 | (mapcar (lambda (c) 42 | (process-send-string process (char-to-string c))) 43 | "The rain in spain falls mainly on the plain. ") 44 | (process-send-string process 45 | (concat "The rain in Spain falls mainly on the end. ")) 46 | 47 | (length "bla") 48 | 49 | (process-send-string process "The rain in spain falls mainly on the plain.\n") 50 | 51 | 52 | 53 | (while 0 54 | (process-send-string process "A") 55 | (process-send-string process "B")) 56 | 57 | 58 | 59 | 60 | 61 | ;;; Commentary: 62 | ;; rath is good and sweet 63 | (require 'term) 64 | 65 | (defun replace-all (string to-find to-replace) 66 | "A replace-all fn." 67 | (let ((index (cl-search to-find string)) 68 | (pos 0) 69 | (result "")) 70 | (while index 71 | (setq result (concat result 72 | (substring string pos index) 73 | to-replace) 74 | pos (+ index (length to-find)) 75 | index (cl-search to-find string :start2 pos))) 76 | (concat result (substring string pos)))) 77 | 78 | (defun rath-serial-process-filter (process output) 79 | "Replace LF in output string with CR+LF." 80 | (term-emulate-terminal process 81 | (replace-all output 82 | (byte-to-string ?\n) 83 | (string ?\r ?\n)))) 84 | 85 | (defun rath-term (port) 86 | "Basically duplicate SERIAL-TERM from term.el but with process 87 | filtering to translate LF to CR+LF." 88 | (interactive (list (serial-read-name))) 89 | (serial-supported-or-barf) 90 | (let* ((process (make-serial-process 91 | :port port 92 | :speed 115200 93 | ; :bytesize 8 94 | ; :parity nil 95 | ; :stopbits 1 96 | :flowcontrol 'hw 97 | ; :coding 'raw-text-unix 98 | ; :noquery t 99 | :name (format "rath:%s" port) 100 | ; :filter 'rath-serial-process-filter 101 | :sentinel 'term-sentinel 102 | )) 103 | (buffer (process-buffer process))) 104 | (with-current-buffer buffer 105 | (term-mode) 106 | (term-line-mode) 107 | (goto-char (point-max)) 108 | (set-marker (process-mark process) (point))) 109 | (switch-to-buffer buffer) 110 | buffer)) 111 | 112 | 113 | 114 | (provide 'rath) 115 | ;;; rath.el ends here 116 | 117 | 118 | -------------------------------------------------------------------------------- /source/PF.s: -------------------------------------------------------------------------------- 1 | # PandaForth by Torlus (c) 2005 2 | # A 32-bit DTC Forth for ARM, based on 3 | # Bradford J. Rodriguez's CamelForth. 4 | # See the original copyright notice below. 5 | # Some hi-level Forth definitions come from 6 | # other well-known implementations, or articles. 7 | # =============================================== 8 | # CamelForth for the Zilog Z80 9 | # (c) 1994 Bradford J. Rodriguez 10 | # Permission is granted to freely copy, modify, 11 | # and distribute this program for personal or 12 | # educational use. Commercial inquiries should 13 | # be directed to the author at 221 King St. E., 14 | # #32, Hamilton, Ontario L8N 1B5 Canada 15 | 16 | .section .iwram,"ax",%progbits 17 | 18 | .global boot 19 | 20 | .extern service 21 | 22 | .arm 23 | .align 24 | 25 | .set link_0, 0 26 | 27 | # ip = IP 28 | # sp = PSP 29 | # fp = RSP 30 | # r0 = W 31 | # r1 = TOS 32 | # r2 = UP 33 | # r3 used for DOES> 34 | # r10 = reserved (info buffer) 35 | 36 | .macro codeh label, length, name, prev 37 | .align 38 | .word link_\prev 39 | .word 0 40 | link_\label: 41 | # a "16-bit chars" version could be done this way 42 | # .hword \length 43 | # .irpc p,"\name" 44 | # .byte 0 45 | # .ascii "\p" 46 | # .endr 47 | .byte \length 48 | .ascii "\name" 49 | .align 50 | \label: 51 | .endm 52 | 53 | .macro head label, length, name, action, prev 54 | .align 55 | .word link_\prev 56 | .word 0 57 | link_\label: 58 | # a "16-bit chars" version could be done this way 59 | # .hword \length 60 | # .irpc p,"\name" 61 | # .byte 0 62 | # .ascii "\p" 63 | # .endr 64 | .byte \length 65 | .ascii "\name" 66 | .align 67 | \label: 68 | bl \action 69 | .endm 70 | 71 | .macro immed label, length, name, action, prev 72 | .align 73 | .word link_\prev 74 | .word 1 75 | link_\label: 76 | # a "16-bit chars" version could be done this way 77 | # .hword \length 78 | # .irpc p,"\name" 79 | # .byte 0 80 | # .ascii "\p" 81 | # .endr 82 | .byte \length 83 | .ascii "\name" 84 | .align 85 | \label: 86 | bl \action 87 | .endm 88 | 89 | .macro next 90 | ldr r0, [ip], #4 91 | add lr, pc, #4 92 | bx r0 93 | .endm 94 | 95 | boot: 96 | b reset 97 | 98 | .string "CODE" 99 | .align 100 | 101 | reset: 102 | sub ip, pc, #4 /* get the address of reset */ 103 | mov r10, r0 /* info buffer */ 104 | 105 | /* info buffer */ 106 | /* $+0 : ps_area_end */ 107 | /* $+4 : rs_area_end */ 108 | /* $+8 : user_area */ 109 | /* $+12 : pad_area */ 110 | 111 | ldr sp, [r10] 112 | ldr fp, [r10, #4] 113 | ldr r2, [r10, #8] 114 | 115 | bl cold 116 | 117 | # INTERPRETER LOGIC ============================= 118 | # See also "defining words" at end of this file 119 | 120 | #C EXIT -- exit a colon definition 121 | codeh exit,4,"exit",0 122 | ldr ip, [fp], #4 /* pop old IP from ret stk */ 123 | next 124 | 125 | #Z lit -- x fetch inline literal to stack 126 | # This is the primtive compiled by LITERAL. 127 | codeh lit,3,"lit",exit 128 | str r1, [sp, #-4]! /* push old TOS */ 129 | ldr r1, [ip], #4 /* fetch cell at IP to TOS, advancing IP */ 130 | next 131 | 132 | #C EXECUTE i*x xt -- j*x execute Forth word 133 | #C at 'xt' 134 | codeh execute,7,"execute",lit 135 | mov r0, r1 /* address of word -> HL */ 136 | ldr r1, [sp], #4 /* pop new TOS */ 137 | 138 | /*mov r1, r0 139 | mov r0, #0 140 | bl service*/ 141 | 142 | /*add pc, lr, #4*/ 143 | bx r0 144 | 145 | # DEFINING WORDS ================================ 146 | 147 | # ENTER, a.k.a. DOCOLON, entered by CALL ENTER 148 | # to enter a new high-level thread (colon def'n.) 149 | # (internal code fragment, not a Forth word) 150 | # N.B.: DOCOLON must be defined before any 151 | # appearance of 'docolon' in a 'word' macro! 152 | .type docolon, STT_FUNC 153 | docolon: 154 | enter: 155 | str ip, [fp, #-4]! /* push old IP on ret stack */ 156 | mov ip, lr /* param field adrs -> IP */ 157 | next 158 | 159 | #C VARIABLE -- define a Forth variable 160 | # CREATE 1 CELLS ALLOT ; 161 | # Action of RAM variable is identical to CREATE, 162 | # so we don't need a DOES> clause to change it. 163 | head variable,8,"variable",docolon,execute 164 | .word create 165 | .word lit,1,cells,allot 166 | /*.word here,lit,0,bdos*/ 167 | .word exit 168 | 169 | # DOVAR, code action of VARIABLE, entered by CALL 170 | # DOCREATE, code action of newly created words 171 | .type dovar, STT_FUNC 172 | docreate: 173 | dovar: /* -- a-addr */ 174 | str r1, [sp, #-4]! /* push old TOS */ 175 | mov r1, lr /* pfa = variables adrs -> TOS */ 176 | next 177 | 178 | #C CONSTANT n -- define a Forth constant 179 | # CREATE , DOES> (machine code fragment) 180 | .type docon, STT_FUNC 181 | head constant,8,"constant",docolon,variable 182 | .word create,comma,xdoes 183 | # DOCON, code action of CONSTANT, 184 | # entered by CALL DOCON 185 | docon: /* -- x */ 186 | str r1, [sp, #-4]! /* push old TOS */ 187 | ldr r1, [lr] /* fetch contents of parameter field -> TOS */ 188 | next 189 | 190 | #Z USER n -- define user variable 'n' 191 | # CREATE , DOES> (machine code fragment) 192 | head user,4,"user",docolon,constant 193 | .word create,comma,xdoes 194 | # douser, code action of user, 195 | # entered by call douser 196 | douser: /* -- a-addr */ 197 | str r1, [sp, #-4]! /* push old TOS */ 198 | ldr r1, [lr] /* fetch contents of parameter field -> TOS */ 199 | add r1, r1, r2 /* and add offset */ 200 | next 201 | 202 | # DODOES, code action of DOES> clause 203 | # entered by CALL fragment 204 | # parameter field 205 | # ... 206 | # fragment: CALL DODOES 207 | # high-level thread 208 | # Enters high-level thread with address of 209 | # parameter field on top of stack. 210 | # (internal code fragment, not a Forth word) 211 | dodoes: /* -- a-addr */ 212 | /* ######################################################### */ 213 | /* DOES> will need to do the following : */ 214 | /* - compile (DOES>) */ 215 | /* - compile an instruction like "mov r3, lr" */ 216 | /* - do ,CF i.e make a "bl ..." */ 217 | /* This is necessary, as we need the "first lr" for the PFA */ 218 | /* and the "second lr" for the IP */ 219 | /* The action of (DOES>) remains the same, i.e compile a */ 220 | /* "bl ..." pointing to the address of our "mov r3, lr" */ 221 | /* ######################################################### */ 222 | str ip, [fp, #-4]! /* push old IP on ret stack */ 223 | mov ip, lr /* adrs of new thread -> IP */ 224 | str r1, [sp, #-4]! /* push old TOS */ 225 | mov r1, r3 226 | next 227 | 228 | #Z BDOS de c -- a call CP/M BDOS 229 | codeh bdos,4,"bdos",user 230 | mov r0, r1 /* TOS = first parameter */ 231 | ldr r1, [sp], #4 /* pop new TOS, into second parameter */ 232 | stmfd sp!, {r2-r3,r10,fp,ip,lr} 233 | /* TODO System Interface function, most likely to be in C */ 234 | bl service 235 | ldmfd sp!, {r2-r3,r10,fp,ip,lr} 236 | /* Return value in r0, so we put in into TOS */ 237 | mov r1, r0 238 | next 239 | #C EMIT c -- output character to console 240 | # 6 BDOS DROP ; 241 | # warning: if c=0ffh, will read one keypress 242 | head emit,4,"emit",docolon,bdos 243 | .word lit,0x06,bdos,drop,exit 244 | 245 | #Z SAVEKEY -- addr temporary storage for KEY? 246 | head savekey,7,"savekey",dovar,emit 247 | .word 0 248 | 249 | #X KEY? -- f return true if char waiting 250 | #_ 0FF 6 BDOS DUP SAVEKEY C! rtns 0 or key 251 | # must use BDOS function 6 to work with KEY 252 | head querykey,4,"key?",docolon,savekey 253 | .word lit,0xff,lit,0x06,bdos 254 | .word dup,savekey,cstore,exit 255 | 256 | #C KEY -- c get character from keyboard 257 | # BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT 258 | # SAVEKEY C@ 0 SAVEKEY C! ; 259 | # must use CP/M direct console I/O to avoid echo 260 | # (BDOS function 6, contained within KEY?) 261 | head key,3,"key",docolon,querykey 262 | key1: .word savekey,cfetch,zeroequal,qbranch,key2 263 | .word querykey,drop,branch,key1 264 | key2: .word savekey,cfetch,lit,0,savekey,cstore 265 | .word exit 266 | 267 | #X BYE i*x -- return to CP/M 268 | codeh bye,3,"bye",key 269 | b reset 270 | 271 | # STACK OPERATIONS ============================== 272 | 273 | #C DUP x -- x x duplicate top of stack 274 | codeh dup,3,"dup",bye 275 | str r1, [sp, #-4]! /* push TOS */ 276 | next 277 | 278 | #C ?DUP x -- 0 | x x DUP if nonzero 279 | codeh qdup,4,"?dup",dup 280 | cmp r1, #0 281 | strne r1, [sp, #-4]! /* push TOS */ 282 | next 283 | 284 | #C DROP x -- drop top of stack 285 | codeh drop,4,"drop",qdup 286 | ldr r1, [sp], #4 /* pop new TOS */ 287 | next 288 | 289 | #C SWAP x1 x2 -- x2 x1 swap top two items 290 | codeh swap,4,"swap",drop 291 | ldr r0, [sp] 292 | str r1, [sp] 293 | mov r1, r0 294 | next 295 | 296 | #C OVER x1 x2 -- x1 x2 x1 per stack diagram 297 | codeh over,4,"over",swap 298 | str r1, [sp, #-4]! /* push TOS */ 299 | ldr r1, [sp, #4] /* get new TOS */ 300 | next 301 | 302 | #C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram 303 | codeh rot,3,"rot",over 304 | ldr r4, [sp] /* get x2 */ 305 | str r1, [sp] /* x1 x3 x3 */ 306 | ldr r1, [sp, #4] /* x1 x3 x1 */ 307 | str r4, [sp, #4] /* x2 x3 x1 */ 308 | next 309 | 310 | #X NIP x1 x2 -- x2 per stack diagram 311 | head nip,3,"nip",docolon,rot 312 | .word swap,drop,exit 313 | 314 | #X TUCK x1 x2 -- x2 x1 x2 per stack diagram 315 | head tuck,4,"tuck",docolon,nip 316 | .word swap,over,exit 317 | 318 | #C >R x -- R: -- x push to return stack 319 | codeh tor,2,">r",tuck 320 | str r1, [fp, #-4]! /* push TOS on return stack */ 321 | ldr r1, [sp], #4 /* pop new TOS */ 322 | next 323 | 324 | #C R> -- x R: x -- pop from return stack 325 | codeh rfrom,2,"r>",tor 326 | str r1, [sp, #-4]! /* push TOS */ 327 | ldr r1, [fp], #4 /* pop new TOS from return stack */ 328 | next 329 | 330 | #C R@ -- x R: x -- x fetch from rtn stk 331 | codeh rfetch,2,"r@",rfrom 332 | str r1, [sp, #-4]! /* push TOS */ 333 | ldr r1, [fp] /* get new TOS from return stack */ 334 | next 335 | 336 | #Z SP@ -- a-addr get data stack pointer 337 | codeh spfetch,3,"sp@",rfetch 338 | str r1, [sp, #-4]! /* push TOS */ 339 | mov r1, sp 340 | next 341 | 342 | #Z SP! a-addr -- set data stack pointer 343 | codeh spstore,3,"sp!",spfetch 344 | mov sp, r1 345 | ldr r1, [sp], #4 /* pop new TOS */ 346 | next 347 | 348 | #Z RP@ -- a-addr get return stack pointer 349 | codeh rpfetch,3,"rp@",spstore 350 | str r1, [sp, #-4]! /* push TOS */ 351 | mov r1, fp 352 | next 353 | 354 | #Z RP! a-addr -- set return stack pointer 355 | codeh rpstore,3,"rp!",rpfetch 356 | mov fp, r1 357 | ldr r1, [sp], #4 /* pop new TOS */ 358 | next 359 | 360 | # MEMORY AND I/O OPERATIONS ===================== 361 | 362 | #C ! x a-addr -- store cell in memory 363 | codeh store,1,"!",rpstore 364 | ldr r4, [sp], #4 /* read value and update sp */ 365 | str r4, [r1] 366 | ldr r1, [sp], #4 /* pop new TOS */ 367 | next 368 | 369 | #Z H! half h-addr -- store half in memory 370 | codeh hstore,2,"h!",store 371 | ldr r4, [sp], #4 /* read value and update sp */ 372 | strh r4, [r1] 373 | ldr r1, [sp], #4 /* pop new TOS */ 374 | next 375 | 376 | #C C! char c-addr -- store char in memory 377 | codeh cstore,2,"c!",hstore 378 | ldr r4, [sp], #4 /* read value and update sp */ 379 | strb r4, [r1] 380 | ldr r1, [sp], #4 /* pop new TOS */ 381 | next 382 | 383 | #Z CH! char cv-addr -- store char in non-byte addressable memory 384 | codeh chstore,3,"ch!",cstore 385 | ldr r4, [sp], #4 /* read value and update sp */ 386 | and r4, r4, #0xff 387 | ands r5, r1, #1 388 | subne r1, r1, #1 /* get halfword-aligned address */ 389 | ldrh r6, [r1] /* fetch the halfword */ 390 | andeq r6, r6, #0xff00 /* mask the corresponding byte */ 391 | movne r4, r4, lsl #8 392 | andne r6, r6, #0x00ff 393 | orr r6, r6, r4 394 | strh r6, [r1] /* store the updated halfword */ 395 | ldr r1, [sp], #4 /* pop new TOS */ 396 | next 397 | 398 | #C @ a-addr -- x fetch cell from memory 399 | codeh fetch,1,"@",chstore 400 | ldr r1, [r1] 401 | next 402 | 403 | #Z H@ h-addr -- x fetch half from memory 404 | codeh hfetch,2,"h@",fetch 405 | ldrh r1, [r1] 406 | next 407 | 408 | #C C@ c-addr -- char fetch char from memory 409 | codeh cfetch,2,"c@",hfetch 410 | ldrb r1, [r1] 411 | next 412 | 413 | #Z CH@ c-addr -- char fetch char from non-byte addressable memory 414 | # so OAM, palette ram, vram, gamepak flash 415 | codeh chfetch,3,"ch@",cfetch 416 | ands r5, r1, #1 417 | subne r1, r1, #1 /* get halfword-aligned address */ 418 | ldrh r6, [r1] /* fetch the halfword */ 419 | movne r6, r6, lsr #8 /* mask the corresponding byte */ 420 | andeq r6, r6, #0x00ff 421 | mov r1, r6 /* update TOS */ 422 | next 423 | 424 | # ARITHMETIC AND LOGICAL OPERATIONS ============= 425 | 426 | #C + n1/u1 n2/u2 -- n3/u3 add n1+n2 427 | codeh plus,1,"+",chfetch 428 | ldr r0, [sp], #4 /* read value and update sp */ 429 | add r1, r0, r1 /* result in TOS */ 430 | next 431 | 432 | #X M+ d n -- d add single to double 433 | codeh mplus,2,"m+",plus 434 | ldr r4, [sp], #4 /* read HI and update sp */ 435 | ldr r5, [sp] /* read LO */ 436 | adds r5, r5, r1 437 | addcs r4, r4, #1 438 | mov r1, r4 439 | str r5, [sp] /* HI+c in TOS, LO+n to stack */ 440 | next 441 | 442 | #C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2 443 | codeh minus,1,"-",mplus 444 | ldr r0, [sp], #4 /* read value and update sp */ 445 | sub r1, r0, r1 /* result in TOS */ 446 | next 447 | 448 | #C AND x1 x2 -- x3 logical AND 449 | codeh and,3,"and",minus 450 | ldr r0, [sp], #4 /* read value and update sp */ 451 | and r1, r0, r1 /* result in TOS */ 452 | next 453 | 454 | #C OR x1 x2 -- x3 logical OR 455 | codeh or,2,"or",and 456 | ldr r0, [sp], #4 /* read value and update sp */ 457 | orr r1, r0, r1 /* result in TOS */ 458 | next 459 | 460 | #C XOR x1 x2 -- x3 logical XOR 461 | codeh xor,3,"xor",or 462 | ldr r0, [sp], #4 /* read value and update sp */ 463 | eor r1, r0, r1 /* result in TOS */ 464 | next 465 | 466 | #C INVERT x1 -- x2 bitwise inversion 467 | codeh invert,6,"invert",xor 468 | mvn r1, r1 469 | next 470 | 471 | #C NEGATE x1 -- x2 two's complement 472 | codeh negate,6,"negate",invert 473 | rsb r1, r1, #0 474 | next 475 | 476 | #C 1+ n1/u1 -- n2/u2 add 1 to TOS 477 | codeh oneplus,2,"1+",negate 478 | add r1, r1, #1 479 | next 480 | 481 | #C 1- n1/u1 -- n2/u2 subtract 1 from TOS 482 | codeh oneminus,2,"1-",oneplus 483 | sub r1, r1, #1 484 | next 485 | 486 | #C 2* x1 -- x2 arithmetic left shift 487 | codeh twostar,2,"2*",oneminus 488 | mov r1, r1, asl #1 489 | next 490 | 491 | #C 2/ x1 -- x2 arithmetic right shift 492 | codeh twoslash,2,"2/",twostar 493 | mov r1, r1, asr #1 494 | next 495 | 496 | #C LSHIFT x1 u -- x2 logical L shift u places 497 | codeh lshift,6,"lshift",twoslash 498 | ldr r0, [sp], #4 /* read value and update sp */ 499 | mov r1, r0, lsl r1 500 | next 501 | 502 | #C RSHIFT x1 u -- x2 logical R shift u places 503 | codeh rshift,6,"rshift",lshift 504 | ldr r0, [sp], #4 /* read value and update sp */ 505 | mov r1, r0, lsr r1 506 | next 507 | 508 | #C +! n/u a-addr -- add cell to memory 509 | codeh plusstore,2,"+!",rshift 510 | ldr r0, [sp], #4 /* read value and update sp */ 511 | ldr r4, [r1] 512 | add r4, r4, r0 513 | str r4, [r1] 514 | ldr r1, [sp], #4 /* pop new TOS */ 515 | next 516 | 517 | # COMPARISON OPERATIONS ========================= 518 | 519 | #C 0= n/u -- flag return true if TOS=0 520 | codeh zeroequal,2,"0=",plusstore 521 | cmp r1, #0 522 | mvneq r1, #0 523 | movne r1, #0 524 | next 525 | 526 | #C 0< n -- flag true if TOS negative 527 | codeh zeroless,2,"0<",zeroequal 528 | cmp r1, #0 529 | mvnlt r1, #0 530 | movge r1, #0 531 | next 532 | 533 | #C = x1 x2 -- flag test x1=x2 534 | codeh equal,1,"=",zeroless 535 | ldr r0, [sp], #4 /* read value and update sp */ 536 | cmp r0, r1 537 | mvneq r1, #0 538 | movne r1, #0 539 | next 540 | 541 | #X <> x1 x2 -- flag test not eq (not ANSI) 542 | codeh notequal,2,"<>",equal 543 | ldr r0, [sp], #4 /* read value and update sp */ 544 | cmp r1, r0 545 | mvnne r1, #0 546 | moveq r1, #0 547 | next 548 | 549 | #C < n1 n2 -- flag test n1 n1 n2 -- flag test n1>n2, signed 558 | codeh greater,1,">",less 559 | ldr r0, [sp], #4 /* read value and update sp */ 560 | cmp r0, r1 561 | mvngt r1, #0 562 | movle r1, #0 563 | next 564 | 565 | #C U< u1 u2 -- flag test u1 u1 u2 -- flag u1>u2 unsgd (not ANSI) 574 | codeh ugreater,2,"u>",uless 575 | ldr r0, [sp], #4 /* read value and update sp */ 576 | cmp r0, r1 577 | mvnhi r1, #0 578 | movls r1, #0 579 | next 580 | 581 | # LOOP AND BRANCH OPERATIONS ==================== 582 | 583 | #Z branch -- branch always 584 | codeh branch,6,"branch",ugreater 585 | ldr ip, [ip] 586 | next 587 | 588 | #Z ?branch x -- branch if TOS zero 589 | codeh qbranch,7,"?branch",branch 590 | cmp r1, #0 591 | addne ip, ip, #4 /* skip inline value */ 592 | ldreq ip, [ip] 593 | ldr r1, [sp], #4 /* pop new TOS */ 594 | next 595 | 596 | #Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2 597 | #Z run-time code for DO 598 | # '83 and ANSI standard loops terminate when the 599 | # boundary of limit-1 and limit is crossed, in 600 | # either direction. This can be conveniently 601 | # implemented by making the limit 8000h, so that 602 | # arithmetic overflow logic can detect crossing. 603 | # I learned this trick from Laxen & Perry F83. 604 | # fudge factor = 8000h-limit, to be added to 605 | # the start value. 606 | 607 | #_ 32-bit version 608 | codeh xdo,4,"(do)",qbranch 609 | ldr r0, [sp], #4 /* read "limit" and update sp */ 610 | rsb r4, r0, #0x80000000 611 | str r4, [fp, #-4]! /* push fudge-factor to RS */ 612 | add r4, r4, r1 613 | str r4, [fp, #-4]! /* push index to RS */ 614 | ldr r1, [sp], #4 /* pop new TOS */ 615 | next 616 | 617 | #Z (loop) R: sys1 sys2 -- | sys1 sys2 618 | #Z run-time code for LOOP 619 | # Add 1 to the loop index. If loop terminates, 620 | # clean up the return stack and skip the branch. 621 | # Else take the inline branch. Note that LOOP 622 | # terminates when index=8000h. 623 | codeh xloop,6,"(loop)",xdo 624 | ldr r0, [fp] /* get item on top of RS (index) */ 625 | adds r0, r0, #1 626 | bvs loopterm /* overflow test */ 627 | str r0, [fp] /* update index on top of RS */ 628 | ldr ip, [ip] /* take the inline branch */ 629 | next 630 | loopterm: /* end of the loop */ 631 | add fp, fp, #8 /* discard the loop info */ 632 | add ip, ip, #4 /* skip the inline branch */ 633 | next 634 | 635 | #Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2 636 | #Z run-time code for +LOOP 637 | # Add n to the loop index. If loop terminates, 638 | # clean up the return stack and skip the branch. 639 | # Else take the inline branch. 640 | codeh xplusloop,7,"(+loop)",xloop 641 | ldr r0, [fp] /* get item on top of RS (index) */ 642 | adds r0, r0, r1 643 | ldr r1, [sp], #4 /* pop new TOS */ 644 | bvs loopterm 645 | str r0, [fp] /* update index on top of RS */ 646 | ldr ip, [ip] /* take the inline branch */ 647 | next 648 | 649 | #C I -- n R: sys1 sys2 -- sys1 sys2 650 | #C get the innermost loop index 651 | codeh ii,1,"i",xplusloop 652 | str r1, [sp, #-4]! /* push TOS */ 653 | ldr r0, [fp] /* get item on top of RS (index) */ 654 | ldr r1, [fp, #4] /* get fudge-factor */ 655 | sub r1, r0, r1 /* true index in TOS */ 656 | next 657 | 658 | #C J -- n R: 4*sys -- 4*sys 659 | #C get the second loop index 660 | codeh jj,1,"j",ii 661 | str r1, [sp, #-4]! /* push TOS */ 662 | ldr r0, [fp, #8] /* get 2nd index from RS */ 663 | ldr r1, [fp, #12] /* get 2nd fudge-factor */ 664 | sub r1, r0, r1 /* true index in TOS */ 665 | next 666 | 667 | #C UNLOOP -- R: sys1 sys2 -- drop loop parms 668 | codeh unloop,6,"unloop",jj 669 | add fp, fp, #8 670 | next 671 | 672 | # MULTIPLY AND DIVIDE =========================== 673 | 674 | #C UM* u1 u2 -- ud unsigned 16x16->32 mult. 675 | # Here is eForth hi-level version : 676 | # UM* ( u u -- ud ) ( 6.1.2360 )( 0xD4 ) 677 | # D# 0 SWAP [ #BITS ] LITERAL 678 | # BEGIN DUP 679 | # WHILE >R DUP UM+ >R >R DUP UM+ R> + R> 680 | # IF >R OVER UM+ R> + THEN R> D# 1 - 681 | # REPEAT DROP >R NIP R> ; 682 | 683 | # let's define UM+ first ( u u -- u cy ) 684 | codeh umplus,3,"um+",unloop 685 | ldr r0, [sp] /* read value */ 686 | adds r0, r0, r1 687 | movcs r1, #1 688 | movcc r1, #0 689 | str r0, [sp] 690 | next 691 | 692 | head umstar,3,"um*",docolon,umplus 693 | .word lit,0,swap,lit,32 694 | umloop: .word dup,qbranch,umend 695 | .word tor,dup,umplus,tor,tor 696 | .word dup,umplus,rfrom,plus,rfrom 697 | .word qbranch,umnext 698 | .word tor,over,umplus,rfrom,plus 699 | umnext: .word rfrom,oneminus 700 | .word branch,umloop 701 | umend: .word drop,tor,nip,rfrom,exit 702 | 703 | #C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16 704 | # eForth hi-level version... too lazy to rewrite it in assembly :) 705 | #_ 32-bit version 706 | head umslashmod,6,"um/mod",docolon,umstar 707 | .word twodup,uless,qbranch,ummend 708 | .word negate,lit,32 709 | ummbeg: .word dup,qbranch,ummrep 710 | .word tor,tor,dup,umplus 711 | .word tor,tor,dup,umplus 712 | .word rfrom,plus 713 | .word dup,rfrom,rfetch,swap,tor,umplus,rfrom,or 714 | .word qbranch,ummels 715 | .word tor,drop,oneplus,rfrom 716 | .word branch,ummthn 717 | ummels: .word drop 718 | ummthn: .word rfrom,rfrom,oneminus 719 | .word branch,ummbeg 720 | ummrep: .word twodrop,swap,exit 721 | ummend: .word drop,twodrop,lit,-1,dup,exit 722 | 723 | # BLOCK AND STRING OPERATIONS =================== 724 | 725 | #C FILL c-addr u char -- fill memory with char 726 | # eForth hi-level version... 727 | # needs BOUNDS ( a n -- a+n a ) ( 0xAC ) OVER + SWAP ; 728 | # uses chstore, so could be better 729 | head bounds,6,"bounds",docolon,umslashmod 730 | .word over,plus,swap,exit 731 | 732 | head fill,4,"fill",docolon,bounds 733 | .word tor,chars,bounds 734 | filbeg: .word twodup,xor 735 | .word qbranch,filrep 736 | .word rfetch,over,chstore,charplus 737 | .word branch,filbeg 738 | filrep: .word rfrom,drop,twodrop,exit 739 | 740 | #z WFILL addr u w -- fill memory with word 741 | codeh wfill,5,"wfill",fill 742 | ldr r5, [sp], #4 /* u */ 743 | ldr r4, [sp], #4 /* addr */ 744 | cmp r5, #0 745 | ble wfill2 746 | wfill1: 747 | str r1, [r4], #4 748 | subs r5, r5, #4 749 | bgt wfill1 750 | wfill2: 751 | ldr r1, [sp], #4 /* pop new TOS */ 752 | next 753 | 754 | #Z WMOVE a-addr1 a-addr2 u -- move word steps from bottom 755 | # hi-level version 756 | head wmove,5,"wmove",docolon,wfill 757 | .word over,plus,tor /* a-addr1 a-addr2 R: a-addr2+u */ 758 | wmbeg: .word dup,rfetch,xor 759 | .word qbranch,wmrep 760 | .word tor,dup,fetch,rfetch,store,cellplus,rfrom,cellplus 761 | .word branch,wmbeg 762 | wmrep: .word rfrom,drop,twodrop,exit 763 | 764 | #Z HMOVE h-addr1 h-addr2 u -- move halfword steps from bottom 765 | # hi-level version 766 | head hmove,5,"hmove",docolon,wmove 767 | .word over,plus,tor /* h-addr1 h-addr2 R: h-addr2+u */ 768 | hmbeg: .word dup,rfetch,xor 769 | .word qbranch,hmrep 770 | .word tor,dup,hfetch,rfetch,hstore,halfplus,rfrom,halfplus 771 | .word branch,hmbeg 772 | hmrep: .word rfrom,drop,twodrop,exit 773 | 774 | #X CMOVE c-addr1 c-addr2 u -- move char steps from bottom 775 | # hi-level version 776 | head cmove,5,"cmove",docolon,hmove 777 | .word over,plus,tor /* c-addr1 c-addr2 R: c-addr2+u */ 778 | cmbeg: .word dup,rfetch,xor 779 | .word qbranch,cmrep 780 | .word tor,dup,cfetch,rfetch,chstore,charplus,rfrom,charplus 781 | .word branch,cmbeg 782 | cmrep: .word rfrom,drop,twodrop,exit 783 | 784 | #X CMOVE> c-addr1 c-addr2 u -- move from top 785 | # hi-level version 786 | head cmoveup,6,"cmove>",docolon,cmove 787 | .word tor 788 | cmubeg: .word rfrom,dup 789 | .word qbranch,cmurep 790 | .word charminus,rfrom,over,rfetch,plus,cfetch,over,rfetch,plus,chstore 791 | .word branch,cmubeg 792 | cmurep: .word drop,twodrop,exit 793 | 794 | #Z SKIP c-addr u c -- c-addr' u' 795 | #Z skip matching chars 796 | # my own hi-level version 797 | head skip,4,"skip",docolon,cmoveup 798 | .word swap,tor 799 | skibeg: .word rfetch,qbranch,skiend /* c-addr c R: u */ 800 | .word over,cfetch,over,equal /* c-addr c f R: u */ 801 | .word qbranch,skiend 802 | .word swap,charplus,swap /* c-addr+1 c R: u */ 803 | .word rfrom,oneminus,tor /* c-addr+1 c R: u-1 */ 804 | .word branch,skibeg 805 | skiend: .word drop,rfrom,exit 806 | 807 | #Z SCAN c-addr u c -- c-addr' u' 808 | #Z find matching char 809 | # my own hi-level version 810 | # difference with SKIP lies in the loop test 811 | head scan,4,"scan",docolon,skip 812 | .word swap,tor 813 | scabeg: .word rfetch,qbranch,scaend /* c-addr c R: u */ 814 | .word over,cfetch,over,notequal /* c-addr c f R: u */ 815 | .word qbranch,scaend 816 | .word swap,charplus,swap /* c-addr+1 c R: u */ 817 | .word rfrom,oneminus,tor /* c-addr+1 c R: u-1 */ 818 | .word branch,scabeg 819 | scaend: .word drop,rfrom,exit 820 | 821 | #Z S= c-addr1 c-addr2 u -- n string compare 822 | #Z n<0: s10: s1>s2 823 | # my own hi-level version 824 | head sequal,2,"s=",docolon,scan 825 | .word tor 826 | seqbeg: .word rfetch,qbranch,seqmat /* c-addr1 c-addr2 R: u */ 827 | .word over,cfetch,over,cfetch,minus,dup /* c-addr1 c-addr2 c1-c2 c1-c2 R: u */ 828 | .word qbranch,seqaga /* c-addr1 c-addr2 c1-c2 R: u */ 829 | .word rfrom,drop,tor,twodrop,rfrom,exit /* mismatch */ 830 | seqaga: .word drop,charplus,swap,charplus,swap 831 | .word rfrom,oneminus,tor /* c-addr1+1 c-addr2+2 R: u-1 */ 832 | .word branch,seqbeg 833 | seqmat: .word twodrop,rfrom,exit /* u=0 */ 834 | 835 | .include "../source/PFD.asm" 836 | .include "../source/PFH.asm" 837 | 838 | # last word from PFH.asm is COLD 839 | 840 | # Example of resource inclusion 841 | # Notice the last parameter, which refer to the previous 842 | # first parameter of "head" macro (think about a linked list) 843 | # Notice also the definition of "lastword", 844 | # that must be defined as link_ 845 | 846 | .section .rom,"ax",%progbits 847 | 848 | head gfx_ball,8,"gfx_ball",dovar,cold 849 | .incbin "../assets/ball.raw" 850 | .align 851 | head pal_ball1,9,"pal_ball1",dovar,gfx_ball 852 | .incbin "../assets/pal1.pal" 853 | .align 854 | head pal_ball2,9,"pal_ball2",dovar,pal_ball1 855 | .incbin "../assets/pal2.pal" 856 | .align 857 | head pal_ball3,9,"pal_ball3",dovar,pal_ball2 858 | .incbin "../assets/pal3.pal" 859 | .align 860 | 861 | head snaggle_tiles,13,"snaggle-tiles",dovar,pal_ball3 862 | .incbin "snaggle.img.bin" 863 | .align 864 | head snaggle_pal,11,"snaggle-pal",dovar,snaggle_tiles 865 | .incbin "snaggle.pal.bin" 866 | .align 867 | 868 | head splash,6,"splash",dovar,snaggle_pal 869 | .incbin "splash.img.bin" 870 | .align 871 | head splash_len,10,"splash-len",docon,splash 872 | .word 76800 873 | 874 | head end,3,"end",dovar,splash_len 875 | .incbin "end.img.bin" 876 | .align 877 | head end_len,7,"end-len",docon,end 878 | .word 76800 879 | 880 | head apt_tiles,9,"apt-tiles",dovar,end_len 881 | .incbin "apartment-map.img.bin" 882 | .align 883 | head apt_tiles_len,13,"apt-tiles-len",docon,apt_tiles 884 | .word 15680 885 | 886 | head apt_pal,7,"apt-pal",dovar,apt_tiles_len 887 | .incbin "shared.pal.bin" 888 | .align 889 | head apt_pal_len,11,"apt-pal-len",docon,apt_pal 890 | .word 512 891 | 892 | head apt_map,7,"apt-map",dovar,apt_pal_len 893 | .incbin "apartment-map.map.bin" 894 | .align 895 | head apt_map_len,11,"apt-map-len",docon,apt_map 896 | .word 4096 897 | 898 | head phone_tiles,11,"phone-tiles",dovar,apt_map_len 899 | .incbin "phone.img.bin" 900 | .align 901 | head phone_len,9,"phone-len",docon,phone_tiles 902 | .word 8384 903 | 904 | head phone_map,9,"phone-map",dovar,phone_len 905 | .incbin "phone.map.bin" 906 | .align 907 | head phone_map_len,13,"phone-map-len",docon,phone_map 908 | .word 2048 909 | 910 | head font_tiles,10,"font-tiles",docon,phone_map_len 911 | .word gba_font 912 | .align 913 | head font_len,10,"font-len",docon,font_tiles 914 | .word 16384 915 | 916 | head beany_tiles,11,"beany-tiles",docon,font_len 917 | .word beany_sheetTiles 918 | head beany_pal,9,"beany-pal",docon,beany_tiles 919 | .word beany_sheetPal 920 | 921 | .section .ewram,"ax",%progbits 922 | 923 | head apt_toi,7,"apt-toi",dovar,beany_tiles 924 | .incbin "apt-toi.bin" 925 | .align 926 | 927 | .include "ass.asm" 928 | 929 | enddict: 930 | 931 | # Reserve some room for Forth 932 | .rept 16 933 | .space 1024 934 | .endr 935 | -------------------------------------------------------------------------------- /source/PFD.asm: -------------------------------------------------------------------------------- 1 | #C ALIGN -- align HERE 2 | codeh align,5,"align",sequal 3 | ldr r4, [r2, #16] /* DP will be at UP+16 */ 4 | ands r5, r4, #0x3 5 | andne r4, r4, #0xfffffffc 6 | addne r4, r4, #4 7 | str r4, [r2, #16] 8 | next 9 | 10 | #C ALIGNED addr -- a-addr align given addr 11 | codeh aligned,7,"aligned",align 12 | ands r5, r1, #0x3 13 | andne r1, r1, #0xfffffffc 14 | addne r1, r1, #4 15 | next 16 | 17 | #Z CELL -- n size of one cell 18 | head cell,4,"cell",docon,aligned 19 | .word 4 20 | 21 | #C CELL+ a-addr1 -- a-addr2 add cell size 22 | codeh cellplus,5,"cell+",cell 23 | add r1, r1, #4 24 | next 25 | 26 | #C CELLS n1 -- n2 cells->adrs units 27 | codeh cells,5,"cells",cellplus 28 | mov r1, r1, lsl #2 29 | next 30 | 31 | # half operations make working with certain GBA memory types 32 | # much more efficient 33 | #Z HALF+ h-addr1 -- h-addr2 add half size 34 | codeh halfplus,5,"half+",cells 35 | add r1, r1, #2 36 | next 37 | 38 | #Z HALF- h-addr1 -- h-addr2 sub half size 39 | codeh halfminus,5,"half-",halfplus 40 | sub r1, r1, #2 41 | next 42 | 43 | #Z HALVES n1 -- n2 chars->adrs units 44 | codeh halves,6,"halves",halfminus 45 | mov r1, r1, lsl #1 46 | next 47 | 48 | #C CHAR+ c-addr1 -- c-addr2 add char size 49 | codeh charplus,5,"char+",halves 50 | add r1, r1, #1 51 | next 52 | 53 | # Not defined in CamelForth, but used in some eForth words 54 | #C CHAR- c-addr1 -- c-addr2 sub char size 55 | codeh charminus,5,"char-",charplus 56 | sub r1, r1, #1 57 | next 58 | 59 | #C CHARS n1 -- n2 chars->adrs units 60 | codeh chars,5,"chars",charminus 61 | next 62 | 63 | #C >BODY xt -- a-addr adrs of param field 64 | #_ 3 + ; Z80 (3 byte CALL) 65 | # Here, 4 bytes 66 | head tobody,5,">body",docolon,chars 67 | .word lit,4,plus,exit 68 | 69 | #X COMPILE, xt -- append execution token 70 | codeh commaxt,8,"compile,",tobody 71 | b comma 72 | 73 | #Z !CF adrs cfa -- set code action of a word 74 | #_ 0CD OVER C! store 'CALL adrs' instr 75 | #_ 1+ ! ; Z80 VERSION 76 | # Needs testing... 77 | # Assembles "bl offset", bl = 0xEB, "offset" on 24bits, in 4-bytes units 78 | # when entering this CF, pc = cfa + 4 79 | # so the offset value is (addr-(cfa+4))>>2 80 | codeh storecf,3,"!cf",commaxt 81 | 82 | ldr r0, [sp], #4 /* read adrs and update sp */ 83 | 84 | sub r0, r0, r1 /* r0 = adrs-cfa */ 85 | mov r0, r0, asr #2 /* r0 = (adrs-(cfa+4))>>2 */ 86 | sub r0, r0, #2 /* r0 = adrs-cfa-4 */ 87 | and r0, r0, #0x00ffffff 88 | orr r0, r0, #0xeb000000 89 | 90 | str r0, [r1] 91 | 92 | ldr r1, [sp], #4 /* pop new TOS */ 93 | next 94 | 95 | #Z ,CF adrs -- append a code field 96 | # HERE !CF 3 ALLOT ; Z80 VERSION (3 bytes) 97 | #_ 4 bytes here 98 | head commacf,3,",cf",docolon,storecf 99 | .word here,storecf 100 | .word lit,4,allot 101 | .word exit 102 | 103 | #Z !COLON -- change code field to docolon 104 | #_ -3 ALLOT docolon-adrs ,CF ; 105 | # This should be used immediately after CREATE. 106 | # This is made a distinct word, because on an STC 107 | # Forth, colon definitions have no code field. 108 | #_ 4 bytes here 109 | head storcolon,6,"!colon",docolon,commacf 110 | .word lit,-4,allot 111 | .word lit,docolon,commacf,exit 112 | 113 | #Z ,EXIT -- append hi-level EXIT action 114 | # ['] EXIT ,XT ; 115 | # This is made a distinct word, because on an STC 116 | # Forth, it appends a RET instruction, not an xt. 117 | head cexit,5,",exit",docolon,storcolon 118 | .word lit,exit,commaxt,exit 119 | 120 | # CONTROL STRUCTURES ============================ 121 | # These words allow Forth control structure words 122 | # to be defined portably. 123 | 124 | #Z ,BRANCH xt -- append a branch instruction 125 | # xt is the branch operator to use, e.g. qbranch 126 | # or (loop). It does NOT append the destination 127 | # address. On the Z80 this is equivalent to ,XT. 128 | codeh commabranch,7,",branch",cexit 129 | b comma 130 | 131 | #Z ,DEST dest -- append a branch address 132 | # This appends the given destination address to 133 | # the branch instruction. On the Z80 this is ',' 134 | # ...other CPUs may use relative addressing. 135 | codeh commadest,5,",dest",commabranch 136 | b comma 137 | 138 | #Z !DEST dest adrs -- change a branch dest'n 139 | # Changes the destination address found at 'adrs' 140 | # to the given 'dest'. On the Z80 this is '!' 141 | # ...other CPUs may need relative addressing. 142 | codeh storedest,5,"!dest",commadest 143 | b store 144 | -------------------------------------------------------------------------------- /source/beany-sheet.s: -------------------------------------------------------------------------------- 1 | 2 | @{{BLOCK(beany_sheet) 3 | 4 | @======================================================================= 5 | @ 6 | @ beany_sheet, 16x16@4, 7 | @ Transparent color : 00,00,00 8 | @ + palette 16 entries, not compressed 9 | @ + 4 tiles Metatiled by 1x2 not compressed 10 | @ Total size: 32 + 128 = 160 11 | @ 12 | @ Time-stamp: 2021-02-02, 00:31:06 13 | @ Exported by Cearn's GBA Image Transmogrifier, v0.8.15 14 | @ ( http://www.coranac.com/projects/#grit ) 15 | @ 16 | @======================================================================= 17 | 18 | .section .rodata 19 | .align 2 20 | .global beany_sheetTiles @ 128 unsigned chars 21 | .hidden beany_sheetTiles 22 | beany_sheetTiles: 23 | .word 0x22222222,0x02666662,0x06536356,0x06666666,0x00651560,0x00666660,0x00066000,0x09999990 24 | .word 0x9AAAAAA9,0x9AA66AA9,0x99966999,0x0AAAAAA0,0x0DDDDDD0,0x05535530,0x05535530,0x00000000 25 | .word 0x22222222,0x02666662,0x06536356,0x06666666,0x60651560,0x90666660,0x90066000,0x99999990 26 | .word 0xAAAAAA99,0x0AAAAA99,0x0AAAAAA9,0x0AAAAAA9,0x0EEDDDD6,0x05535530,0x05535530,0x00000000 27 | 28 | .section .rodata 29 | .align 2 30 | .global beany_sheetPal @ 32 unsigned chars 31 | .hidden beany_sheetPal 32 | beany_sheetPal: 33 | .hword 0x0000,0x1884,0x1CA8,0x18EC,0x1D51,0x7FFF,0x329B,0x4F11 34 | .hword 0x1BDF,0x2B93,0x1AED,0x3646,0x1529,0x112A,0x1CE6,0x38E7 35 | 36 | @}}BLOCK(beany_sheet) 37 | -------------------------------------------------------------------------------- /source/cam80-12/CAMEL80.AZM: -------------------------------------------------------------------------------- 1 | ; Listing 2. 2 | ; =============================================== 3 | ; CamelForth for the Zilog Z80 4 | ; (c) 1994 Bradford J. Rodriguez 5 | ; Permission is granted to freely copy, modify, 6 | ; and distribute this program for personal or 7 | ; educational use. Commercial inquiries should 8 | ; be directed to the author at 221 King St. E., 9 | ; #32, Hamilton, Ontario L8N 1B5 Canada 10 | ; 11 | ; CAMEL80.AZM: Code Primitives 12 | ; Source code is for the Z80MR macro assembler. 13 | ; Forth words are documented as follows: 14 | ;x NAME stack -- stack description 15 | ; where x=C for ANS Forth Core words, X for ANS 16 | ; Extensions, Z for internal or private words. 17 | ; 18 | ; Direct-Threaded Forth model for Zilog Z80 19 | ; 16 bit cell, 8 bit char, 8 bit (byte) adrs unit 20 | ; Z80 BC = Forth TOS (top Param Stack item) 21 | ; HL = W working register 22 | ; DE = IP Interpreter Pointer 23 | ; SP = PSP Param Stack Pointer 24 | ; IX = RSP Return Stack Pointer 25 | ; IY = UP User area Pointer 26 | ; A, alternate register set = temporaries 27 | ; 28 | ; Revision history: 29 | ; 19 Aug 94 v1.0 30 | ; 25 Jan 95 v1.01 now using BDOS function 0Ah 31 | ; for interpreter input; TIB at 82h. 32 | ; 02 Mar 95 v1.02 changed ALIGN to ALIGNED in 33 | ; S" (S"); changed ,BRANCH to ,XT in DO. 34 | ; =============================================== 35 | ; Macros to define Forth headers 36 | ; HEAD label,length,name,action 37 | ; IMMED label,length,name,action 38 | ; label = assembler name for this word 39 | ; (special characters not allowed) 40 | ; length = length of name field 41 | ; name = Forth's name for this word 42 | ; action = code routine for this word, e.g. 43 | ; DOCOLON, or DOCODE for code words 44 | ; IMMED defines a header for an IMMEDIATE word. 45 | ; 46 | DOCODE EQU 0 ; flag to indicate CODE words 47 | link DEFL 0 ; link to previous Forth word 48 | 49 | head MACRO #label,#length,#name,#action 50 | DW link 51 | DB 0 52 | link DEFL $ 53 | DB #length,'#name' 54 | #label: 55 | IF .NOT.(#action=DOCODE) 56 | call #action 57 | ENDIF 58 | ENDM 59 | 60 | immed MACRO #label,#length,#name,#action 61 | DW link 62 | DB 1 63 | link DEFL $ 64 | DB #length,'#name' 65 | #label: 66 | IF .NOT.(#action=DOCODE) 67 | call #action 68 | ENDIF 69 | ENDM 70 | 71 | ; The NEXT macro (7 bytes) assembles the 'next' 72 | ; code in-line in every Z80 CamelForth CODE word. 73 | next MACRO 74 | ex de,hl 75 | ld e,(hl) 76 | inc hl 77 | ld d,(hl) 78 | inc hl 79 | ex de,hl 80 | jp (hl) 81 | ENDM 82 | 83 | ; NEXTHL is used when the IP is already in HL. 84 | nexthl MACRO 85 | ld e,(hl) 86 | inc hl 87 | ld d,(hl) 88 | inc hl 89 | ex de,hl 90 | jp (hl) 91 | ENDM 92 | 93 | ; RESET AND INTERRUPT VECTORS =================== 94 | ; ...are not used in the CP/M implementation 95 | ; Instead, we have the... 96 | 97 | ; CP/M ENTRY POINT 98 | org 100h 99 | reset: ld hl,(6h) ; BDOS address, rounded down 100 | ld l,0 ; = end of avail.mem (EM) 101 | dec h ; EM-100h 102 | ld sp,hl ; = top of param stack 103 | inc h ; EM 104 | push hl 105 | pop ix ; = top of return stack 106 | dec h ; EM-200h 107 | dec h 108 | push hl 109 | pop iy ; = bottom of user area 110 | ld de,1 ; do reset if COLD returns 111 | jp COLD ; enter top-level Forth word 112 | 113 | ; Memory map: 114 | ; 0080h Terminal Input Buffer, 128 bytes 115 | ; 0100h Forth kernel = start of CP/M TPA 116 | ; ? h Forth dictionary (user RAM) 117 | ; EM-200h User area, 128 bytes 118 | ; EM-180h Parameter stack, 128B, grows down 119 | ; EM-100h HOLD area, 40 bytes, grows down 120 | ; EM-0D8h PAD buffer, 88 bytes 121 | ; EM-80h Return stack, 128 B, grows down 122 | ; EM End of RAM = start of CP/M BDOS 123 | ; See also the definitions of U0, S0, and R0 124 | ; in the "system variables & constants" area. 125 | ; A task w/o terminal input requires 200h bytes. 126 | ; Double all except TIB and PAD for 32-bit CPUs. 127 | 128 | ; INTERPRETER LOGIC ============================= 129 | ; See also "defining words" at end of this file 130 | 131 | ;C EXIT -- exit a colon definition 132 | head EXIT,4,EXIT,docode 133 | ld e,(ix+0) ; pop old IP from ret stk 134 | inc ix 135 | ld d,(ix+0) 136 | inc ix 137 | next 138 | 139 | ;Z lit -- x fetch inline literal to stack 140 | ; This is the primtive compiled by LITERAL. 141 | head lit,3,lit,docode 142 | push bc ; push old TOS 143 | ld a,(de) ; fetch cell at IP to TOS, 144 | ld c,a ; advancing IP 145 | inc de 146 | ld a,(de) 147 | ld b,a 148 | inc de 149 | next 150 | 151 | ;C EXECUTE i*x xt -- j*x execute Forth word 152 | ;C at 'xt' 153 | head EXECUTE,7,EXECUTE,docode 154 | ld h,b ; address of word -> HL 155 | ld l,c 156 | pop bc ; get new TOS 157 | jp (hl) ; go do Forth word 158 | 159 | ; DEFINING WORDS ================================ 160 | 161 | ; ENTER, a.k.a. DOCOLON, entered by CALL ENTER 162 | ; to enter a new high-level thread (colon def'n.) 163 | ; (internal code fragment, not a Forth word) 164 | ; N.B.: DOCOLON must be defined before any 165 | ; appearance of 'docolon' in a 'word' macro! 166 | docolon: ; (alternate name) 167 | enter: dec ix ; push old IP on ret stack 168 | ld (ix+0),d 169 | dec ix 170 | ld (ix+0),e 171 | pop hl ; param field adrs -> IP 172 | nexthl ; use the faster 'nexthl' 173 | 174 | ;C VARIABLE -- define a Forth variable 175 | ; CREATE 1 CELLS ALLOT ; 176 | ; Action of RAM variable is identical to CREATE, 177 | ; so we don't need a DOES> clause to change it. 178 | head VARIABLE,8,VARIABLE,docolon 179 | DW CREATE,LIT,1,CELLS,ALLOT,EXIT 180 | ; DOVAR, code action of VARIABLE, entered by CALL 181 | ; DOCREATE, code action of newly created words 182 | docreate: 183 | dovar: ; -- a-addr 184 | pop hl ; parameter field address 185 | push bc ; push old TOS 186 | ld b,h ; pfa = variable's adrs -> TOS 187 | ld c,l 188 | next 189 | 190 | ;C CONSTANT n -- define a Forth constant 191 | ; CREATE , DOES> (machine code fragment) 192 | head CONSTANT,8,CONSTANT,docolon 193 | DW CREATE,COMMA,XDOES 194 | ; DOCON, code action of CONSTANT, 195 | ; entered by CALL DOCON 196 | docon: ; -- x 197 | pop hl ; parameter field address 198 | push bc ; push old TOS 199 | ld c,(hl) ; fetch contents of parameter 200 | inc hl ; field -> TOS 201 | ld b,(hl) 202 | next 203 | 204 | ;Z USER n -- define user variable 'n' 205 | ; CREATE , DOES> (machine code fragment) 206 | head USER,4,USER,docolon 207 | DW CREATE,COMMA,XDOES 208 | ; DOUSER, code action of USER, 209 | ; entered by CALL DOUSER 210 | douser: ; -- a-addr 211 | pop hl ; parameter field address 212 | push bc ; push old TOS 213 | ld c,(hl) ; fetch contents of parameter 214 | inc hl ; field 215 | ld b,(hl) 216 | push iy ; copy user base address to HL 217 | pop hl 218 | add hl,bc ; and add offset 219 | ld b,h ; put result in TOS 220 | ld c,l 221 | next 222 | 223 | ; DODOES, code action of DOES> clause 224 | ; entered by CALL fragment 225 | ; parameter field 226 | ; ... 227 | ; fragment: CALL DODOES 228 | ; high-level thread 229 | ; Enters high-level thread with address of 230 | ; parameter field on top of stack. 231 | ; (internal code fragment, not a Forth word) 232 | dodoes: ; -- a-addr 233 | dec ix ; push old IP on ret stk 234 | ld (ix+0),d 235 | dec ix 236 | ld (ix+0),e 237 | pop de ; adrs of new thread -> IP 238 | pop hl ; adrs of parameter field 239 | push bc ; push old TOS onto stack 240 | ld b,h ; pfa -> new TOS 241 | ld c,l 242 | next 243 | 244 | ; CP/M TERMINAL I/O ============================= 245 | cpmbdos EQU 5h ; CP/M BDOS entry point 246 | 247 | ;Z BDOS de c -- a call CP/M BDOS 248 | head BDOS,4,BDOS,docode 249 | ex de,hl ; save important Forth regs 250 | pop de ; (DE,IX,IY) & pop DE value 251 | push hl 252 | push ix 253 | push iy 254 | call cpmbdos 255 | ld c,a ; result in TOS 256 | ld b,0 257 | pop iy ; restore Forth regs 258 | pop ix 259 | pop de 260 | next 261 | 262 | ;C EMIT c -- output character to console 263 | ; 6 BDOS DROP ; 264 | ; warning: if c=0ffh, will read one keypress 265 | head EMIT,4,EMIT,docolon 266 | DW LIT,06H,BDOS,DROP,EXIT 267 | 268 | ;Z SAVEKEY -- addr temporary storage for KEY? 269 | head savekey,7,SAVEKEY,dovar 270 | DW 0 271 | 272 | ;X KEY? -- f return true if char waiting 273 | ; 0FF 6 BDOS DUP SAVEKEY C! ; rtns 0 or key 274 | ; must use BDOS function 6 to work with KEY 275 | head querykey,4,KEY?,docolon 276 | DW LIT,0FFH,LIT,06H,BDOS 277 | DW DUP,SAVEKEY,CSTORE,EXIT 278 | 279 | ;C KEY -- c get character from keyboard 280 | ; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT 281 | ; SAVEKEY C@ 0 SAVEKEY C! ; 282 | ; must use CP/M direct console I/O to avoid echo 283 | ; (BDOS function 6, contained within KEY?) 284 | head KEY,3,KEY,docolon 285 | KEY1: DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2 286 | DW QUERYKEY,DROP,branch,KEY1 287 | KEY2: DW SAVEKEY,CFETCH,LIT,0,SAVEKEY,CSTORE 288 | DW EXIT 289 | 290 | ;Z CPMACCEPT c-addr +n -- +n' get line of input 291 | ; SWAP 2 - TUCK C! max # of characters 292 | ; DUP 0A BDOS DROP CP/M Get Console Buffer 293 | ; 1+ C@ 0A EMIT ; get returned count 294 | ; Note: requires the two locations before c-addr 295 | ; to be available for use. 296 | head CPMACCEPT,9,CPMACCEPT,docolon 297 | DW SWOP,LIT,2,MINUS,TUCK,CSTORE 298 | DW DUP,LIT,0Ah,BDOS,DROP 299 | DW ONEPLUS,CFETCH,LIT,0Ah,EMIT,EXIT 300 | 301 | ;X BYE i*x -- return to CP/M 302 | head bye,3,bye,docode 303 | jp 0 304 | 305 | ; STACK OPERATIONS ============================== 306 | 307 | ;C DUP x -- x x duplicate top of stack 308 | head DUP,3,DUP,docode 309 | pushtos: push bc 310 | next 311 | 312 | ;C ?DUP x -- 0 | x x DUP if nonzero 313 | head QDUP,4,?DUP,docode 314 | ld a,b 315 | or c 316 | jr nz,pushtos 317 | next 318 | 319 | ;C DROP x -- drop top of stack 320 | head DROP,4,DROP,docode 321 | poptos: pop bc 322 | next 323 | 324 | ;C SWAP x1 x2 -- x2 x1 swap top two items 325 | head SWOP,4,SWAP,docode 326 | pop hl 327 | push bc 328 | ld b,h 329 | ld c,l 330 | next 331 | 332 | ;C OVER x1 x2 -- x1 x2 x1 per stack diagram 333 | head OVER,4,OVER,docode 334 | pop hl 335 | push hl 336 | push bc 337 | ld b,h 338 | ld c,l 339 | next 340 | 341 | ;C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram 342 | head ROT,3,ROT,docode 343 | ; x3 is in TOS 344 | pop hl ; x2 345 | ex (sp),hl ; x2 on stack, x1 in hl 346 | push bc 347 | ld b,h 348 | ld c,l 349 | next 350 | 351 | ;X NIP x1 x2 -- x2 per stack diagram 352 | head NIP,3,NIP,docolon 353 | DW SWOP,DROP,EXIT 354 | 355 | ;X TUCK x1 x2 -- x2 x1 x2 per stack diagram 356 | head TUCK,4,TUCK,docolon 357 | DW SWOP,OVER,EXIT 358 | 359 | ;C >R x -- R: -- x push to return stack 360 | head TOR,2,>R,docode 361 | dec ix ; push TOS onto rtn stk 362 | ld (ix+0),b 363 | dec ix 364 | ld (ix+0),c 365 | pop bc ; pop new TOS 366 | next 367 | 368 | ;C R> -- x R: x -- pop from return stack 369 | head RFROM,2,R>,docode 370 | push bc ; push old TOS 371 | ld c,(ix+0) ; pop top rtn stk item 372 | inc ix ; to TOS 373 | ld b,(ix+0) 374 | inc ix 375 | next 376 | 377 | ;C R@ -- x R: x -- x fetch from rtn stk 378 | head RFETCH,2,R@,docode 379 | push bc ; push old TOS 380 | ld c,(ix+0) ; fetch top rtn stk item 381 | ld b,(ix+1) ; to TOS 382 | next 383 | 384 | ;Z SP@ -- a-addr get data stack pointer 385 | head SPFETCH,3,SP@,docode 386 | push bc 387 | ld hl,0 388 | add hl,sp 389 | ld b,h 390 | ld c,l 391 | next 392 | 393 | ;Z SP! a-addr -- set data stack pointer 394 | head SPSTORE,3,SP!,docode 395 | ld h,b 396 | ld l,c 397 | ld sp,hl 398 | pop bc ; get new TOS 399 | next 400 | 401 | ;Z RP@ -- a-addr get return stack pointer 402 | head RPFETCH,3,RP@,docode 403 | push bc 404 | push ix 405 | pop bc 406 | next 407 | 408 | ;Z RP! a-addr -- set return stack pointer 409 | head RPSTORE,3,RP!,docode 410 | push bc 411 | pop ix 412 | pop bc 413 | next 414 | 415 | ; MEMORY AND I/O OPERATIONS ===================== 416 | 417 | ;C ! x a-addr -- store cell in memory 418 | head STORE,1,!,docode 419 | ld h,b ; address in hl 420 | ld l,c 421 | pop bc ; data in bc 422 | ld (hl),c 423 | inc hl 424 | ld (hl),b 425 | pop bc ; pop new TOS 426 | next 427 | 428 | ;C C! char c-addr -- store char in memory 429 | head CSTORE,2,C!,docode 430 | ld h,b ; address in hl 431 | ld l,c 432 | pop bc ; data in bc 433 | ld (hl),c 434 | pop bc ; pop new TOS 435 | next 436 | 437 | ;C @ a-addr -- x fetch cell from memory 438 | head FETCH,1,@,docode 439 | ld h,b ; address in hl 440 | ld l,c 441 | ld c,(hl) 442 | inc hl 443 | ld b,(hl) 444 | next 445 | 446 | ;C C@ c-addr -- char fetch char from memory 447 | head CFETCH,2,C@,docode 448 | ld a,(bc) 449 | ld c,a 450 | ld b,0 451 | next 452 | 453 | ;Z PC! char c-addr -- output char to port 454 | head PCSTORE,3,PC!,docode 455 | pop hl ; char in L 456 | out (c),l ; to port (BC) 457 | pop bc ; pop new TOS 458 | next 459 | 460 | ;Z PC@ c-addr -- char input char from port 461 | head PCFETCH,3,PC@,docode 462 | in c,(c) ; read port (BC) to C 463 | ld b,0 464 | next 465 | 466 | ; ARITHMETIC AND LOGICAL OPERATIONS ============= 467 | 468 | ;C + n1/u1 n2/u2 -- n3/u3 add n1+n2 469 | head PLUS,1,+,docode 470 | pop hl 471 | add hl,bc 472 | ld b,h 473 | ld c,l 474 | next 475 | 476 | ;X M+ d n -- d add single to double 477 | head MPLUS,2,M+,docode 478 | ex de,hl 479 | pop de ; hi cell 480 | ex (sp),hl ; lo cell, save IP 481 | add hl,bc 482 | ld b,d ; hi result in BC (TOS) 483 | ld c,e 484 | jr nc,mplus1 485 | inc bc 486 | mplus1: pop de ; restore saved IP 487 | push hl ; push lo result 488 | next 489 | 490 | ;C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2 491 | head MINUS,1,-,docode 492 | pop hl 493 | or a 494 | sbc hl,bc 495 | ld b,h 496 | ld c,l 497 | next 498 | 499 | ;C AND x1 x2 -- x3 logical AND 500 | head AND,3,AND,docode 501 | pop hl 502 | ld a,b 503 | and h 504 | ld b,a 505 | ld a,c 506 | and l 507 | ld c,a 508 | next 509 | 510 | ;C OR x1 x2 -- x3 logical OR 511 | head OR,2,OR,docode 512 | pop hl 513 | ld a,b 514 | or h 515 | ld b,a 516 | ld a,c 517 | or l 518 | ld c,a 519 | next 520 | 521 | ;C XOR x1 x2 -- x3 logical XOR 522 | head XOR,3,XOR,docode 523 | pop hl 524 | ld a,b 525 | xor h 526 | ld b,a 527 | ld a,c 528 | xor l 529 | ld c,a 530 | next 531 | 532 | ;C INVERT x1 -- x2 bitwise inversion 533 | head INVERT,6,INVERT,docode 534 | ld a,b 535 | cpl 536 | ld b,a 537 | ld a,c 538 | cpl 539 | ld c,a 540 | next 541 | 542 | ;C NEGATE x1 -- x2 two's complement 543 | head NEGATE,6,NEGATE,docode 544 | ld a,b 545 | cpl 546 | ld b,a 547 | ld a,c 548 | cpl 549 | ld c,a 550 | inc bc 551 | next 552 | 553 | ;C 1+ n1/u1 -- n2/u2 add 1 to TOS 554 | head ONEPLUS,2,1+,docode 555 | inc bc 556 | next 557 | 558 | ;C 1- n1/u1 -- n2/u2 subtract 1 from TOS 559 | head ONEMINUS,2,1-,docode 560 | dec bc 561 | next 562 | 563 | ;Z >< x1 -- x2 swap bytes (not ANSI) 564 | head swapbytes,2,><,docode 565 | ld a,b 566 | ld b,c 567 | ld c,a 568 | next 569 | 570 | ;C 2* x1 -- x2 arithmetic left shift 571 | head TWOSTAR,2,2*,docode 572 | sla c 573 | rl b 574 | next 575 | 576 | ;C 2/ x1 -- x2 arithmetic right shift 577 | head TWOSLASH,2,2/,docode 578 | sra b 579 | rr c 580 | next 581 | 582 | ;C LSHIFT x1 u -- x2 logical L shift u places 583 | head LSHIFT,6,LSHIFT,docode 584 | ld b,c ; b = loop counter 585 | pop hl ; NB: hi 8 bits ignored! 586 | inc b ; test for counter=0 case 587 | jr lsh2 588 | lsh1: add hl,hl ; left shift HL, n times 589 | lsh2: djnz lsh1 590 | ld b,h ; result is new TOS 591 | ld c,l 592 | next 593 | 594 | ;C RSHIFT x1 u -- x2 logical R shift u places 595 | head RSHIFT,6,RSHIFT,docode 596 | ld b,c ; b = loop counter 597 | pop hl ; NB: hi 8 bits ignored! 598 | inc b ; test for counter=0 case 599 | jr rsh2 600 | rsh1: srl h ; right shift HL, n times 601 | rr l 602 | rsh2: djnz rsh1 603 | ld b,h ; result is new TOS 604 | ld c,l 605 | next 606 | 607 | ;C +! n/u a-addr -- add cell to memory 608 | head PLUSSTORE,2,+!,docode 609 | pop hl 610 | ld a,(bc) ; low byte 611 | add a,l 612 | ld (bc),a 613 | inc bc 614 | ld a,(bc) ; high byte 615 | adc a,h 616 | ld (bc),a 617 | pop bc ; pop new TOS 618 | next 619 | 620 | ; COMPARISON OPERATIONS ========================= 621 | 622 | ;C 0= n/u -- flag return true if TOS=0 623 | head ZEROEQUAL,2,0=,docode 624 | ld a,b 625 | or c ; result=0 if bc was 0 626 | sub 1 ; cy set if bc was 0 627 | sbc a,a ; propagate cy through A 628 | ld b,a ; put 0000 or FFFF in TOS 629 | ld c,a 630 | next 631 | 632 | ;C 0< n -- flag true if TOS negative 633 | head ZEROLESS,2,0<,docode 634 | sla b ; sign bit -> cy flag 635 | sbc a,a ; propagate cy through A 636 | ld b,a ; put 0000 or FFFF in TOS 637 | ld c,a 638 | next 639 | 640 | ;C = x1 x2 -- flag test x1=x2 641 | head EQUAL,1,=,docode 642 | pop hl 643 | or a 644 | sbc hl,bc ; x1-x2 in HL, SZVC valid 645 | jr z,tostrue 646 | tosfalse: ld bc,0 647 | next 648 | 649 | ;X <> x1 x2 -- flag test not eq (not ANSI) 650 | head NOTEQUAL,2,<>,docolon 651 | DW EQUAL,ZEROEQUAL,EXIT 652 | 653 | ;C < n1 n2 -- flag test n1 n1 +ve, n2 -ve, rslt -ve, so n1>n2 660 | ; if result positive & not OV, n1>=n2 661 | ; pos. & OV => n1 -ve, n2 +ve, rslt +ve, so n1 n1 n2 -- flag test n1>n2, signed 671 | head GREATER,1,>,docolon 672 | DW SWOP,LESS,EXIT 673 | 674 | ;C U< u1 u2 -- flag test u1 u1 u2 -- flag u1>u2 unsgd (not ANSI) 685 | head UGREATER,2,U>,docolon 686 | DW SWOP,ULESS,EXIT 687 | 688 | ; LOOP AND BRANCH OPERATIONS ==================== 689 | 690 | ;Z branch -- branch always 691 | head branch,6,branch,docode 692 | dobranch: ld a,(de) ; get inline value => IP 693 | ld l,a 694 | inc de 695 | ld a,(de) 696 | ld h,a 697 | nexthl 698 | 699 | ;Z ?branch x -- branch if TOS zero 700 | head qbranch,7,?branch,docode 701 | ld a,b 702 | or c ; test old TOS 703 | pop bc ; pop new TOS 704 | jr z,dobranch ; if old TOS=0, branch 705 | inc de ; else skip inline value 706 | inc de 707 | next 708 | 709 | ;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2 710 | ;Z run-time code for DO 711 | ; '83 and ANSI standard loops terminate when the 712 | ; boundary of limit-1 and limit is crossed, in 713 | ; either direction. This can be conveniently 714 | ; implemented by making the limit 8000h, so that 715 | ; arithmetic overflow logic can detect crossing. 716 | ; I learned this trick from Laxen & Perry F83. 717 | ; fudge factor = 8000h-limit, to be added to 718 | ; the start value. 719 | head xdo,4,(do),docode 720 | ex de,hl 721 | ex (sp),hl ; IP on stack, limit in HL 722 | ex de,hl 723 | ld hl,8000h 724 | or a 725 | sbc hl,de ; 8000-limit in HL 726 | dec ix ; push this fudge factor 727 | ld (ix+0),h ; onto return stack 728 | dec ix ; for later use by 'I' 729 | ld (ix+0),l 730 | add hl,bc ; add fudge to start value 731 | dec ix ; push adjusted start value 732 | ld (ix+0),h ; onto return stack 733 | dec ix ; as the loop index. 734 | ld (ix+0),l 735 | pop de ; restore the saved IP 736 | pop bc ; pop new TOS 737 | next 738 | 739 | ;Z (loop) R: sys1 sys2 -- | sys1 sys2 740 | ;Z run-time code for LOOP 741 | ; Add 1 to the loop index. If loop terminates, 742 | ; clean up the return stack and skip the branch. 743 | ; Else take the inline branch. Note that LOOP 744 | ; terminates when index=8000h. 745 | head xloop,6,(loop),docode 746 | exx 747 | ld bc,1 748 | looptst: ld l,(ix+0) ; get the loop index 749 | ld h,(ix+1) 750 | or a 751 | adc hl,bc ; increment w/overflow test 752 | jp pe,loopterm ; overflow=loop done 753 | ; continue the loop 754 | ld (ix+0),l ; save the updated index 755 | ld (ix+1),h 756 | exx 757 | jr dobranch ; take the inline branch 758 | loopterm: ; terminate the loop 759 | ld bc,4 ; discard the loop info 760 | add ix,bc 761 | exx 762 | inc de ; skip the inline branch 763 | inc de 764 | next 765 | 766 | ;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2 767 | ;Z run-time code for +LOOP 768 | ; Add n to the loop index. If loop terminates, 769 | ; clean up the return stack and skip the branch. 770 | ; Else take the inline branch. 771 | head xplusloop,7,(+loop),docode 772 | pop hl ; this will be the new TOS 773 | push bc 774 | ld b,h 775 | ld c,l 776 | exx 777 | pop bc ; old TOS = loop increment 778 | jr looptst 779 | 780 | ;C I -- n R: sys1 sys2 -- sys1 sys2 781 | ;C get the innermost loop index 782 | head II,1,I,docode 783 | push bc ; push old TOS 784 | ld l,(ix+0) ; get current loop index 785 | ld h,(ix+1) 786 | ld c,(ix+2) ; get fudge factor 787 | ld b,(ix+3) 788 | or a 789 | sbc hl,bc ; subtract fudge factor, 790 | ld b,h ; returning true index 791 | ld c,l 792 | next 793 | 794 | ;C J -- n R: 4*sys -- 4*sys 795 | ;C get the second loop index 796 | head JJ,1,J,docode 797 | push bc ; push old TOS 798 | ld l,(ix+4) ; get current loop index 799 | ld h,(ix+5) 800 | ld c,(ix+6) ; get fudge factor 801 | ld b,(ix+7) 802 | or a 803 | sbc hl,bc ; subtract fudge factor, 804 | ld b,h ; returning true index 805 | ld c,l 806 | next 807 | 808 | ;C UNLOOP -- R: sys1 sys2 -- drop loop parms 809 | head UNLOOP,6,UNLOOP,docode 810 | inc ix 811 | inc ix 812 | inc ix 813 | inc ix 814 | next 815 | 816 | ; MULTIPLY AND DIVIDE =========================== 817 | 818 | ;C UM* u1 u2 -- ud unsigned 16x16->32 mult. 819 | head UMSTAR,3,UM*,docode 820 | push bc 821 | exx 822 | pop bc ; u2 in BC 823 | pop de ; u1 in DE 824 | ld hl,0 ; result will be in HLDE 825 | ld a,17 ; loop counter 826 | or a ; clear cy 827 | umloop: rr h 828 | rr l 829 | rr d 830 | rr e 831 | jr nc,noadd 832 | add hl,bc 833 | noadd: dec a 834 | jr nz,umloop 835 | push de ; lo result 836 | push hl ; hi result 837 | exx 838 | pop bc ; put TOS back in BC 839 | next 840 | 841 | ;C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16 842 | head UMSLASHMOD,6,UM/MOD,docode 843 | push bc 844 | exx 845 | pop bc ; BC = divisor 846 | pop hl ; HLDE = dividend 847 | pop de 848 | ld a,16 ; loop counter 849 | sla e 850 | rl d ; hi bit DE -> carry 851 | udloop: adc hl,hl ; rot left w/ carry 852 | jr nc,udiv3 853 | ; case 1: 17 bit, cy:HL = 1xxxx 854 | or a ; we know we can subtract 855 | sbc hl,bc 856 | or a ; clear cy to indicate sub ok 857 | jr udiv4 858 | ; case 2: 16 bit, cy:HL = 0xxxx 859 | udiv3: sbc hl,bc ; try the subtract 860 | jr nc,udiv4 ; if no cy, subtract ok 861 | add hl,bc ; else cancel the subtract 862 | scf ; and set cy to indicate 863 | udiv4: rl e ; rotate result bit into DE, 864 | rl d ; and next bit of DE into cy 865 | dec a 866 | jr nz,udloop 867 | ; now have complemented quotient in DE, 868 | ; and remainder in HL 869 | ld a,d 870 | cpl 871 | ld b,a 872 | ld a,e 873 | cpl 874 | ld c,a 875 | push hl ; push remainder 876 | push bc 877 | exx 878 | pop bc ; quotient remains in TOS 879 | next 880 | 881 | ; BLOCK AND STRING OPERATIONS =================== 882 | 883 | ;C FILL c-addr u char -- fill memory with char 884 | head FILL,4,FILL,docode 885 | ld a,c ; character in a 886 | exx ; use alt. register set 887 | pop bc ; count in bc 888 | pop de ; address in de 889 | or a ; clear carry flag 890 | ld hl,0ffffh 891 | adc hl,bc ; test for count=0 or 1 892 | jr nc,filldone ; no cy: count=0, skip 893 | ld (de),a ; fill first byte 894 | jr z,filldone ; zero, count=1, done 895 | dec bc ; else adjust count, 896 | ld h,d ; let hl = start adrs, 897 | ld l,e 898 | inc de ; let de = start adrs+1 899 | ldir ; copy (hl)->(de) 900 | filldone: exx ; back to main reg set 901 | pop bc ; pop new TOS 902 | next 903 | 904 | ;X CMOVE c-addr1 c-addr2 u -- move from bottom 905 | ; as defined in the ANSI optional String word set 906 | ; On byte machines, CMOVE and CMOVE> are logical 907 | ; factors of MOVE. They are easy to implement on 908 | ; CPUs which have a block-move instruction. 909 | head CMOVE,5,CMOVE,docode 910 | push bc 911 | exx 912 | pop bc ; count 913 | pop de ; destination adrs 914 | pop hl ; source adrs 915 | ld a,b ; test for count=0 916 | or c 917 | jr z,cmovedone 918 | ldir ; move from bottom to top 919 | cmovedone: exx 920 | pop bc ; pop new TOS 921 | next 922 | 923 | ;X CMOVE> c-addr1 c-addr2 u -- move from top 924 | ; as defined in the ANSI optional String word set 925 | head CMOVEUP,6,CMOVE>,docode 926 | push bc 927 | exx 928 | pop bc ; count 929 | pop hl ; destination adrs 930 | pop de ; source adrs 931 | ld a,b ; test for count=0 932 | or c 933 | jr z,umovedone 934 | add hl,bc ; last byte in destination 935 | dec hl 936 | ex de,hl 937 | add hl,bc ; last byte in source 938 | dec hl 939 | lddr ; move from top to bottom 940 | umovedone: exx 941 | pop bc ; pop new TOS 942 | next 943 | 944 | ;Z SKIP c-addr u c -- c-addr' u' 945 | ;Z skip matching chars 946 | ; Although SKIP, SCAN, and S= are perhaps not the 947 | ; ideal factors of WORD and FIND, they closely 948 | ; follow the string operations available on many 949 | ; CPUs, and so are easy to implement and fast. 950 | head skip,4,SKIP,docode 951 | ld a,c ; skip character 952 | exx 953 | pop bc ; count 954 | pop hl ; address 955 | ld e,a ; test for count=0 956 | ld a,b 957 | or c 958 | jr z,skipdone 959 | ld a,e 960 | skiploop: cpi 961 | jr nz,skipmis ; char mismatch: exit 962 | jp pe,skiploop ; count not exhausted 963 | jr skipdone ; count 0, no mismatch 964 | skipmis: inc bc ; mismatch! undo last to 965 | dec hl ; point at mismatch char 966 | skipdone: push hl ; updated address 967 | push bc ; updated count 968 | exx 969 | pop bc ; TOS in bc 970 | next 971 | 972 | ;Z SCAN c-addr u c -- c-addr' u' 973 | ;Z find matching char 974 | head scan,4,SCAN,docode 975 | ld a,c ; scan character 976 | exx 977 | pop bc ; count 978 | pop hl ; address 979 | ld e,a ; test for count=0 980 | ld a,b 981 | or c 982 | jr z,scandone 983 | ld a,e 984 | cpir ; scan 'til match or count=0 985 | jr nz,scandone ; no match, BC & HL ok 986 | inc bc ; match! undo last to 987 | dec hl ; point at match char 988 | scandone: push hl ; updated address 989 | push bc ; updated count 990 | exx 991 | pop bc ; TOS in bc 992 | next 993 | 994 | ;Z S= c-addr1 c-addr2 u -- n string compare 995 | ;Z n<0: s10: s1>s2 996 | head sequal,2,S=,docode 997 | push bc 998 | exx 999 | pop bc ; count 1000 | pop hl ; addr2 1001 | pop de ; addr1 1002 | ld a,b ; test for count=0 1003 | or c 1004 | jr z,smatch ; by definition, match! 1005 | sloop: ld a,(de) 1006 | inc de 1007 | cpi 1008 | jr nz,sdiff ; char mismatch: exit 1009 | jp pe,sloop ; count not exhausted 1010 | smatch: ; count exhausted & no mismatch found 1011 | exx 1012 | ld bc,0 ; bc=0000 (s1=s2) 1013 | jr snext 1014 | sdiff: ; mismatch! undo last 'cpi' increment 1015 | dec hl ; point at mismatch char 1016 | cp (hl) ; set cy if char1 < char2 1017 | sbc a,a ; propagate cy thru A 1018 | exx 1019 | ld b,a ; bc=FFFF if cy (s1s2) 1021 | ld c,a 1022 | snext: next 1023 | 1024 | *INCLUDE camel80d.azm ; CPU Dependencies 1025 | *INCLUDE camel80h.azm ; High Level words 1026 | lastword EQU link ; nfa of last word in dict. 1027 | enddict EQU $ ; user's code starts here 1028 | END 1029 | 1030 | -------------------------------------------------------------------------------- /source/cam80-12/CAMEL80D.AZM: -------------------------------------------------------------------------------- 1 | ; LISTING 3. 2 | ; 3 | ; =============================================== 4 | ; CamelForth for the Zilog Z80 5 | ; (c) 1994 Bradford J. Rodriguez 6 | ; Permission is granted to freely copy, modify, 7 | ; and distribute this program for personal or 8 | ; educational use. Commercial inquiries should 9 | ; be directed to the author at 221 King St. E., 10 | ; #32, Hamilton, Ontario L8N 1B5 Canada 11 | ; 12 | ; CAMEL80D.AZM: CPU and Model Dependencies 13 | ; Source code is for the Z80MR macro assembler. 14 | ; Forth words are documented as follows: 15 | ;* NAME stack -- stack description 16 | ; Word names in upper case are from the ANS 17 | ; Forth Core word set. Names in lower case are 18 | ; "internal" implementation words & extensions. 19 | ; 20 | ; Direct-Threaded Forth model for Zilog Z80 21 | ; cell size is 16 bits (2 bytes) 22 | ; char size is 8 bits (1 byte) 23 | ; address unit is 8 bits (1 byte), i.e., 24 | ; addresses are byte-aligned. 25 | ; =============================================== 26 | 27 | ; ALIGNMENT AND PORTABILITY OPERATORS =========== 28 | ; Many of these are synonyms for other words, 29 | ; and so are defined as CODE words. 30 | 31 | ;C ALIGN -- align HERE 32 | head ALIGN,5,ALIGN,docode 33 | noop: next 34 | 35 | ;C ALIGNED addr -- a-addr align given addr 36 | head ALIGNED,7,ALIGNED,docode 37 | jr noop 38 | 39 | ;Z CELL -- n size of one cell 40 | head CELL,4,CELL,docon 41 | dw 2 42 | 43 | ;C CELL+ a-addr1 -- a-addr2 add cell size 44 | ; 2 + ; 45 | head CELLPLUS,5,CELL+,docode 46 | inc bc 47 | inc bc 48 | next 49 | 50 | ;C CELLS n1 -- n2 cells->adrs units 51 | head CELLS,5,CELLS,docode 52 | jp twostar 53 | 54 | ;C CHAR+ c-addr1 -- c-addr2 add char size 55 | head CHARPLUS,5,CHAR+,docode 56 | jp oneplus 57 | 58 | ;C CHARS n1 -- n2 chars->adrs units 59 | head CHARS,5,CHARS,docode 60 | jr noop 61 | 62 | ;C >BODY xt -- a-addr adrs of param field 63 | ; 3 + ; Z80 (3 byte CALL) 64 | head TOBODY,5,>BODY,docolon 65 | DW LIT,3,PLUS,EXIT 66 | 67 | ;X COMPILE, xt -- append execution token 68 | ; I called this word ,XT before I discovered that 69 | ; it is defined in the ANSI standard as COMPILE,. 70 | ; On a DTC Forth this simply appends xt (like , ) 71 | ; but on an STC Forth this must append 'CALL xt'. 72 | head COMMAXT,8,'COMPILE,',docode 73 | jp COMMA 74 | 75 | ;Z !CF adrs cfa -- set code action of a word 76 | ; 0CD OVER C! store 'CALL adrs' instr 77 | ; 1+ ! ; Z80 VERSION 78 | ; Depending on the implementation this could 79 | ; append CALL adrs or JUMP adrs. 80 | head STORECF,3,!CF,docolon 81 | DW LIT,0CDH,OVER,CSTORE 82 | DW ONEPLUS,STORE,EXIT 83 | 84 | ;Z ,CF adrs -- append a code field 85 | ; HERE !CF 3 ALLOT ; Z80 VERSION (3 bytes) 86 | head COMMACF,3,',CF',docolon 87 | DW HERE,STORECF,LIT,3,ALLOT,EXIT 88 | 89 | ;Z !COLON -- change code field to docolon 90 | ; -3 ALLOT docolon-adrs ,CF ; 91 | ; This should be used immediately after CREATE. 92 | ; This is made a distinct word, because on an STC 93 | ; Forth, colon definitions have no code field. 94 | head STORCOLON,6,'!COLON',docolon 95 | DW LIT,-3,ALLOT 96 | DW LIT,docolon,COMMACF,EXIT 97 | 98 | ;Z ,EXIT -- append hi-level EXIT action 99 | ; ['] EXIT ,XT ; 100 | ; This is made a distinct word, because on an STC 101 | ; Forth, it appends a RET instruction, not an xt. 102 | head CEXIT,5,',EXIT',docolon 103 | DW LIT,EXIT,COMMAXT,EXIT 104 | 105 | ; CONTROL STRUCTURES ============================ 106 | ; These words allow Forth control structure words 107 | ; to be defined portably. 108 | 109 | ;Z ,BRANCH xt -- append a branch instruction 110 | ; xt is the branch operator to use, e.g. qbranch 111 | ; or (loop). It does NOT append the destination 112 | ; address. On the Z80 this is equivalent to ,XT. 113 | head COMMABRANCH,7,',BRANCH',docode 114 | jp COMMA 115 | 116 | ;Z ,DEST dest -- append a branch address 117 | ; This appends the given destination address to 118 | ; the branch instruction. On the Z80 this is ',' 119 | ; ...other CPUs may use relative addressing. 120 | head COMMADEST,5,',DEST',docode 121 | jp COMMA 122 | 123 | ;Z !DEST dest adrs -- change a branch dest'n 124 | ; Changes the destination address found at 'adrs' 125 | ; to the given 'dest'. On the Z80 this is '!' 126 | ; ...other CPUs may need relative addressing. 127 | head STOREDEST,5,'!DEST',docode 128 | jp STORE 129 | 130 | ; HEADER STRUCTURE ============================== 131 | ; The structure of the Forth dictionary headers 132 | ; (name, link, immediate flag, and "smudge" bit) 133 | ; does not necessarily differ across CPUs. This 134 | ; structure is not easily factored into distinct 135 | ; "portable" words; instead, it is implicit in 136 | ; the definitions of FIND and CREATE, and also in 137 | ; NFA>LFA, NFA>CFA, IMMED?, IMMEDIATE, HIDE, and 138 | ; REVEAL. These words must be (substantially) 139 | ; rewritten if either the header structure or its 140 | ; inherent assumptions are changed. 141 | 142 | -------------------------------------------------------------------------------- /source/cam80-12/CAMEL80H.AZM: -------------------------------------------------------------------------------- 1 | ; LISTING 2. 2 | ; 3 | ; =============================================== 4 | ; CamelForth for the Zilog Z80 5 | ; (c) 1994 Bradford J. Rodriguez 6 | ; Permission is granted to freely copy, modify, 7 | ; and distribute this program for personal or 8 | ; educational use. Commercial inquiries should 9 | ; be directed to the author at 221 King St. E., 10 | ; #32, Hamilton, Ontario L8N 1B5 Canada 11 | ; 12 | ; CAMEL80H.AZM: High Level Words 13 | ; Source code is for the Z80MR macro assembler. 14 | ; Forth words are documented as follows: 15 | ;* NAME stack -- stack description 16 | ; Word names in upper case are from the ANS 17 | ; Forth Core word set. Names in lower case are 18 | ; "internal" implementation words & extensions. 19 | ; =============================================== 20 | 21 | ; SYSTEM VARIABLES & CONSTANTS ================== 22 | 23 | ;C BL -- char an ASCII space 24 | head BL,2,BL,docon 25 | dw 20h 26 | 27 | ;Z tibsize -- n size of TIB 28 | head TIBSIZE,7,TIBSIZE,docon 29 | dw 124 ; 2 chars safety zone 30 | 31 | ;X tib -- a-addr Terminal Input Buffer 32 | ; HEX 82 CONSTANT TIB CP/M systems: 126 bytes 33 | ; HEX -80 USER TIB others: below user area 34 | head TIB,3,TIB,docon 35 | dw 82h 36 | 37 | ;Z u0 -- a-addr current user area adrs 38 | ; 0 USER U0 39 | head U0,2,U0,douser 40 | dw 0 41 | 42 | ;C >IN -- a-addr holds offset into TIB 43 | ; 2 USER >IN 44 | head TOIN,3,>IN,douser 45 | dw 2 46 | 47 | ;C BASE -- a-addr holds conversion radix 48 | ; 4 USER BASE 49 | head BASE,4,BASE,douser 50 | dw 4 51 | 52 | ;C STATE -- a-addr holds compiler state 53 | ; 6 USER STATE 54 | head STATE,5,STATE,douser 55 | dw 6 56 | 57 | ;Z dp -- a-addr holds dictionary ptr 58 | ; 8 USER DP 59 | head DP,2,DP,douser 60 | dw 8 61 | 62 | ;Z 'source -- a-addr two cells: len, adrs 63 | ; 10 USER 'SOURCE 64 | ; head TICKSOURCE,7,'SOURCE,douser 65 | DW link ; must expand 66 | DB 0 ; manually 67 | link DEFL $ ; because of 68 | DB 7,27h,'SOURCE' ; tick character 69 | TICKSOURCE: call douser ; in name! 70 | dw 10 71 | 72 | ;Z latest -- a-addr last word in dict. 73 | ; 14 USER LATEST 74 | head LATEST,6,LATEST,douser 75 | dw 14 76 | 77 | ;Z hp -- a-addr HOLD pointer 78 | ; 16 USER HP 79 | head HP,2,HP,douser 80 | dw 16 81 | 82 | ;Z LP -- a-addr Leave-stack pointer 83 | ; 18 USER LP 84 | head LP,2,LP,douser 85 | dw 18 86 | 87 | ;Z s0 -- a-addr end of parameter stack 88 | head S0,2,S0,douser 89 | dw 100h 90 | 91 | ;X PAD -- a-addr user PAD buffer 92 | ; = end of hold area! 93 | head PAD,3,PAD,douser 94 | dw 128h 95 | 96 | ;Z l0 -- a-addr bottom of Leave stack 97 | head L0,2,L0,douser 98 | dw 180h 99 | 100 | ;Z r0 -- a-addr end of return stack 101 | head R0,2,R0,douser 102 | dw 200h 103 | 104 | ;Z uinit -- addr initial values for user area 105 | head UINIT,5,UINIT,docreate 106 | DW 0,0,10,0 ; reserved,>IN,BASE,STATE 107 | DW enddict ; DP 108 | DW 0,0 ; SOURCE init'd elsewhere 109 | DW lastword ; LATEST 110 | DW 0 ; HP init'd elsewhere 111 | 112 | ;Z #init -- n #bytes of user area init data 113 | head NINIT,5,#INIT,docon 114 | DW 18 115 | 116 | ; ARITHMETIC OPERATORS ========================== 117 | 118 | ;C S>D n -- d single -> double prec. 119 | ; DUP 0< ; 120 | head STOD,3,S>D,docolon 121 | dw DUP,ZEROLESS,EXIT 122 | 123 | ;Z ?NEGATE n1 n2 -- n3 negate n1 if n2 negative 124 | ; 0< IF NEGATE THEN ; ...a common factor 125 | head QNEGATE,7,?NEGATE,docolon 126 | DW ZEROLESS,qbranch,QNEG1,NEGATE 127 | QNEG1: DW EXIT 128 | 129 | ;C ABS n1 -- +n2 absolute value 130 | ; DUP ?NEGATE ; 131 | head ABS,3,ABS,docolon 132 | DW DUP,QNEGATE,EXIT 133 | 134 | ;X DNEGATE d1 -- d2 negate double precision 135 | ; SWAP INVERT SWAP INVERT 1 M+ ; 136 | head DNEGATE,7,DNEGATE,docolon 137 | DW SWOP,INVERT,SWOP,INVERT,LIT,1,MPLUS 138 | DW EXIT 139 | 140 | ;Z ?DNEGATE d1 n -- d2 negate d1 if n negative 141 | ; 0< IF DNEGATE THEN ; ...a common factor 142 | head QDNEGATE,8,?DNEGATE,docolon 143 | DW ZEROLESS,qbranch,DNEG1,DNEGATE 144 | DNEG1: DW EXIT 145 | 146 | ;X DABS d1 -- +d2 absolute value dbl.prec. 147 | ; DUP ?DNEGATE ; 148 | head DABS,4,DABS,docolon 149 | DW DUP,QDNEGATE,EXIT 150 | 151 | ;C M* n1 n2 -- d signed 16*16->32 multiply 152 | ; 2DUP XOR >R carries sign of the result 153 | ; SWAP ABS SWAP ABS UM* 154 | ; R> ?DNEGATE ; 155 | head MSTAR,2,M*,docolon 156 | DW TWODUP,XOR,TOR 157 | DW SWOP,ABS,SWOP,ABS,UMSTAR 158 | DW RFROM,QDNEGATE,EXIT 159 | 160 | ;C SM/REM d1 n1 -- n2 n3 symmetric signed div 161 | ; 2DUP XOR >R sign of quotient 162 | ; OVER >R sign of remainder 163 | ; ABS >R DABS R> UM/MOD 164 | ; SWAP R> ?NEGATE 165 | ; SWAP R> ?NEGATE ; 166 | ; Ref. dpANS-6 section 3.2.2.1. 167 | head SMSLASHREM,6,SM/REM,docolon 168 | DW TWODUP,XOR,TOR,OVER,TOR 169 | DW ABS,TOR,DABS,RFROM,UMSLASHMOD 170 | DW SWOP,RFROM,QNEGATE,SWOP,RFROM,QNEGATE 171 | DW EXIT 172 | 173 | ;C FM/MOD d1 n1 -- n2 n3 floored signed div'n 174 | ; DUP >R save divisor 175 | ; SM/REM 176 | ; DUP 0< IF if quotient negative, 177 | ; SWAP R> + add divisor to rem'dr 178 | ; SWAP 1- decrement quotient 179 | ; ELSE R> DROP THEN ; 180 | ; Ref. dpANS-6 section 3.2.2.1. 181 | head FMSLASHMOD,6,FM/MOD,docolon 182 | DW DUP,TOR,SMSLASHREM 183 | DW DUP,ZEROLESS,qbranch,FMMOD1 184 | DW SWOP,RFROM,PLUS,SWOP,ONEMINUS 185 | DW branch,FMMOD2 186 | FMMOD1: DW RFROM,DROP 187 | FMMOD2: DW EXIT 188 | 189 | ;C * n1 n2 -- n3 signed multiply 190 | ; M* DROP ; 191 | head STAR,1,*,docolon 192 | dw MSTAR,DROP,EXIT 193 | 194 | ;C /MOD n1 n2 -- n3 n4 signed divide/rem'dr 195 | ; >R S>D R> FM/MOD ; 196 | head SLASHMOD,4,/MOD,docolon 197 | dw TOR,STOD,RFROM,FMSLASHMOD,EXIT 198 | 199 | ;C / n1 n2 -- n3 signed divide 200 | ; /MOD nip ; 201 | head SLASH,1,/,docolon 202 | dw SLASHMOD,NIP,EXIT 203 | 204 | ;C MOD n1 n2 -- n3 signed remainder 205 | ; /MOD DROP ; 206 | head MOD,3,MOD,docolon 207 | dw SLASHMOD,DROP,EXIT 208 | 209 | ;C */MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem" 210 | ; >R M* R> FM/MOD ; 211 | head SSMOD,5,*/MOD,docolon 212 | dw TOR,MSTAR,RFROM,FMSLASHMOD,EXIT 213 | 214 | ;C */ n1 n2 n3 -- n4 n1*n2/n3 215 | ; */MOD nip ; 216 | head STARSLASH,2,*/,docolon 217 | dw SSMOD,NIP,EXIT 218 | 219 | ;C MAX n1 n2 -- n3 signed maximum 220 | ; 2DUP < IF SWAP THEN DROP ; 221 | head MAX,3,MAX,docolon 222 | dw TWODUP,LESS,qbranch,MAX1,SWOP 223 | MAX1: dw DROP,EXIT 224 | 225 | ;C MIN n1 n2 -- n3 signed minimum 226 | ; 2DUP > IF SWAP THEN DROP ; 227 | head MIN,3,MIN,docolon 228 | dw TWODUP,GREATER,qbranch,MIN1,SWOP 229 | MIN1: dw DROP,EXIT 230 | 231 | ; DOUBLE OPERATORS ============================== 232 | 233 | ;C 2@ a-addr -- x1 x2 fetch 2 cells 234 | ; DUP CELL+ @ SWAP @ ; 235 | ; the lower address will appear on top of stack 236 | head TWOFETCH,2,2@,docolon 237 | dw DUP,CELLPLUS,FETCH,SWOP,FETCH,EXIT 238 | 239 | ;C 2! x1 x2 a-addr -- store 2 cells 240 | ; SWAP OVER ! CELL+ ! ; 241 | ; the top of stack is stored at the lower adrs 242 | head TWOSTORE,2,2!,docolon 243 | dw SWOP,OVER,STORE,CELLPLUS,STORE,EXIT 244 | 245 | ;C 2DROP x1 x2 -- drop 2 cells 246 | ; DROP DROP ; 247 | head TWODROP,5,2DROP,docolon 248 | dw DROP,DROP,EXIT 249 | 250 | ;C 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells 251 | ; OVER OVER ; 252 | head TWODUP,4,2DUP,docolon 253 | dw OVER,OVER,EXIT 254 | 255 | ;C 2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram 256 | ; ROT >R ROT R> ; 257 | head TWOSWAP,5,2SWAP,docolon 258 | dw ROT,TOR,ROT,RFROM,EXIT 259 | 260 | ;C 2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 261 | ; >R >R 2DUP R> R> 2SWAP ; 262 | head TWOOVER,5,2OVER,docolon 263 | dw TOR,TOR,TWODUP,RFROM,RFROM 264 | dw TWOSWAP,EXIT 265 | 266 | ; INPUT/OUTPUT ================================== 267 | 268 | ;C COUNT c-addr1 -- c-addr2 u counted->adr/len 269 | ; DUP CHAR+ SWAP C@ ; 270 | head COUNT,5,COUNT,docolon 271 | dw DUP,CHARPLUS,SWOP,CFETCH,EXIT 272 | 273 | ;C CR -- output newline 274 | ; 0D EMIT 0A EMIT ; 275 | head CR,2,CR,docolon 276 | dw lit,0dh,EMIT,lit,0ah,EMIT,EXIT 277 | 278 | ;C SPACE -- output a space 279 | ; BL EMIT ; 280 | head SPACE,5,SPACE,docolon 281 | dw BL,EMIT,EXIT 282 | 283 | ;C SPACES n -- output n spaces 284 | ; BEGIN DUP WHILE SPACE 1- REPEAT DROP ; 285 | head SPACES,6,SPACES,docolon 286 | SPCS1: DW DUP,qbranch,SPCS2 287 | DW SPACE,ONEMINUS,branch,SPCS1 288 | SPCS2: DW DROP,EXIT 289 | 290 | ;Z umin u1 u2 -- u unsigned minimum 291 | ; 2DUP U> IF SWAP THEN DROP ; 292 | head UMIN,4,UMIN,docolon 293 | DW TWODUP,UGREATER,QBRANCH,UMIN1,SWOP 294 | UMIN1: DW DROP,EXIT 295 | 296 | ;Z umax u1 u2 -- u unsigned maximum 297 | ; 2DUP U< IF SWAP THEN DROP ; 298 | head UMAX,4,UMAX,docolon 299 | DW TWODUP,ULESS,QBRANCH,UMAX1,SWOP 300 | UMAX1: DW DROP,EXIT 301 | 302 | ;C ACCEPT c-addr +n -- +n' get line from term'l 303 | ; OVER + 1- OVER -- sa ea a 304 | ; BEGIN KEY -- sa ea a c 305 | ; DUP 0D <> WHILE 306 | ; DUP EMIT -- sa ea a c 307 | ; DUP 8 = IF DROP 1- >R OVER R> UMAX 308 | ; ELSE OVER C! 1+ OVER UMIN 309 | ; THEN -- sa ea a 310 | ; REPEAT -- sa ea a c 311 | ; DROP NIP SWAP - ; 312 | head ACCEPT,6,ACCEPT,docolon 313 | DW OVER,PLUS,ONEMINUS,OVER 314 | ACC1: DW KEY,DUP,LIT,0DH,NOTEQUAL,QBRANCH,ACC5 315 | DW DUP,EMIT,DUP,LIT,8,EQUAL,QBRANCH,ACC3 316 | DW DROP,ONEMINUS,TOR,OVER,RFROM,UMAX 317 | DW BRANCH,ACC4 318 | ACC3: DW OVER,CSTORE,ONEPLUS,OVER,UMIN 319 | ACC4: DW BRANCH,ACC1 320 | ACC5: DW DROP,NIP,SWOP,MINUS,EXIT 321 | 322 | ;C TYPE c-addr +n -- type line to term'l 323 | ; ?DUP IF 324 | ; OVER + SWAP DO I C@ EMIT LOOP 325 | ; ELSE DROP THEN ; 326 | head TYPE,4,TYPE,docolon 327 | DW QDUP,QBRANCH,TYP4 328 | DW OVER,PLUS,SWOP,XDO 329 | TYP3: DW II,CFETCH,EMIT,XLOOP,TYP3 330 | DW BRANCH,TYP5 331 | TYP4: DW DROP 332 | TYP5: DW EXIT 333 | 334 | ;Z (S") -- c-addr u run-time code for S" 335 | ; R> COUNT 2DUP + ALIGNED >R ; 336 | head XSQUOTE,4,(S"),docolon 337 | DW RFROM,COUNT,TWODUP,PLUS,ALIGNED,TOR 338 | DW EXIT 339 | 340 | ;C S" -- compile in-line string 341 | ; COMPILE (S") [ HEX ] 342 | ; 22 WORD C@ 1+ ALIGNED ALLOT ; IMMEDIATE 343 | immed SQUOTE,2,S",docolon 344 | DW LIT,XSQUOTE,COMMAXT 345 | DW LIT,22H,WORD,CFETCH,ONEPLUS 346 | DW ALIGNED,ALLOT,EXIT 347 | 348 | ;C ." -- compile string to print 349 | ; POSTPONE S" POSTPONE TYPE ; IMMEDIATE 350 | immed DOTQUOTE,2,.",docolon 351 | DW SQUOTE 352 | DW LIT,TYPE,COMMAXT 353 | DW EXIT 354 | 355 | ; NUMERIC OUTPUT ================================ 356 | ; Numeric conversion is done l.s.digit first, so 357 | ; the output buffer is built backwards in memory. 358 | 359 | ; Some double-precision arithmetic operators are 360 | ; needed to implement ANSI numeric conversion. 361 | 362 | ;Z UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide 363 | ; >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ; 364 | head UDSLASHMOD,6,UD/MOD,docolon 365 | DW TOR,LIT,0,RFETCH,UMSLASHMOD,ROT,ROT 366 | DW RFROM,UMSLASHMOD,ROT,EXIT 367 | 368 | ;Z UD* ud1 d2 -- ud3 32*16->32 multiply 369 | ; DUP >R UM* DROP SWAP R> UM* ROT + ; 370 | head UDSTAR,3,UD*,docolon 371 | DW DUP,TOR,UMSTAR,DROP 372 | DW SWOP,RFROM,UMSTAR,ROT,PLUS,EXIT 373 | 374 | ;C HOLD char -- add char to output string 375 | ; -1 HP +! HP @ C! ; 376 | head HOLD,4,HOLD,docolon 377 | DW LIT,-1,HP,PLUSSTORE 378 | DW HP,FETCH,CSTORE,EXIT 379 | 380 | ;C <# -- begin numeric conversion 381 | ; PAD HP ! ; (initialize Hold Pointer) 382 | head LESSNUM,2,<#,docolon 383 | DW PAD,HP,STORE,EXIT 384 | 385 | ;Z >digit n -- c convert to 0..9A..Z 386 | ; [ HEX ] DUP 9 > 7 AND + 30 + ; 387 | head TODIGIT,6,>DIGIT,docolon 388 | DW DUP,LIT,9,GREATER,LIT,7,AND,PLUS 389 | DW LIT,30H,PLUS,EXIT 390 | 391 | ;C # ud1 -- ud2 convert 1 digit of output 392 | ; BASE @ UD/MOD ROT >digit HOLD ; 393 | head NUM,1,#,docolon 394 | DW BASE,FETCH,UDSLASHMOD,ROT,TODIGIT 395 | DW HOLD,EXIT 396 | 397 | ;C #S ud1 -- ud2 convert remaining digits 398 | ; BEGIN # 2DUP OR 0= UNTIL ; 399 | head NUMS,2,#S,docolon 400 | NUMS1: DW NUM,TWODUP,OR,ZEROEQUAL,qbranch,NUMS1 401 | DW EXIT 402 | 403 | ;C #> ud1 -- c-addr u end conv., get string 404 | ; 2DROP HP @ PAD OVER - ; 405 | head NUMGREATER,2,#>,docolon 406 | DW TWODROP,HP,FETCH,PAD,OVER,MINUS,EXIT 407 | 408 | ;C SIGN n -- add minus sign if n<0 409 | ; 0< IF 2D HOLD THEN ; 410 | head SIGN,4,SIGN,docolon 411 | DW ZEROLESS,qbranch,SIGN1,LIT,2DH,HOLD 412 | SIGN1: DW EXIT 413 | 414 | ;C U. u -- display u unsigned 415 | ; <# 0 #S #> TYPE SPACE ; 416 | head UDOT,2,U.,docolon 417 | DW LESSNUM,LIT,0,NUMS,NUMGREATER,TYPE 418 | DW SPACE,EXIT 419 | 420 | ;C . n -- display n signed 421 | ; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ; 422 | head DOT,1,'.',docolon 423 | DW LESSNUM,DUP,ABS,LIT,0,NUMS 424 | DW ROT,SIGN,NUMGREATER,TYPE,SPACE,EXIT 425 | 426 | ;C DECIMAL -- set number base to decimal 427 | ; 10 BASE ! ; 428 | head DECIMAL,7,DECIMAL,docolon 429 | DW LIT,10,BASE,STORE,EXIT 430 | 431 | ;X HEX -- set number base to hex 432 | ; 16 BASE ! ; 433 | head HEX,3,HEX,docolon 434 | DW LIT,16,BASE,STORE,EXIT 435 | 436 | ; DICTIONARY MANAGEMENT ========================= 437 | 438 | ;C HERE -- addr returns dictionary ptr 439 | ; DP @ ; 440 | head HERE,4,HERE,docolon 441 | dw DP,FETCH,EXIT 442 | 443 | ;C ALLOT n -- allocate n bytes in dict 444 | ; DP +! ; 445 | head ALLOT,5,ALLOT,docolon 446 | dw DP,PLUSSTORE,EXIT 447 | 448 | ; Note: , and C, are only valid for combined 449 | ; Code and Data spaces. 450 | 451 | ;C , x -- append cell to dict 452 | ; HERE ! 1 CELLS ALLOT ; 453 | head COMMA,1,',',docolon 454 | dw HERE,STORE,lit,1,CELLS,ALLOT,EXIT 455 | 456 | ;C C, char -- append char to dict 457 | ; HERE C! 1 CHARS ALLOT ; 458 | head CCOMMA,2,'C,',docolon 459 | dw HERE,CSTORE,lit,1,CHARS,ALLOT,EXIT 460 | 461 | ; INTERPRETER =================================== 462 | ; Note that NFA>LFA, NFA>CFA, IMMED?, and FIND 463 | ; are dependent on the structure of the Forth 464 | ; header. This may be common across many CPUs, 465 | ; or it may be different. 466 | 467 | ;C SOURCE -- adr n current input buffer 468 | ; 'SOURCE 2@ ; length is at lower adrs 469 | head SOURCE,6,SOURCE,docolon 470 | DW TICKSOURCE,TWOFETCH,EXIT 471 | 472 | ;X /STRING a u n -- a+n u-n trim string 473 | ; ROT OVER + ROT ROT - ; 474 | head SLASHSTRING,7,/STRING,docolon 475 | DW ROT,OVER,PLUS,ROT,ROT,MINUS,EXIT 476 | 477 | ;Z >counted src n dst -- copy to counted str 478 | ; 2DUP C! CHAR+ SWAP CMOVE ; 479 | head TOCOUNTED,8,>COUNTED,docolon 480 | DW TWODUP,CSTORE,CHARPLUS,SWOP,CMOVE,EXIT 481 | 482 | ;C WORD char -- c-addr n word delim'd by char 483 | ; DUP SOURCE >IN @ /STRING -- c c adr n 484 | ; DUP >R ROT SKIP -- c adr' n' 485 | ; OVER >R ROT SCAN -- adr" n" 486 | ; DUP IF CHAR- THEN skip trailing delim. 487 | ; R> R> ROT - >IN +! update >IN offset 488 | ; TUCK - -- adr' N 489 | ; HERE >counted -- 490 | ; HERE -- a 491 | ; BL OVER COUNT + C! ; append trailing blank 492 | head WORD,4,WORD,docolon 493 | DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING 494 | DW DUP,TOR,ROT,SKIP 495 | DW OVER,TOR,ROT,SCAN 496 | DW DUP,qbranch,WORD1,ONEMINUS ; char- 497 | WORD1: DW RFROM,RFROM,ROT,MINUS,TOIN,PLUSSTORE 498 | DW TUCK,MINUS 499 | DW HERE,TOCOUNTED,HERE 500 | DW BL,OVER,COUNT,PLUS,CSTORE,EXIT 501 | 502 | ;Z NFA>LFA nfa -- lfa name adr -> link field 503 | ; 3 - ; 504 | head NFATOLFA,7,NFA>LFA,docolon 505 | DW LIT,3,MINUS,EXIT 506 | 507 | ;Z NFA>CFA nfa -- cfa name adr -> code field 508 | ; COUNT 7F AND + ; mask off 'smudge' bit 509 | head NFATOCFA,7,NFA>CFA,docolon 510 | DW COUNT,LIT,07FH,AND,PLUS,EXIT 511 | 512 | ;Z IMMED? nfa -- f fetch immediate flag 513 | ; 1- C@ ; nonzero if immed 514 | head IMMEDQ,6,IMMED?,docolon 515 | DW ONEMINUS,CFETCH,EXIT 516 | 517 | ;C FIND c-addr -- c-addr 0 if not found 518 | ;C xt 1 if immediate 519 | ;C xt -1 if "normal" 520 | ; LATEST @ BEGIN -- a nfa 521 | ; 2DUP OVER C@ CHAR+ -- a nfa a nfa n+1 522 | ; S= -- a nfa f 523 | ; DUP IF 524 | ; DROP 525 | ; NFA>LFA @ DUP -- a link link 526 | ; THEN 527 | ; 0= UNTIL -- a nfa OR a 0 528 | ; DUP IF 529 | ; NIP DUP NFA>CFA -- nfa xt 530 | ; SWAP IMMED? -- xt iflag 531 | ; 0= 1 OR -- xt 1/-1 532 | ; THEN ; 533 | head FIND,4,FIND,docolon 534 | DW LATEST,FETCH 535 | FIND1: DW TWODUP,OVER,CFETCH,CHARPLUS 536 | DW SEQUAL,DUP,qbranch,FIND2 537 | DW DROP,NFATOLFA,FETCH,DUP 538 | FIND2: DW ZEROEQUAL,qbranch,FIND1 539 | DW DUP,qbranch,FIND3 540 | DW NIP,DUP,NFATOCFA 541 | DW SWOP,IMMEDQ,ZEROEQUAL,LIT,1,OR 542 | FIND3: DW EXIT 543 | 544 | ;C LITERAL x -- append numeric literal 545 | ; STATE @ IF ['] LIT ,XT , THEN ; IMMEDIATE 546 | ; This tests STATE so that it can also be used 547 | ; interpretively. (ANSI doesn't require this.) 548 | immed LITERAL,7,LITERAL,docolon 549 | DW STATE,FETCH,qbranch,LITER1 550 | DW LIT,LIT,COMMAXT,COMMA 551 | LITER1: DW EXIT 552 | 553 | ;Z DIGIT? c -- n -1 if c is a valid digit 554 | ;Z -- x 0 otherwise 555 | ; [ HEX ] DUP 39 > 100 AND + silly looking 556 | ; DUP 140 > 107 AND - 30 - but it works! 557 | ; DUP BASE @ U< ; 558 | head DIGITQ,6,DIGIT?,docolon 559 | DW DUP,LIT,39H,GREATER,LIT,100H,AND,PLUS 560 | DW DUP,LIT,140H,GREATER,LIT,107H,AND 561 | DW MINUS,LIT,30H,MINUS 562 | DW DUP,BASE,FETCH,ULESS,EXIT 563 | 564 | ;Z ?SIGN adr n -- adr' n' f get optional sign 565 | ;Z advance adr/n if sign; return NZ if negative 566 | ; OVER C@ -- adr n c 567 | ; 2C - DUP ABS 1 = AND -- +=-1, -=+1, else 0 568 | ; DUP IF 1+ -- +=0, -=+2 569 | ; >R 1 /STRING R> -- adr' n' f 570 | ; THEN ; 571 | head QSIGN,5,?SIGN,docolon 572 | DW OVER,CFETCH,LIT,2CH,MINUS,DUP,ABS 573 | DW LIT,1,EQUAL,AND,DUP,qbranch,QSIGN1 574 | DW ONEPLUS,TOR,LIT,1,SLASHSTRING,RFROM 575 | QSIGN1: DW EXIT 576 | 577 | ;C >NUMBER ud adr u -- ud' adr' u' 578 | ;C convert string to number 579 | ; BEGIN 580 | ; DUP WHILE 581 | ; OVER C@ DIGIT? 582 | ; 0= IF DROP EXIT THEN 583 | ; >R 2SWAP BASE @ UD* 584 | ; R> M+ 2SWAP 585 | ; 1 /STRING 586 | ; REPEAT ; 587 | head TONUMBER,7,>NUMBER,docolon 588 | TONUM1: DW DUP,qbranch,TONUM3 589 | DW OVER,CFETCH,DIGITQ 590 | DW ZEROEQUAL,qbranch,TONUM2,DROP,EXIT 591 | TONUM2: DW TOR,TWOSWAP,BASE,FETCH,UDSTAR 592 | DW RFROM,MPLUS,TWOSWAP 593 | DW LIT,1,SLASHSTRING,branch,TONUM1 594 | TONUM3: DW EXIT 595 | 596 | ;Z ?NUMBER c-addr -- n -1 string->number 597 | ;Z -- c-addr 0 if convert error 598 | ; DUP 0 0 ROT COUNT -- ca ud adr n 599 | ; ?SIGN >R >NUMBER -- ca ud adr' n' 600 | ; IF R> 2DROP 2DROP 0 -- ca 0 (error) 601 | ; ELSE 2DROP NIP R> 602 | ; IF NEGATE THEN -1 -- n -1 (ok) 603 | ; THEN ; 604 | head QNUMBER,7,?NUMBER,docolon 605 | DW DUP,LIT,0,DUP,ROT,COUNT 606 | DW QSIGN,TOR,TONUMBER,qbranch,QNUM1 607 | DW RFROM,TWODROP,TWODROP,LIT,0 608 | DW branch,QNUM3 609 | QNUM1: DW TWODROP,NIP,RFROM,qbranch,QNUM2,NEGATE 610 | QNUM2: DW LIT,-1 611 | QNUM3: DW EXIT 612 | 613 | ;Z INTERPRET i*x c-addr u -- j*x 614 | ;Z interpret given buffer 615 | ; This is a common factor of EVALUATE and QUIT. 616 | ; ref. dpANS-6, 3.4 The Forth Text Interpreter 617 | ; 'SOURCE 2! 0 >IN ! 618 | ; BEGIN 619 | ; BL WORD DUP C@ WHILE -- textadr 620 | ; FIND -- a 0/1/-1 621 | ; ?DUP IF -- xt 1/-1 622 | ; 1+ STATE @ 0= OR immed or interp? 623 | ; IF EXECUTE ELSE ,XT THEN 624 | ; ELSE -- textadr 625 | ; ?NUMBER 626 | ; IF POSTPONE LITERAL converted ok 627 | ; ELSE COUNT TYPE 3F EMIT CR ABORT err 628 | ; THEN 629 | ; THEN 630 | ; REPEAT DROP ; 631 | head INTERPRET,9,INTERPRET,docolon 632 | DW TICKSOURCE,TWOSTORE,LIT,0,TOIN,STORE 633 | INTER1: DW BL,WORD,DUP,CFETCH,qbranch,INTER9 634 | DW FIND,QDUP,qbranch,INTER4 635 | DW ONEPLUS,STATE,FETCH,ZEROEQUAL,OR 636 | DW qbranch,INTER2 637 | DW EXECUTE,branch,INTER3 638 | INTER2: DW COMMAXT 639 | INTER3: DW branch,INTER8 640 | INTER4: DW QNUMBER,qbranch,INTER5 641 | DW LITERAL,branch,INTER6 642 | INTER5: DW COUNT,TYPE,LIT,3FH,EMIT,CR,ABORT 643 | INTER6: 644 | INTER8: DW branch,INTER1 645 | INTER9: DW DROP,EXIT 646 | 647 | ;C EVALUATE i*x c-addr u -- j*x interprt string 648 | ; 'SOURCE 2@ >R >R >IN @ >R 649 | ; INTERPRET 650 | ; R> >IN ! R> R> 'SOURCE 2! ; 651 | head EVALUATE,8,EVALUATE,docolon 652 | DW TICKSOURCE,TWOFETCH,TOR,TOR 653 | DW TOIN,FETCH,TOR,INTERPRET 654 | DW RFROM,TOIN,STORE,RFROM,RFROM 655 | DW TICKSOURCE,TWOSTORE,EXIT 656 | 657 | ;C QUIT -- R: i*x -- interpret from kbd 658 | ; L0 LP ! R0 RP! 0 STATE ! 659 | ; BEGIN 660 | ; TIB DUP TIBSIZE ACCEPT SPACE 661 | ; INTERPRET 662 | ; STATE @ 0= IF CR ." OK" THEN 663 | ; AGAIN ; 664 | head QUIT,4,QUIT,docolon 665 | DW L0,LP,STORE 666 | DW R0,RPSTORE,LIT,0,STATE,STORE 667 | QUIT1: DW TIB,DUP,TIBSIZE,CPMACCEPT,SPACE 668 | DW INTERPRET 669 | DW STATE,FETCH,ZEROEQUAL,qbranch,QUIT2 670 | DW CR,XSQUOTE 671 | DB 3,'ok ' 672 | DW TYPE 673 | QUIT2: DW branch,QUIT1 674 | 675 | ;C ABORT i*x -- R: j*x -- clear stk & QUIT 676 | ; S0 SP! QUIT ; 677 | head ABORT,5,ABORT,docolon 678 | DW S0,SPSTORE,QUIT ; QUIT never returns 679 | 680 | ;Z ?ABORT f c-addr u -- abort & print msg 681 | ; ROT IF TYPE ABORT THEN 2DROP ; 682 | head QABORT,6,?ABORT,docolon 683 | DW ROT,qbranch,QABO1,TYPE,ABORT 684 | QABO1: DW TWODROP,EXIT 685 | 686 | ;C ABORT" i*x 0 -- i*x R: j*x -- j*x x1=0 687 | ;C i*x x1 -- R: j*x -- x1<>0 688 | ; POSTPONE S" POSTPONE ?ABORT ; IMMEDIATE 689 | immed ABORTQUOTE,6,ABORT",docolon 690 | DW SQUOTE 691 | DW LIT,QABORT,COMMAXT 692 | DW EXIT 693 | 694 | ;C ' -- xt find word in dictionary 695 | ; BL WORD FIND 696 | ; 0= ABORT" ?" ; 697 | ; head TICK,1,',docolon 698 | DW link ; must expand 699 | DB 0 ; manually 700 | link DEFL $ ; because of 701 | DB 1,27h ; tick character 702 | TICK: call docolon 703 | DW BL,WORD,FIND,ZEROEQUAL,XSQUOTE 704 | DB 1,'?' 705 | DW QABORT,EXIT 706 | 707 | ;C CHAR -- char parse ASCII character 708 | ; BL WORD 1+ C@ ; 709 | head CHAR,4,CHAR,docolon 710 | DW BL,WORD,ONEPLUS,CFETCH,EXIT 711 | 712 | ;C [CHAR] -- compile character literal 713 | ; CHAR ['] LIT ,XT , ; IMMEDIATE 714 | immed BRACCHAR,6,[CHAR],docolon 715 | DW CHAR 716 | DW LIT,LIT,COMMAXT 717 | DW COMMA,EXIT 718 | 719 | ;C ( -- skip input until ) 720 | ; [ HEX ] 29 WORD DROP ; IMMEDIATE 721 | immed PAREN,1,(,docolon 722 | DW LIT,29H,WORD,DROP,EXIT 723 | 724 | ; COMPILER ====================================== 725 | 726 | ;C CREATE -- create an empty definition 727 | ; LATEST @ , 0 C, link & immed field 728 | ; HERE LATEST ! new "latest" link 729 | ; BL WORD C@ 1+ ALLOT name field 730 | ; docreate ,CF code field 731 | head CREATE,6,CREATE,docolon 732 | DW LATEST,FETCH,COMMA,LIT,0,CCOMMA 733 | DW HERE,LATEST,STORE 734 | DW BL,WORD,CFETCH,ONEPLUS,ALLOT 735 | DW LIT,docreate,COMMACF,EXIT 736 | 737 | ;Z (DOES>) -- run-time action of DOES> 738 | ; R> adrs of headless DOES> def'n 739 | ; LATEST @ NFA>CFA code field to fix up 740 | ; !CF ; 741 | head XDOES,7,(DOES>),docolon 742 | DW RFROM,LATEST,FETCH,NFATOCFA,STORECF 743 | DW EXIT 744 | 745 | ;C DOES> -- change action of latest def'n 746 | ; COMPILE (DOES>) 747 | ; dodoes ,CF ; IMMEDIATE 748 | immed DOES,5,DOES>,docolon 749 | DW LIT,XDOES,COMMAXT 750 | DW LIT,dodoes,COMMACF,EXIT 751 | 752 | ;C RECURSE -- recurse current definition 753 | ; LATEST @ NFA>CFA ,XT ; IMMEDIATE 754 | immed RECURSE,7,RECURSE,docolon 755 | DW LATEST,FETCH,NFATOCFA,COMMAXT,EXIT 756 | 757 | ;C [ -- enter interpretive state 758 | ; 0 STATE ! ; IMMEDIATE 759 | immed LEFTBRACKET,1,[,docolon 760 | DW LIT,0,STATE,STORE,EXIT 761 | 762 | ;C ] -- enter compiling state 763 | ; -1 STATE ! ; 764 | head RIGHTBRACKET,1,],docolon 765 | DW LIT,-1,STATE,STORE,EXIT 766 | 767 | ;Z HIDE -- "hide" latest definition 768 | ; LATEST @ DUP C@ 80 OR SWAP C! ; 769 | head HIDE,4,HIDE,docolon 770 | DW LATEST,FETCH,DUP,CFETCH,LIT,80H,OR 771 | DW SWOP,CSTORE,EXIT 772 | 773 | ;Z REVEAL -- "reveal" latest definition 774 | ; LATEST @ DUP C@ 7F AND SWAP C! ; 775 | head REVEAL,6,REVEAL,docolon 776 | DW LATEST,FETCH,DUP,CFETCH,LIT,7FH,AND 777 | DW SWOP,CSTORE,EXIT 778 | 779 | ;C IMMEDIATE -- make last def'n immediate 780 | ; 1 LATEST @ 1- C! ; set immediate flag 781 | head IMMEDIATE,9,IMMEDIATE,docolon 782 | DW LIT,1,LATEST,FETCH,ONEMINUS,CSTORE 783 | DW EXIT 784 | 785 | ;C : -- begin a colon definition 786 | ; CREATE HIDE ] !COLON ; 787 | head COLON,1,:,docode 788 | CALL docolon ; code fwd ref explicitly 789 | DW CREATE,HIDE,RIGHTBRACKET,STORCOLON 790 | DW EXIT 791 | 792 | ;C ; 793 | ; REVEAL ,EXIT 794 | ; POSTPONE [ ; IMMEDIATE 795 | immed SEMICOLON,1,';',docolon 796 | DW REVEAL,CEXIT 797 | DW LEFTBRACKET,EXIT 798 | 799 | ;C ['] -- find word & compile as literal 800 | ; ' ['] LIT ,XT , ; IMMEDIATE 801 | ; When encountered in a colon definition, the 802 | ; phrase ['] xxx will cause LIT,xxt to be 803 | ; compiled into the colon definition (where 804 | ; (where xxt is the execution token of word xxx). 805 | ; When the colon definition executes, xxt will 806 | ; be put on the stack. (All xt's are one cell.) 807 | ; immed BRACTICK,3,['],docolon 808 | DW link ; must expand 809 | DB 1 ; manually 810 | link DEFL $ ; because of 811 | DB 3,5Bh,27h,5Dh ; tick character 812 | BRACTICK: call docolon 813 | DW TICK ; get xt of 'xxx' 814 | DW LIT,LIT,COMMAXT ; append LIT action 815 | DW COMMA,EXIT ; append xt literal 816 | 817 | ;C POSTPONE -- postpone compile action of word 818 | ; BL WORD FIND 819 | ; DUP 0= ABORT" ?" 820 | ; 0< IF -- xt non immed: add code to current 821 | ; def'n to compile xt later. 822 | ; ['] LIT ,XT , add "LIT,xt,COMMAXT" 823 | ; ['] ,XT ,XT to current definition 824 | ; ELSE ,XT immed: compile into cur. def'n 825 | ; THEN ; IMMEDIATE 826 | immed POSTPONE,8,POSTPONE,docolon 827 | DW BL,WORD,FIND,DUP,ZEROEQUAL,XSQUOTE 828 | DB 1,'?' 829 | DW QABORT,ZEROLESS,qbranch,POST1 830 | DW LIT,LIT,COMMAXT,COMMA 831 | DW LIT,COMMAXT,COMMAXT,branch,POST2 832 | POST1: DW COMMAXT 833 | POST2: DW EXIT 834 | 835 | ;Z COMPILE -- append inline execution token 836 | ; R> DUP CELL+ >R @ ,XT ; 837 | ; The phrase ['] xxx ,XT appears so often that 838 | ; this word was created to combine the actions 839 | ; of LIT and ,XT. It takes an inline literal 840 | ; execution token and appends it to the dict. 841 | ; head COMPILE,7,COMPILE,docolon 842 | ; DW RFROM,DUP,CELLPLUS,TOR 843 | ; DW FETCH,COMMAXT,EXIT 844 | ; N.B.: not used in the current implementation 845 | 846 | ; CONTROL STRUCTURES ============================ 847 | 848 | ;C IF -- adrs conditional forward branch 849 | ; ['] qbranch ,BRANCH HERE DUP ,DEST ; 850 | ; IMMEDIATE 851 | immed IF,2,IF,docolon 852 | DW LIT,qbranch,COMMABRANCH 853 | DW HERE,DUP,COMMADEST,EXIT 854 | 855 | ;C THEN adrs -- resolve forward branch 856 | ; HERE SWAP !DEST ; IMMEDIATE 857 | immed THEN,4,THEN,docolon 858 | DW HERE,SWOP,STOREDEST,EXIT 859 | 860 | ;C ELSE adrs1 -- adrs2 branch for IF..ELSE 861 | ; ['] branch ,BRANCH HERE DUP ,DEST 862 | ; SWAP POSTPONE THEN ; IMMEDIATE 863 | immed ELSE,4,ELSE,docolon 864 | DW LIT,branch,COMMABRANCH 865 | DW HERE,DUP,COMMADEST 866 | DW SWOP,THEN,EXIT 867 | 868 | ;C BEGIN -- adrs target for bwd. branch 869 | ; HERE ; IMMEDIATE 870 | immed BEGIN,5,BEGIN,docode 871 | jp HERE 872 | 873 | ;C UNTIL adrs -- conditional backward branch 874 | ; ['] qbranch ,BRANCH ,DEST ; IMMEDIATE 875 | ; conditional backward branch 876 | immed UNTIL,5,UNTIL,docolon 877 | DW LIT,qbranch,COMMABRANCH 878 | DW COMMADEST,EXIT 879 | 880 | ;X AGAIN adrs -- uncond'l backward branch 881 | ; ['] branch ,BRANCH ,DEST ; IMMEDIATE 882 | ; unconditional backward branch 883 | immed AGAIN,5,AGAIN,docolon 884 | DW LIT,branch,COMMABRANCH 885 | DW COMMADEST,EXIT 886 | 887 | ;C WHILE -- adrs branch for WHILE loop 888 | ; POSTPONE IF ; IMMEDIATE 889 | immed WHILE,5,WHILE,docode 890 | jp IF 891 | 892 | ;C REPEAT adrs1 adrs2 -- resolve WHILE loop 893 | ; SWAP POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE 894 | immed REPEAT,6,REPEAT,docolon 895 | DW SWOP,AGAIN,THEN,EXIT 896 | 897 | ;Z >L x -- L: -- x move to leave stack 898 | ; CELL LP +! LP @ ! ; (L stack grows up) 899 | head TOL,2,>L,docolon 900 | DW CELL,LP,PLUSSTORE,LP,FETCH,STORE,EXIT 901 | 902 | ;Z L> -- x L: x -- move from leave stack 903 | ; LP @ @ CELL NEGATE LP +! ; 904 | head LFROM,2,L>,docolon 905 | DW LP,FETCH,FETCH 906 | DW CELL,NEGATE,LP,PLUSSTORE,EXIT 907 | 908 | ;C DO -- adrs L: -- 0 909 | ; ['] xdo ,XT HERE target for bwd branch 910 | ; 0 >L ; IMMEDIATE marker for LEAVEs 911 | immed DO,2,DO,docolon 912 | DW LIT,xdo,COMMAXT,HERE 913 | DW LIT,0,TOL,EXIT 914 | 915 | ;Z ENDLOOP adrs xt -- L: 0 a1 a2 .. aN -- 916 | ; ,BRANCH ,DEST backward loop 917 | ; BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ; 918 | ; resolve LEAVEs 919 | ; This is a common factor of LOOP and +LOOP. 920 | head ENDLOOP,7,ENDLOOP,docolon 921 | DW COMMABRANCH,COMMADEST 922 | LOOP1: DW LFROM,QDUP,qbranch,LOOP2 923 | DW THEN,branch,LOOP1 924 | LOOP2: DW EXIT 925 | 926 | ;C LOOP adrs -- L: 0 a1 a2 .. aN -- 927 | ; ['] xloop ENDLOOP ; IMMEDIATE 928 | immed LOOP,4,LOOP,docolon 929 | DW LIT,xloop,ENDLOOP,EXIT 930 | 931 | ;C +LOOP adrs -- L: 0 a1 a2 .. aN -- 932 | ; ['] xplusloop ENDLOOP ; IMMEDIATE 933 | immed PLUSLOOP,5,+LOOP,docolon 934 | DW LIT,xplusloop,ENDLOOP,EXIT 935 | 936 | ;C LEAVE -- L: -- adrs 937 | ; ['] UNLOOP ,XT 938 | ; ['] branch ,BRANCH HERE DUP ,DEST >L 939 | ; ; IMMEDIATE unconditional forward branch 940 | immed LEAVE,5,LEAVE,docolon 941 | DW LIT,unloop,COMMAXT 942 | DW LIT,branch,COMMABRANCH 943 | DW HERE,DUP,COMMADEST,TOL,EXIT 944 | 945 | ; OTHER OPERATIONS ============================== 946 | 947 | ;X WITHIN n1|u1 n2|u2 n3|u3 -- f n2<=n1R - R> U< ; per ANS document 949 | head WITHIN,6,WITHIN,docolon 950 | DW OVER,MINUS,TOR,MINUS,RFROM,ULESS,EXIT 951 | 952 | ;C MOVE addr1 addr2 u -- smart move 953 | ; VERSION FOR 1 ADDRESS UNIT = 1 CHAR 954 | ; >R 2DUP SWAP DUP R@ + -- ... dst src src+n 955 | ; WITHIN IF R> CMOVE> src <= dst < src+n 956 | ; ELSE R> CMOVE THEN ; otherwise 957 | head MOVE,4,MOVE,docolon 958 | DW TOR,TWODUP,SWOP,DUP,RFETCH,PLUS 959 | DW WITHIN,qbranch,MOVE1 960 | DW RFROM,CMOVEUP,branch,MOVE2 961 | MOVE1: DW RFROM,CMOVE 962 | MOVE2: DW EXIT 963 | 964 | ;C DEPTH -- +n number of items on stack 965 | ; SP@ S0 SWAP - 2/ ; 16-BIT VERSION! 966 | head DEPTH,5,DEPTH,docolon 967 | DW SPFETCH,S0,SWOP,MINUS,TWOSLASH,EXIT 968 | 969 | ;C ENVIRONMENT? c-addr u -- false system query 970 | ; -- i*x true 971 | ; 2DROP 0 ; the minimal definition! 972 | head ENVIRONMENTQ,12,ENVIRONMENT?,docolon 973 | DW TWODROP,LIT,0,EXIT 974 | 975 | ; UTILITY WORDS AND STARTUP ===================== 976 | 977 | ;X WORDS -- list all words in dict. 978 | ; LATEST @ BEGIN 979 | ; DUP COUNT TYPE SPACE 980 | ; NFA>LFA @ 981 | ; DUP 0= UNTIL 982 | ; DROP ; 983 | head WORDS,5,WORDS,docolon 984 | DW LATEST,FETCH 985 | WDS1: DW DUP,COUNT,TYPE,SPACE,NFATOLFA,FETCH 986 | DW DUP,ZEROEQUAL,qbranch,WDS1 987 | DW DROP,EXIT 988 | 989 | ;X .S -- print stack contents 990 | ; SP@ S0 - IF 991 | ; SP@ S0 2 - DO I @ U. -2 +LOOP 992 | ; THEN ; 993 | head DOTS,2,.S,docolon 994 | DW SPFETCH,S0,MINUS,qbranch,DOTS2 995 | DW SPFETCH,S0,LIT,2,MINUS,XDO 996 | DOTS1: DW II,FETCH,UDOT,LIT,-2,XPLUSLOOP,DOTS1 997 | DOTS2: DW EXIT 998 | 999 | ;Z COLD -- cold start Forth system 1000 | ; UINIT U0 #INIT CMOVE init user area 1001 | ; 80 COUNT INTERPRET interpret CP/M cmd 1002 | ; ." Z80 CamelForth etc." 1003 | ; ABORT ; 1004 | head COLD,4,COLD,docolon 1005 | DW UINIT,U0,NINIT,CMOVE 1006 | DW LIT,80h,COUNT,INTERPRET 1007 | DW XSQUOTE 1008 | DB 35,'Z80 CamelForth v1.01 25 Jan 1995' 1009 | DB 0dh,0ah 1010 | DW TYPE,ABORT ; ABORT never returns 1011 | 1012 | -------------------------------------------------------------------------------- /source/cam80-12/CAMELTST.AZM: -------------------------------------------------------------------------------- 1 | ; Listing 1. 2 | ; =============================================== 3 | ; CamelForth for the Zilog Z80 4 | ; Primitive testing code 5 | ; 6 | ; This is the "minimal" test of the CamelForth 7 | ; kernel. It verifies the threading and nesting 8 | ; mechanisms, the stacks, and the primitives 9 | ; DUP EMIT EXIT lit branch ONEPLUS. 10 | ; It is particularly useful because it does not 11 | ; use the DO..LOOP, multiply, or divide words, 12 | ; and because it can be used on embedded CPUs. 13 | ; The numeric display word .A is also useful 14 | ; for testing the rest of the Core wordset. 15 | ; 16 | ; The required macros and CPU initialization 17 | ; are in file CAMEL80.AZM. 18 | ; =============================================== 19 | 20 | ;Z >< u1 -- u2 swap the bytes of TOS 21 | head SWAB,2,><,docode 22 | ld a,b 23 | ld b,c 24 | ld c,a 25 | next 26 | 27 | ;Z LO c1 -- c2 return low nybble of TOS 28 | head LO,2,LO,docode 29 | ld a,c 30 | and 0fh 31 | ld c,a 32 | ld b,0 33 | next 34 | 35 | ;Z HI c1 -- c2 return high nybble of TOS 36 | head HI,2,HI,docode 37 | ld a,c 38 | and 0f0h 39 | rrca 40 | rrca 41 | rrca 42 | rrca 43 | ld c,a 44 | ld b,0 45 | next 46 | 47 | ;Z >HEX c1 -- c2 convert nybble to hex char 48 | head TOHEX,4,>HEX,docode 49 | ld a,c 50 | sub 0ah 51 | jr c,numeric 52 | add a,7 53 | numeric: add a,3ah 54 | ld c,a 55 | next 56 | 57 | ;Z .HH c -- print byte as 2 hex digits 58 | ; DUP HI >HEX EMIT LO >HEX EMIT ; 59 | head DOTHH,3,.HH,docolon 60 | DW DUP,HI,TOHEX,EMIT,LO,TOHEX,EMIT,EXIT 61 | 62 | ;Z .B a -- a+1 fetch & print byte, advancing 63 | ; DUP C@ .HH 20 EMIT 1+ ; 64 | head DOTB,2,.B,docolon 65 | DW DUP,CFETCH,DOTHH,lit,20h,EMIT,ONEPLUS,EXIT 66 | 67 | ;Z .A u -- print unsigned as 4 hex digits 68 | ; DUP >< .HH .HH 20 EMIT ; 69 | head DOTA,2,.A,docolon 70 | DW DUP,SWAB,DOTHH,DOTHH,lit,20h,EMIT,EXIT 71 | 72 | ;X DUMP addr u -- dump u locations at addr 73 | ; 0 DO 74 | ; I 15 AND 0= IF CR DUP .A THEN 75 | ; .B 76 | ; LOOP DROP ; 77 | head DUMP,4,DUMP,docolon 78 | DW LIT,0,XDO 79 | DUMP2: DW II,LIT,15,AND,ZEROEQUAL,qbranch,DUMP1 80 | DW CR,DUP,DOTA 81 | DUMP1: DW DOTB,XLOOP,DUMP2,DROP,EXIT 82 | 83 | ;Z ZQUIT -- endless dump for testing 84 | ; 0 BEGIN 0D EMIT 0A EMIT DUP .A 85 | ; .B .B .B .B .B .B .B .B 86 | ; .B .B .B .B .B .B .B .B 87 | ; AGAIN ; 88 | head ZQUIT,5,ZQUIT,docolon 89 | DW lit,0 90 | zquit1: DW lit,0dh,EMIT,lit,0ah,EMIT,DUP,DOTA 91 | DW DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB 92 | DW DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB 93 | DW branch,zquit1 94 | -------------------------------------------------------------------------------- /source/cam80-12/CAMLDUMP.AZM: -------------------------------------------------------------------------------- 1 | ;Z DUMP adr n -- +++TEMP+++ 2 | ; 1 UMAX 0 DO .B LOOP DROP ; 3 | head DUMP,4,DUMP,docolon 4 | DW LIT,1,UMAX,LIT,0,XDO 5 | DUMP1: DW DOTB,XLOOP,DUMP1 6 | DW DROP,EXIT 7 | 8 | -------------------------------------------------------------------------------- /source/cam80-12/GLOSSHI.TXT: -------------------------------------------------------------------------------- 1 | TABLE 1. GLOSSARY OF "HIGH LEVEL" WORDS 2 | (files CAMEL80D.AZM and CAMEL80H.AZM) 3 | 4 | NAME stack in -- stack out description 5 | 6 | Guide to stack diagrams: R: = return stack, 7 | c = 8-bit character, flag = boolean (0 or -1), 8 | n = signed 16-bit, u = unsigned 16-bit, 9 | d = signed 32-bit, ud = unsigned 32-bit, 10 | +n = unsigned 15-bit, x = any cell value, 11 | i*x j*x = any number of cell values, 12 | a-addr = aligned adrs, c-addr = character adrs 13 | p-addr = I/O port adrs, sys = system-specific. 14 | Refer to ANS Forth document for more details. 15 | 16 | ANS Forth Core words 17 | These are required words whose definitions are 18 | specified by the ANS Forth document. 19 | 20 | # ud1 -- ud2 convert 1 digit of output 21 | #S ud1 -- ud2 convert remaining digits 22 | #> ud1 -- c-addr u end conv., get string 23 | ' -- xt find word in dictionary 24 | ( -- skip input until ) 25 | * n1 n2 -- n3 signed multiply 26 | */ n1 n2 n3 -- n4 n1*n2/n3 27 | */MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem & quot 28 | +LOOP adrs -- L: 0 a1 a2 .. aN -- 29 | , x -- append cell to dict 30 | / n1 n2 -- n3 signed divide 31 | /MOD n1 n2 -- n3 n4 signed divide, rem & quot 32 | : -- begin a colon definition 33 | ; end a colon definition 34 | <# -- begin numeric conversion 35 | >BODY xt -- a-addr adrs of param field 36 | >IN -- a-addr holds offset into TIB 37 | >NUMBER ud adr u -- ud' adr' u' 38 | convert string to number 39 | 2DROP x1 x2 -- drop 2 cells 40 | 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells 41 | 2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 per diag 42 | 2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram 43 | 2! x1 x2 a-addr -- store 2 cells 44 | 2@ a-addr -- x1 x2 fetch 2 cells 45 | ABORT i*x -- R: j*x -- clear stack & QUIT 46 | ABORT" i*x 0 -- i*x R: j*x -- j*x print msg & 47 | i*x x1 -- R: j*x -- abort,x1<>0 48 | ABS n1 -- +n2 absolute value 49 | ACCEPT c-addr +n -- +n' get line from terminal 50 | ALIGN -- align HERE 51 | ALIGNED addr -- a-addr align given addr 52 | ALLOT n -- allocate n bytes in dict 53 | BASE -- a-addr holds conversion radix 54 | BEGIN -- adrs target for backward branch 55 | BL -- char an ASCII space 56 | C, char -- append char to dict 57 | CELLS n1 -- n2 cells->adrs units 58 | CELL+ a-addr1 -- a-addr2 add cell size to adrs 59 | CHAR -- char parse ASCII character 60 | CHARS n1 -- n2 chars->adrs units 61 | CHAR+ c-addr1 -- c-addr2 add char size to adrs 62 | COUNT c-addr1 -- c-addr2 u counted->adr/len 63 | CR -- output newline 64 | CREATE -- create an empty definition 65 | DECIMAL -- set number base to decimal 66 | DEPTH -- +n number of items on stack 67 | DO -- adrs L: -- 0 start of DO..LOOP 68 | DOES> -- change action of latest def'n 69 | ELSE adrs1 -- adrs2 branch for IF..ELSE 70 | ENVIRONMENT? c-addr u -- false system query 71 | EVALUATE i*x c-addr u -- j*x interpret string 72 | FIND c-addr -- c-addr 0 ..if name not found 73 | xt 1 ..if immediate 74 | xt -1 ..if "normal" 75 | FM/MOD d1 n1 -- n2 n3 floored signed division 76 | HERE -- addr returns dictionary pointer 77 | HOLD char -- add char to output string 78 | IF -- adrs conditional forward branch 79 | IMMEDIATE -- make last def'n immediate 80 | LEAVE -- L: -- adrs exit DO..LOOP 81 | LITERAL x -- append numeric literal to dict. 82 | LOOP adrs -- L: 0 a1 a2 .. aN -- 83 | MAX n1 n2 -- n3 signed maximum 84 | MIN n1 n2 -- n3 signed minimum 85 | MOD n1 n2 -- n3 signed remainder 86 | MOVE addr1 addr2 u -- smart move 87 | M* n1 n2 -- d signed 16*16->32 multiply 88 | POSTPONE -- postpone compile action of word 89 | QUIT -- R: i*x -- interpret from keyboard 90 | RECURSE -- recurse current definition 91 | REPEAT adrs1 adrs2 -- resolve WHILE loop 92 | SIGN n -- add minus sign if n<0 93 | SM/REM d1 n1 -- n2 n3 symmetric signed division 94 | SOURCE -- adr n current input buffer 95 | SPACE -- output a space 96 | SPACES n -- output n spaces 97 | STATE -- a-addr holds compiler state 98 | S" -- compile in-line string 99 | ." -- compile string to print 100 | S>D n -- d single -> double precision 101 | THEN adrs -- resolve forward branch 102 | TYPE c-addr +n -- type line to terminal 103 | UNTIL adrs -- conditional backward branch 104 | U. u -- display u unsigned 105 | . n -- display n signed 106 | WHILE -- adrs branch for WHILE loop 107 | WORD char -- c-addr n parse word delim by char 108 | [ -- enter interpretive state 109 | [CHAR] -- compile character literal 110 | ['] -- find word & compile as literal 111 | ] -- enter compiling state 112 | 113 | ANS Forth Extensions 114 | These are optional words whose definitions are 115 | specified by the ANS Forth document. 116 | 117 | .S -- print stack contents 118 | /STRING a u n -- a+n u-n trim string 119 | AGAIN adrs -- uncond'l backward branch 120 | COMPILE, xt -- append execution token 121 | DABS d1 -- +d2 absolute value, dbl.prec. 122 | DNEGATE d1 -- d2 negate, double precision 123 | HEX -- set number base to hex 124 | PAD -- a-addr user PAD buffer 125 | TIB -- a-addr Terminal Input Buffer 126 | WITHIN n1|u1 n2|u2 n3|u3 -- f test n2<=n1) -- run-time action of DOES> 141 | (S") -- c-addr u run-time code for S" 142 | ,BRANCH xt -- append a branch instruction 143 | ,CF adrs -- append a code field 144 | ,DEST dest -- append a branch address 145 | ,EXIT -- append hi-level EXIT action 146 | >COUNTED src n dst -- copy to counted str 147 | >DIGIT n -- c convert to 0..9A..Z 148 | >L x -- L: -- x move to Leave stack 149 | ?ABORT f c-addr u -- abort & print msg 150 | ?DNEGATE d1 n -- d2 negate d1 if n negative 151 | ?NEGATE n1 n2 -- n3 negate n1 if n2 negative 152 | ?NUMBER c-addr -- n -1 convert string->number 153 | -- c-addr 0 if convert error 154 | ?SIGN adr n -- adr' n' f get optional sign 155 | advance adr/n if sign; return NZ if negative 156 | CELL -- n size of one cell 157 | COLD -- cold start Forth system 158 | COMPILE -- append inline execution token 159 | DIGIT? c -- n -1 ..if c is a valid digit 160 | -- x 0 ..otherwise 161 | DP -- a-addr holds dictionary ptr 162 | ENDLOOP adrs xt -- L: 0 a1 a2 .. aN -- 163 | HIDE -- "hide" latest definition 164 | HP -- a-addr HOLD pointer 165 | IMMED? nfa -- f fetch immediate flag 166 | INTERPRET i*x c-addr u -- j*x 167 | interpret given buffer 168 | L0 -- a-addr bottom of Leave stack 169 | LATEST -- a-addr last word in dictionary 170 | LP -- a-addr Leave-stack pointer 171 | L> -- x L: x -- move from Leave stack 172 | NFA>CFA nfa -- cfa name adr -> code field 173 | NFA>LFA nfa -- lfa name adr -> link field 174 | R0 -- a-addr end of return stack 175 | REVEAL -- "reveal" latest definition 176 | S0 -- a-addr end of parameter stack 177 | TIBSIZE -- n size of TIB 178 | U0 -- a-addr current user area adrs 179 | UD* ud1 d2 -- ud3 32*16->32 multiply 180 | UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide 181 | UINIT -- addr initial values for user area 182 | UMAX u1 u2 -- u unsigned maximum 183 | UMIN u1 u2 -- u unsigned minimum 184 | 185 | -------------------------------------------------------------------------------- /source/cam80-12/GLOSSLO.TXT: -------------------------------------------------------------------------------- 1 | TABLE 1. GLOSSARY OF WORDS IN CAMEL80.AZM 2 | Words which are (usually) written in CODE. 3 | 4 | NAME stack in -- stack out description 5 | 6 | Guide to stack diagrams: R: = return stack, 7 | c = 8-bit character, flag = boolean (0 or -1), 8 | n = signed 16-bit, u = unsigned 16-bit, 9 | d = signed 32-bit, ud = unsigned 32-bit, 10 | +n = unsigned 15-bit, x = any cell value, 11 | i*x j*x = any number of cell values, 12 | a-addr = aligned adrs, c-addr = character adrs 13 | p-addr = I/O port adrs, sys = system-specific. 14 | Refer to ANS Forth document for more details. 15 | 16 | ANS Forth Core words 17 | These are required words whose definitions are 18 | specified by the ANS Forth document. 19 | 20 | ! x a-addr -- store cell in memory 21 | + n1/u1 n2/u2 -- n3/u3 add n1+n2 22 | +! n/u a-addr -- add cell to memory 23 | - n1/u1 n2/u2 -- n3/u3 subtract n1-n2 24 | < n1 n2 -- flag test n1 n1 n2 -- flag test n1>n2, signed 27 | >R x -- R: -- x push to return stack 28 | ?DUP x -- 0 | x x DUP if nonzero 29 | @ a-addr -- x fetch cell from memory 30 | 0< n -- flag true if TOS negative 31 | 0= n/u -- flag return true if TOS=0 32 | 1+ n1/u1 -- n2/u2 add 1 to TOS 33 | 1- n1/u1 -- n2/u2 subtract 1 from TOS 34 | 2* x1 -- x2 arithmetic left shift 35 | 2/ x1 -- x2 arithmetic right shift 36 | AND x1 x2 -- x3 logical AND 37 | CONSTANT n -- define a Forth constant 38 | C! c c-addr -- store char in memory 39 | C@ c-addr -- c fetch char from memory 40 | DROP x -- drop top of stack 41 | DUP x -- x x duplicate top of stack 42 | EMIT c -- output character to console 43 | EXECUTE i*x xt -- j*x execute Forth word 'xt' 44 | EXIT -- exit a colon definition 45 | FILL c-addr u c -- fill memory with char 46 | I -- n R: sys1 sys2 -- sys1 sys2 47 | get the innermost loop index 48 | INVERT x1 -- x2 bitwise inversion 49 | J -- n R: 4*sys -- 4*sys 50 | get the second loop index 51 | KEY -- c get character from keyboard 52 | LSHIFT x1 u -- x2 logical L shift u places 53 | NEGATE x1 -- x2 two's complement 54 | OR x1 x2 -- x3 logical OR 55 | OVER x1 x2 -- x1 x2 x1 per stack diagram 56 | ROT x1 x2 x3 -- x2 x3 x1 per stack diagram 57 | RSHIFT x1 u -- x2 logical R shift u places 58 | R> -- x R: x -- pop from return stack 59 | R@ -- x R: x -- x fetch from rtn stk 60 | SWAP x1 x2 -- x2 x1 swap top two items 61 | UM* u1 u2 -- ud unsigned 16x16->32 mult. 62 | UM/MOD ud u1 -- u2 u3 unsigned 32/16->16 div. 63 | UNLOOP -- R: sys1 sys2 -- drop loop parms 64 | U< u1 u2 -- flag test u1 x1 x2 -- flag test not equal 73 | BYE i*x -- return to CP/M 74 | CMOVE c-addr1 c-addr2 u -- move from bottom 75 | CMOVE> c-addr1 c-addr2 u -- move from top 76 | KEY? -- flag return true if char waiting 77 | M+ d1 n -- d2 add single to double 78 | NIP x1 x2 -- x2 per stack diagram 79 | TUCK x1 x2 -- x2 x1 x2 per stack diagram 80 | U> u1 u2 -- flag test u1>u2, unsigned 81 | 82 | Private Extensions 83 | These are words which are unique to CamelForth. 84 | Many of these are necessary to implement ANS 85 | Forth words, but are not specified by the ANS 86 | document. Others are functions I find useful. 87 | 88 | (do) n1|u1 n2|u2 -- R: -- sys1 sys2 89 | run-time code for DO 90 | (loop) R: sys1 sys2 -- | sys1 sys2 91 | run-time code for LOOP 92 | (+loop) n -- R: sys1 sys2 -- | sys1 sys2 93 | run-time code for +LOOP 94 | >< x1 -- x2 swap bytes 95 | ?branch x -- branch if TOS zero 96 | BDOS DE C -- A call CP/M BDOS 97 | branch -- branch always 98 | lit -- x fetch inline literal to stack 99 | PC! c p-addr -- output char to port 100 | PC@ p-addr -- c input char from port 101 | RP! a-addr -- set return stack pointer 102 | RP@ -- a-addr get return stack pointer 103 | SCAN c-addr1 u1 c -- c-addr2 u2 104 | find matching char 105 | SKIP c-addr1 u1 c -- c-addr2 u2 106 | skip matching chars 107 | SP! a-addr -- set data stack pointer 108 | SP@ -- a-addr get data stack pointer 109 | S= c-addr1 c-addr2 u -- n string compare 110 | n<0: s10: s1>s2 111 | USER n -- define user variable 'n' 112 |  -------------------------------------------------------------------------------- /source/cam80-12/README.Z80: -------------------------------------------------------------------------------- 1 | CAMELFORTH FOR THE Z80 - BETA TEST VERSION - 16 APRIL 1995 2 | ========================================================== 3 | 4 | This is a BETA TEST version of CamelForth/80, an ANSI Standard Forth for 5 | the Zilog Z80 microprocessor and the CP/M operating system. This means 6 | that, although I have tested the bulk of this code for correct 7 | functioning, and have fixed several bugs, you may discover new bugs. 8 | I'd appreciate hearing of any such, either 9 | 10 | by Internet: bj@headwaters.com 11 | or by amateur packet radio: VE3RHJ@VE3IJD.#CON.ON.CAN.NA 12 | 13 | I'll also answer questions and try to solve problems. 14 | 15 | * * * 16 | 17 | As distributed, CamelForth will assemble to run under CP/M 2.x. It 18 | determines the highest available RAM location from CP/M, and places its 19 | data areas (stacks, user area, etc.) immediately below that. The 20 | CamelForth program resides in the bottom of the CP/M program area 21 | (100h), and any user definitions are added immediately after. CP/M's 22 | default command buffer at 80h is used for the Terminal Input Buffer. 23 | 24 | To start CamelForth under CP/M, type the command 25 | 26 | CAMEL80 ...any Forth commands... 27 | 28 | CamelForth will execute the rest of the CP/M command line as a Forth 29 | statement, and then enter the Forth interpreter. To return to CP/M, use 30 | the command 31 | 32 | BYE 33 | 34 | Note that CamelForth is CASE SENSITIVE, and all Forth words are in UPPER 35 | CASE. 36 | 37 | MODIFICATION FOR STANDALONE USE 38 | 39 | CamelForth can be easily assembled for a standalone or embedded Z80. 40 | About 6K of PROM and 640 bytes of RAM are used by CamelForth, plus 41 | whatever additional PROM and RAM is needed by your program. You will 42 | probably need to provide the Z80 reset vector, e.g. 43 | 44 | org 0 45 | jp reset 46 | 47 | You must also add any required hardware initialization, and the Forth 48 | words KEY KEY? and EMIT for your hardware. You should modify the 49 | 'reset' routine to use an equate for end of RAM, e.g. 50 | 51 | reset: ld hl,ramend ; end of available memory (EM) 52 | dec h ; EM-100h 53 | ld sp,hl ; = top of param stack 54 | inc h ; EM 55 | etc. 56 | 57 | If you are putting CamelForth in PROM, but want to have a Forth 58 | dictionary in RAM (so you can add new definitions), you'll have to 59 | change the 'enddict' equate (at the end of camel80.azm) to the your 60 | starting RAM address. Do NOT change the 'lastword' equate. 61 | 62 | The Terminal Input Buffer must be moved to a new location in RAM. The 63 | usual CamelForth usage is 80h bytes below the user area. TIB can be 64 | redefined as 65 | 66 | ;X tib -- a-addr Terminal Input Buffer 67 | ; HEX -80 USER TIB below user area 68 | head TIB,3,TIB,douser 69 | dw -80h 70 | 71 | You should also delete the line 72 | 73 | DW LIT,80h,COUNT,INTERPRET 74 | 75 | from the routine COLD. This line causes the CP/M command "tail" to be 76 | executed as a Forth command...inapplicable in a standalone system. 77 | 78 | * * * 79 | 80 | This program was written using the Z80MR macro assembler under CP/M. 81 | Z80MR is a freeware assembler, available from GEnie and several other 82 | CP/M archives. Assemble the CamelForth source files with the commands 83 | 84 | z80mr camel80 85 | load camel80 86 | 87 | Z80MR produces an Intel hex file camel80.hex, and LOAD generates the 88 | file camel80.com. (Note: do NOT use the version of Z80MR that directly 89 | outputs a .COM file; that version of the assembler has bugs.) For 90 | embedded applications you probably can skip the LOAD, since most PROM 91 | programmers, PROM emulators, and debug programs will accept Intel hex 92 | files. 93 | 94 | If you don't have CP/M, you can use the MYZ80 emulator on an IBM PC, or 95 | you can rewrite the source code for your Z80 macro assembler. 96 | 97 | There are TWO WAYS to write embedded programs in CamelForth: 98 | 99 | 1. If you have CamelForth running on an embedded Z80, you can download 100 | Forth code directly to CamelForth. This lets you type new words from 101 | the keyboard, test them as they are defined, and re-define them to make 102 | changes. Or you can edit an ASCII text file, and use a program such as 103 | Procomm to send this file over the serial port to your Z80. It can take 104 | a few seconds to compile each line, so be sure to leave plenty of delay 105 | after the line. (I'm working on handshaking to improve this.) Also be 106 | sure that no line exceeds 80 characters. 107 | 108 | 2. If you you want to burn your program into PROM, you can add your code 109 | to the file CAMEL80.ASM. (I recommend creating a separate file and 110 | using the *INCLUDE directive.) This requires you to convert your Forth 111 | code to assembler code. To show how this is done, every high-level 112 | Forth word in the file is shown with its equivalent Forth code in a 113 | comment. Be especially careful with control structures (IF..ELSE..THEN, 114 | BEGIN..UNTIL, DO..LOOP, and the like), and with the Forth word headers. 115 | Reassemble CAMEL80.AZM and burn a PROM (or download to a PROM emulator 116 | or debug monitor), then test. This is a much slower process, and is 117 | best saved for the final stage when you have a tested & debugged program 118 | that you want to put in PROM. 119 | 120 | Disk I/O is not yet supported under CP/M. However, CamelForth v1.2 will 121 | accept commands from a CP/M SUBMIT file using the XSUB utility. The 122 | SUBMIT file should contain the commands 123 | 124 | XSUB 125 | CAMEL80 126 | ...Forth source code... 127 | 128 | This will run CamelForth/80 under XSUB, which will feed the rest of the 129 | file to CamelForth as terminal input. You can automatically return to 130 | CP/M by putting the CamelForth BYE command in the file. Then you can 131 | save the modified CamelForth image with the CP/M command 132 | 133 | SAVE nn CAMELNEW.COM 134 | 135 | 'nn' is the decimal number of pages occupied by the CamelForth 136 | dictionary. You can determine this value while in CamelForth with the 137 | statement 138 | 139 | DECIMAL HERE 0 256 UM/MOD NIP . 140 | 141 | Unfortunately, at the moment there's no way to totally automate this as 142 | part of the SUBMIT file. And I'm reluctant to add SAVE to CamelForth 143 | when CP/M has a perfectly good SAVE command. 144 | 145 | * * * 146 | 147 | --------------------------- LICENSE TERMS ------------------------------ 148 | CamelForth for the Zilog Z80 (c) 1994 Bradford J. Rodriguez. 149 | Permission is granted to freely copy, modify, and distribute this 150 | program for personal or educational use. Commercial inquiries should be 151 | directed to the author at 221 King St. E., #32, Hamilton, Ontario 152 | L8N 1B5 Canada 153 | ------------------------------------------------------------------------ 154 | 155 | Freely translated, this means: I'm keeping the copyright to this 156 | program, but you're welcome to use it, change it, experiment with it, 157 | give it to friends, build it into your projects, teach it to your 158 | students -- anything EXCEPT make money from it. If you want to sell 159 | CamelForth, include it as part of something you're selling, or base a 160 | product upon it, let's talk. I'm reasonable. 161 | 162 | -------------------------------------------------------------------------------- /source/gbfs.h: -------------------------------------------------------------------------------- 1 | /* gbfs.h 2 | access object in a GBFS file 3 | 4 | Copyright 2002 Damian Yerrick 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the 8 | "Software"), to deal in the Software without restriction, including 9 | without limitation the rights to use, copy, modify, merge, publish, 10 | distribute, sublicense, and/or sell copies of the Software, and to 11 | permit persons to whom the Software is furnished to do so, subject to 12 | the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be 15 | included in all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 19 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 21 | BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN 22 | AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 23 | OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 24 | IN THE SOFTWARE. 25 | 26 | */ 27 | 28 | 29 | /* Dependency on prior include files 30 | 31 | Before you #include "gbfs.h", you should define the following types: 32 | typedef (unsigned 16-bit integer) u16; 33 | typedef (unsigned 32-bit integer) u32; 34 | Your gba.h should do this for you. 35 | */ 36 | 37 | #ifndef INCLUDE_GBFS_H 38 | #define INCLUDE_GBFS_H 39 | #ifdef __cplusplus 40 | extern "C" { 41 | #endif 42 | 43 | 44 | typedef struct GBFS_FILE 45 | { 46 | char magic[16]; /* "PinEightGBFS\r\n\032\n" */ 47 | u32 total_len; /* total length of archive */ 48 | u16 dir_off; /* offset in bytes to directory */ 49 | u16 dir_nmemb; /* number of files */ 50 | char reserved[8]; /* for future use */ 51 | } GBFS_FILE; 52 | 53 | typedef struct GBFS_ENTRY 54 | { 55 | char name[24]; /* filename, nul-padded */ 56 | u32 len; /* length of object in bytes */ 57 | u32 data_offset; /* in bytes from beginning of file */ 58 | } GBFS_ENTRY; 59 | 60 | 61 | GBFS_FILE *find_first_gbfs_file(const void *start); 62 | void *skip_gbfs_file(const GBFS_FILE *file); 63 | void *gbfs_get_obj(const GBFS_FILE *file, 64 | const char *name, 65 | u32 *len); 66 | void *gbfs_copy_obj(void *dst, 67 | const GBFS_FILE *file, 68 | const char *name); 69 | 70 | 71 | #ifdef __cplusplus 72 | } 73 | #endif 74 | #endif 75 | -------------------------------------------------------------------------------- /source/libgbfs.c: -------------------------------------------------------------------------------- 1 | //Torlus - dynamic definition of GBFS_SEARCH_LIMIT 2 | 3 | /* libgbfs.c 4 | access object in a GBFS file 5 | 6 | Copyright 2002 Damian Yerrick 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining 9 | a copy of this software and associated documentation files (the 10 | "Software"), to deal in the Software without restriction, including 11 | without limitation the rights to use, copy, modify, merge, publish, 12 | distribute, sublicense, and/or sell copies of the Software, and to 13 | permit persons to whom the Software is furnished to do so, subject to 14 | the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be 17 | included in all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 23 | BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN 24 | AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 25 | OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 26 | IN THE SOFTWARE. 27 | 28 | */ 29 | 30 | 31 | /* This code assumes a LITTLE ENDIAN target. It'll need a boatload 32 | of itohs and itohl calls if converted to run on Sega Genesis. It 33 | also assumes that the target uses 16-bit short and 32-bit longs. 34 | */ 35 | 36 | typedef unsigned short u16; 37 | typedef unsigned long u32; 38 | 39 | #include 40 | #include 41 | #include "gbfs.h" 42 | 43 | /* change this to the end of your ROM, or to 0x02040000 for multiboot */ 44 | 45 | //Torlus 46 | //#ifdef TARGET_PF_mb 47 | //#define GBFS_SEARCH_LIMIT ((const u32 *)0x02040000) 48 | //#else 49 | #define GBFS_SEARCH_LIMIT ((const u32 *)0x0a000000) 50 | //#endif 51 | 52 | 53 | /* a power of two, less than or equal to the argument passed to 54 | padbin */ 55 | #define GBFS_ALIGNMENT 256 56 | 57 | GBFS_FILE *find_first_gbfs_file(const void *start) 58 | { 59 | /* align the pointer */ 60 | const u32 *here = (const u32 *) 61 | ((unsigned long)start & (-GBFS_ALIGNMENT)); 62 | 63 | const char rest_of_magic[] = "ightGBFS\r\n\032\n"; 64 | 65 | /* while we haven't yet reached the end of the ROM space */ 66 | while(here < GBFS_SEARCH_LIMIT) 67 | { 68 | /* We have to keep the magic code in two pieces; otherwise, 69 | this function will find itself and think it's a GBFS file. 70 | This obviously won't work if your compiler stores this 71 | numeric literal just before the literal string, but Devkit 72 | Advance seems to keep numeric constant pools separate enough 73 | from string pools for this to work. 74 | */ 75 | if(*here == 0x456e6950) /* ASCII code for "PinE" */ 76 | { 77 | /* we're already after here; 78 | if the rest of the magic matches, then we're through */ 79 | if(!memcmp(here + 1, rest_of_magic, 12)) 80 | return (GBFS_FILE *)here; 81 | } 82 | here += GBFS_ALIGNMENT / sizeof(*here); 83 | } 84 | return 0; 85 | } 86 | 87 | 88 | void *skip_gbfs_file(const GBFS_FILE *file) 89 | { 90 | return ((char *)file + file->total_len); 91 | } 92 | 93 | 94 | static int namecmp(const void *a, const void *b) 95 | { 96 | return memcmp(a, b, 24); 97 | } 98 | 99 | 100 | void *gbfs_get_obj(const GBFS_FILE *file, 101 | const char *name, 102 | u32 *len) 103 | { 104 | char key[24] = {0}; 105 | 106 | GBFS_ENTRY *dirbase = (GBFS_ENTRY *)((char *)file + file->dir_off); 107 | size_t n_entries = file->dir_nmemb; 108 | GBFS_ENTRY *here; 109 | 110 | strncpy(key, name, 24); 111 | 112 | here = bsearch(key, dirbase, 113 | n_entries, sizeof(GBFS_ENTRY), 114 | namecmp); 115 | if(!here) 116 | return NULL; 117 | 118 | if(len) 119 | *len = here->len; 120 | return (char *)file + here->data_offset; 121 | } 122 | 123 | 124 | void *gbfs_copy_obj(void *dst, 125 | const GBFS_FILE *file, 126 | const char *name) 127 | { 128 | u32 len; 129 | const void *src = gbfs_get_obj(file, name, &len); 130 | 131 | if(!src) 132 | return NULL; 133 | 134 | memcpy(dst, src, len); 135 | return dst; 136 | } 137 | -------------------------------------------------------------------------------- /source/main.c: -------------------------------------------------------------------------------- 1 | #include "tonc.h" 2 | 3 | #include "AAS.h" 4 | #include "AAS_Data.h" 5 | #include "gbfs.h" 6 | 7 | #ifdef LINK_UART 8 | #include "circular_buffer.h" 9 | #include "uart.h" 10 | #endif 11 | 12 | /* // 8x8 Font */ 13 | /* extern const u8 gba_font[]; */ 14 | 15 | // Space reserved for PandaForth 16 | u8 user_area[256]; 17 | // This stack is used by Forth and C, so it needs to be large enough 18 | // I could have made these two stacks distinct... 19 | u8 ps_area[1024]; 20 | u8 rs_area[512]; 21 | u8 holdpad_area[40+88]; 22 | 23 | // Memory Map Information needed by PandaForth 24 | u8 *forthInfo[] = { ps_area+128, rs_area+128, user_area, holdpad_area+40 }; 25 | 26 | // PandaForth entry point function 27 | extern void boot(u8 *forthInfo[]); 28 | 29 | // Source Files 30 | int filesCount; 31 | GBFS_FILE *gbfs; 32 | GBFS_ENTRY *gbfs_entry; 33 | u8 *sourcePos; 34 | u32 sourceLen; 35 | 36 | int in_music; 37 | 38 | int main() { 39 | // Set up the interrupt handlers 40 | irq_init(NULL); 41 | // Enable Vblank Interrupt to allow VblankIntrWait 42 | irq_add(II_VBLANK, AAS_DoWork); 43 | 44 | #ifdef LINK_UART 45 | init_circ_buff(&g_uart_rcv_buffer, g_rcv_buffer, UART_RCV_BUFFER_SIZE); 46 | init_uart(SIO_BAUD_115200); 47 | // Set uart interrupt handler 48 | irq_add(II_SERIAL, handle_uart_gbaser); 49 | #endif 50 | 51 | in_music = 0; 52 | 53 | // Find the embedded source, if any 54 | gbfs_entry = NULL; 55 | gbfs = find_first_gbfs_file(find_first_gbfs_file); 56 | sourceLen = 0; 57 | 58 | if (gbfs != NULL) { 59 | filesCount = gbfs->dir_nmemb-1; 60 | gbfs_entry = (GBFS_ENTRY *)((char *)gbfs + gbfs->dir_off); 61 | sourcePos = gbfs_get_obj(gbfs,gbfs_entry->name,&sourceLen); 62 | } 63 | 64 | // Boot up PandaForth 65 | boot(forthInfo); 66 | 67 | // Never reached 68 | return 0; 69 | } 70 | 71 | // C <-> Forth interface 72 | int EWRAM_CODE service(int serv, int param) { 73 | int ch; 74 | if (serv == 6) { 75 | if (param != 0xff) { 76 | /* write_char(param); */ 77 | #ifndef LINK_NONE 78 | dputchar(param); 79 | #endif 80 | } else { 81 | if (sourceLen > 0) { 82 | sourceLen--; 83 | ch = *sourcePos++; 84 | if ((sourceLen == 0) && (filesCount > 0)) { 85 | filesCount--; 86 | gbfs_entry++; 87 | sourcePos = gbfs_get_obj(gbfs,gbfs_entry->name,&sourceLen); 88 | if (sourcePos == NULL) sourceLen=0; 89 | } 90 | if (ch == '\t') return ' '; 91 | /*if (ch == '\n') for(i=0; i<30;i++) VBlankIntrWait();*/ 92 | if (ch == '\r') return 0; 93 | return ch; 94 | } else { 95 | #ifdef LINK_UART 96 | if(!circ_bytes_available(&g_uart_rcv_buffer)) { 97 | dputchar(0x1e); 98 | } 99 | ch = rcv_char(); 100 | #endif 101 | #ifdef LINK_NONE 102 | while(1) VBlankIntrWait(); 103 | return 0; 104 | #else 105 | if (ch == '\r') return 0; 106 | return ch; 107 | #endif 108 | } 109 | } 110 | } else if (serv == 1) { 111 | if(in_music) 112 | // AAS_DoWork(); 113 | while(param--) VBlankIntrWait(); 114 | return 0; 115 | } else if (serv == 2) { 116 | if (in_music) { 117 | irq_add(II_TIMER1, AAS_FastTimer1InterruptHandler); 118 | AAS_MOD_SetVolume(256); 119 | AAS_MOD_Play(AAS_DATA_MOD_bla); 120 | } 121 | return 0; 122 | } else if ( serv == 3) { 123 | AAS_SFX_Play( 124 | 0, 125 | 64, 126 | 8000, 127 | AAS_DATA_SFX_START_Ring, 128 | AAS_DATA_SFX_END_Ring, 129 | NULL); 130 | 131 | // AAS_MOD_Stop(); 132 | /* int countdown = 10; */ 133 | /* while(countdown--) { */ 134 | /* AAS_DoWork(); */ 135 | /* VBlankIntrWait(); */ 136 | /* } */ 137 | // irq_delete(II_TIMER1); 138 | return 0; 139 | } else if (serv == 4) { 140 | if(in_music) 141 | // AAS_DoWork(); 142 | return 0; 143 | } else if (serv == 5) { 144 | // Initialise AAS 145 | AAS_SetConfig( 146 | AAS_CONFIG_MIX_16KHZ, 147 | AAS_CONFIG_CHANS_8, 148 | AAS_CONFIG_SPATIAL_STEREO, 149 | AAS_CONFIG_DYNAMIC_OFF ); 150 | in_music = 1; 151 | return 0; 152 | } 153 | return 0; 154 | } 155 | -------------------------------------------------------------------------------- /tools/compiler.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | # Very very naive forth cross-compiler, just about functional enough to make this 4 | # workable for a simple entry for a GBA game competition. 5 | 6 | # When I have a bit more time (HA!), I'll write a full-blown one that will 7 | # inherently basically be a whole Forth implementation all by itself. 8 | 9 | import argparse 10 | import os 11 | import re 12 | 13 | LAST_WORD = "apt_toi" 14 | GENSYM = 0 15 | 16 | # classes 17 | class Stmt: 18 | def __init__(self, name, tokens): 19 | self.name = name 20 | self.tokens = tokens 21 | 22 | def to_ass(self, file, prev_word): 23 | raise CompileError("to_ass not implemented for this stmt: {0}".format(self.print())) 24 | 25 | def __repr__(self): 26 | return self.print() 27 | 28 | def __str__(self): 29 | return self.print() 30 | 31 | def print(self): 32 | return "stmt: {0} _ {1}".format(self.name, self.tokens[0].line) 33 | 34 | 35 | class Const(Stmt): 36 | def __init__(self, name, tokens, val): 37 | super().__init__(name, tokens) 38 | self.val = val 39 | 40 | def to_ass(self, file, prev_word): 41 | ass_name = name_to_ass(self.name) 42 | out = ' head {0},{1},"{2}",docon,{3}\n .word {4}\n\n'.format( 43 | ass_name, len(self.name), self.name, prev_word, hex(self.val)) 44 | file.write(out) 45 | return ass_name 46 | 47 | def print(self): 48 | return "const: {0} . {1} _ {2}".format(self.name, self.val, self.tokens[0].line) 49 | 50 | 51 | class Var(Stmt): 52 | def __init__(self, name, tokens): 53 | super().__init__(name, tokens) 54 | 55 | def to_ass(self, file, prev_word): 56 | ass_name = name_to_ass(self.name) 57 | out = ' head {0},{1},"{2}",dovar,{3}\n .word 0x0\n\n'.format( 58 | ass_name, len(self.name), self.name, prev_word) 59 | file.write(out) 60 | return ass_name 61 | 62 | def print(self): 63 | return "var: {0} _ {1}".format(self.name, self.tokens[0].line) 64 | 65 | 66 | class Array(Stmt): 67 | def __init__(self, name, tokens, val): 68 | super().__init__(name, tokens) 69 | self.val = val 70 | 71 | def to_ass(self, file, prev_word): 72 | ass_name = name_to_ass(self.name) 73 | out = ' head {0},{1},"{2}",dovar,{3}\n .space {4}\n\n'.format( 74 | ass_name, len(self.name), self.name, prev_word, hex(self.val)) 75 | file.write(out) 76 | return ass_name 77 | 78 | def print(self): 79 | return "array: {0} . {1} _ {2}".format(self.name, self.val, self.tokens[0].line) 80 | 81 | 82 | class Nr(Stmt): 83 | def __init__(self, name, tokens, val): 84 | super().__init__(name, tokens) 85 | self.val = val 86 | 87 | def to_ass(self, file, prev_word): 88 | file.write("lit,{0}".format(hex(self.val))) 89 | 90 | def print(self): 91 | return "const: {0} . {1} _ {2}".format(self.name, self.val, self.tokens[0].line) 92 | 93 | class Str(Stmt): 94 | def __init__(self, name, tokens, val): 95 | super().__init__(name, tokens) 96 | self.val = val 97 | 98 | def to_ass(self, file, prev_word): 99 | escapes = self.val.count('\\') 100 | size = len(self.val) - escapes 101 | file.write('xsquote\n.byte {}\n.ascii "{}"\n.align\n' 102 | .format(hex(size), self.val)) 103 | 104 | def print(self): 105 | return "str: {0} . {1} _ {2}".format(self.name, self.val, self.tokens[0].line) 106 | 107 | class Word(Stmt): 108 | def __init__(self, name, tokens, words): 109 | super().__init__(name, tokens) 110 | self.words = words 111 | 112 | def to_ass(self, file, prev_word): 113 | ass_name = name_to_ass(self.name) 114 | file.write(' head {0},{1},"{2}",docolon,{3}\n'.format( 115 | ass_name, len(self.name), self.name, prev_word)) 116 | 117 | if not self.words or not isinstance(self.words[0], Label): 118 | file.write(" .word ") 119 | 120 | # It has been a long time since I wrote something this ugly, 121 | # but I don't care anymore. We need a true compiler and this 122 | # should be thrown away anyways 123 | if self.words: 124 | word_size = len(self.words) 125 | for i, word in enumerate(self.words): 126 | word.to_ass(file, prev_word) 127 | if isinstance(word, Str): 128 | file.write(" .word ") 129 | continue 130 | if (i < word_size - 1 and 131 | not isinstance(word, Label) and 132 | not isinstance(self.words[i+1], Label)): 133 | file.write(',') 134 | if i >= word_size - 1 and not isinstance(word, Label): 135 | file.write(',') 136 | if (i < word_size - 1 and 137 | isinstance(word, Label) and 138 | not isinstance(self.words[i+1], Label)): 139 | file.write(" .word ") 140 | if i >= word_size - 1 and isinstance(word, Label): 141 | file.write(" .word ") 142 | 143 | file.write('exit\n\n') 144 | 145 | return ass_name 146 | 147 | def print(self): 148 | return "const: {0} . {1} _ {2}".format(self.name, self.words, self.tokens[0].line) 149 | 150 | 151 | class Label(Stmt): 152 | def __init__(self, name, token): 153 | global GENSYM 154 | label_name = name + "_" + str(GENSYM) 155 | GENSYM += 1 156 | super().__init__(label_name, [token]) 157 | 158 | def to_ass(self, file, prev_word): 159 | ass_name = name_to_ass(self.name) 160 | file.write('\n{0}:'.format(ass_name)) 161 | 162 | def print(self): 163 | return "label: {0} _ {1}".format(self.name, self.tokens[0].line) 164 | 165 | 166 | class BranchUncond(Stmt): 167 | def __init__(self, name, token): 168 | super().__init__(name, [token]) 169 | 170 | def to_ass(self, file, prev_word): 171 | ass_name = name_to_ass(self.name) 172 | file.write('branch,{0}'.format(ass_name)) 173 | 174 | def print(self): 175 | return "branch: to {0} _ {1}".format(self.name, self.tokens[0].line) 176 | 177 | 178 | class BranchZero(Stmt): 179 | def __init__(self, name, token): 180 | super().__init__(name, [token]) 181 | 182 | def to_ass(self, file, prev_word): 183 | ass_name = name_to_ass(self.name) 184 | file.write('qbranch,{0}'.format(ass_name)) 185 | 186 | def print(self): 187 | return "qbranch: to {0} _ {1}".format(self.name, self.tokens[0].line) 188 | 189 | class Branch(Stmt): 190 | def __init__(self, name, token, branch_type): 191 | super().__init__(name, [token]) 192 | self.branch_type = branch_type 193 | 194 | def to_ass(self, file, prev_word): 195 | ass_type = name_to_ass(self.branch_type) 196 | ass_name = name_to_ass(self.name) 197 | file.write('{0},{1}'.format(ass_type,ass_name)) 198 | 199 | def print(self): 200 | return "{0}: to {1} _ {2}".format(self.branch_type, self.name, self.tokens[0].line) 201 | 202 | class Token: 203 | def __init__(self, tok, line): 204 | self.tok = tok 205 | self.line = line 206 | 207 | def __repr__(self): 208 | return self.print() 209 | 210 | def __str__(self): 211 | return self.print() 212 | 213 | def to_ass(self, file, prev_word): 214 | file.write("{0}".format(name_to_ass(self.tok))) 215 | 216 | def print(self): 217 | return "tok: {0} _ {1}".format(self.tok, self.line) 218 | 219 | 220 | class Context: 221 | def __init__(self): 222 | self.stmts = [] 223 | self.words = {} 224 | self.base = 10 225 | self.stack = [] 226 | self.tokens = [] 227 | 228 | class CompileError(Exception): 229 | """Base class for exceptions in this module.""" 230 | pass 231 | 232 | 233 | # tokenize 234 | def tokenize(file): 235 | tokens = [] 236 | with open(file) as fp: 237 | line = fp.readline() 238 | count = 1 239 | while line: 240 | things = line.split() 241 | [tokens.append(Token(x, count)) for x in things] 242 | line = fp.readline() 243 | count += 1 244 | return tokens 245 | 246 | def peek(tokens): 247 | return tokens[0] 248 | 249 | def string_split_single_line(line): 250 | """We need to split on word boundry""" 251 | if line == "": 252 | return line 253 | n = 28 254 | line_list = line.split() 255 | lines_out = line_list.pop(0) 256 | count = len(lines_out) 257 | for word in line_list: 258 | word_len = len(word) 259 | if count + word_len + 1 > n: 260 | lines_out += '\\n' + word 261 | count = word_len 262 | else: 263 | lines_out += ' ' + word 264 | count += word_len + 1 265 | return lines_out 266 | 267 | def string_split_lines(string): 268 | hard_lines = re.split('\\\\n', string) 269 | str_out = "" 270 | for line in hard_lines: 271 | str_out += '\\n' + string_split_single_line(line) 272 | return str_out[2:] # remove leading line break 273 | 274 | # parse 275 | def parse_string(context): 276 | tokens = context.tokens 277 | # remove `s"' 278 | str_toks = [tokens.pop(0)] 279 | first = tokens.pop(0) 280 | str_toks.append(first) 281 | string = first.tok 282 | while True: 283 | next = tokens.pop(0) 284 | str_toks.append(next) 285 | str_split = next.tok.split('"') 286 | if len(str_split) > 2: 287 | raise CompileError("string delimiter found in middle of word: {}".format(next.tok)) 288 | string += " " + str_split[0] 289 | if len(str_split) == 2: 290 | break 291 | 292 | return Str(first.tok, str_toks, string_split_lines(string)) 293 | 294 | def colon_compile(context): 295 | words = [] 296 | tokens = context.tokens 297 | definition = [tokens.pop(0), tokens.pop(0)] 298 | name = definition[1].tok 299 | branch_stack = [] 300 | if_stack = [] 301 | 302 | next = peek(tokens).tok 303 | while next != ";": 304 | try: 305 | words.append(parse_number(context)) 306 | next = peek(tokens).tok 307 | continue 308 | except ValueError: 309 | pass 310 | 311 | if next == "(": 312 | parse_comment(context) 313 | elif next == "begin": 314 | label = Label(name, tokens.pop(0)) 315 | words.append(label) 316 | branch_stack.append(label) 317 | elif next == "until": 318 | assert branch_stack, "branch stack is empty!" 319 | label = branch_stack.pop() 320 | words.append(BranchZero(label.name, tokens.pop(0))) 321 | elif next == "if": 322 | not_if_branch = BranchZero(None, tokens.pop(0)) 323 | words.append(not_if_branch) 324 | if_stack.append(not_if_branch) 325 | elif next == "else": 326 | # here we should end up with: 327 | # end of if, so unconditional branch to then 328 | # landing label of qbranch, so beginning of else 329 | # then label 330 | # but be sure to remove else landing from stack before pushing if 331 | assert if_stack, "if stack is empty!" 332 | else_token = tokens.pop(0) 333 | # remove else landing 334 | else_branch = if_stack.pop() 335 | # unconditional branch 336 | if_branch = BranchUncond(None, else_token) 337 | words.append(if_branch) 338 | if_stack.append(if_branch) 339 | # landing label of else 340 | label = Label(name, else_token) 341 | else_branch.name = label.name 342 | words.append(label) 343 | elif next == "then": 344 | assert if_stack, "if stack is empty!" 345 | label = Label(name, tokens.pop(0)) 346 | not_if_branch = if_stack.pop() 347 | not_if_branch.name = label.name 348 | words.append(label) 349 | elif next == "while": 350 | branch = BranchZero(None, tokens.pop(0)) 351 | branch_stack.append(branch) 352 | words.append(branch) 353 | elif next == "repeat": 354 | while_branch = branch_stack.pop() 355 | begin_label = branch_stack.pop() 356 | repeat_token = tokens.pop(0) 357 | repeat_branch = BranchUncond(begin_label.name, repeat_token) 358 | repeat_label = Label(name, repeat_token) 359 | while_branch.name = repeat_label.name 360 | words.append(repeat_branch) 361 | words.append(repeat_label) 362 | elif next == "do": 363 | token = tokens.pop(0) 364 | words.append(token) 365 | label = Label(name, token) 366 | words.append(label) 367 | branch_stack.append(label) 368 | elif next in ["loop", "+loop"]: 369 | assert branch_stack, "branch stack is empty!" 370 | label = branch_stack.pop() 371 | words.append(Branch(label.name, tokens.pop(0), next)) 372 | elif next == "s\"": 373 | words.append(parse_string(context)) 374 | else: 375 | words.append(tokens.pop(0)) 376 | 377 | next = peek(tokens).tok 378 | 379 | definition.extend(words) 380 | definition.append(tokens.pop(0)) 381 | 382 | stmt = Word(name, definition, words) 383 | context.stmts.append(stmt) 384 | context.words[name] = stmt 385 | 386 | def parse_comment(context): 387 | while context.tokens.pop(0).tok != ")": 388 | pass 389 | 390 | def parse_const(context): 391 | tokens = context.tokens 392 | assert len(context.stack) > 0, "expected at least one token on the stack!!" 393 | number = context.stack.pop() 394 | assert isinstance(number, Nr), "expected number!!: {0}".format(number) 395 | const = tokens.pop(0) 396 | name = tokens.pop(0) 397 | stmt = Const(name.tok, [number, const, name], number.val) 398 | context.stmts.append(stmt) 399 | context.words[name.tok] = stmt 400 | 401 | def parse_var(context): 402 | tokens = context.tokens 403 | const = tokens.pop(0) 404 | name = tokens.pop(0) 405 | stmt = Var(name.tok, [const, name]) 406 | context.stmts.append(stmt) 407 | context.words[name.tok] = stmt 408 | 409 | def parse_array(context): 410 | tokens = context.tokens 411 | assert len(context.stack) > 0, "expected at least one token on the stack!!" 412 | number = context.stack.pop() 413 | assert isinstance(number, Nr), "expected number!!: {0}".format(number) 414 | array = tokens.pop(0) 415 | name = tokens.pop(0) 416 | stmt = Array(name.tok, [number, array, name], number.val) 417 | context.stmts.append(stmt) 418 | context.words[name.tok] = stmt 419 | 420 | def parse_number(context): 421 | tokens = context.tokens 422 | nr = int(peek(tokens).tok, context.base) 423 | if nr >= -0x80000000 and nr <= 0xffffffff: 424 | token = tokens.pop(0) 425 | return Nr(token.tok, [token], nr) 426 | else: 427 | raise CompileError("number isn't within range!!: {0}".format(peek(tokens))) 428 | 429 | 430 | def parse_arith(context): 431 | assert len(context.stack) > 1, "expected at least two token on the stack!!" 432 | 433 | arith = context.tokens.pop(0) 434 | nr2_word = context.stack.pop() 435 | nr1_word = context.stack.pop() 436 | nr1 = nr1_word.val 437 | nr2 = nr2_word.val 438 | 439 | result = None 440 | 441 | if arith.tok == "+": 442 | result = nr1 + nr2 443 | elif arith.tok == "-": 444 | result = nr1 - nr2 445 | elif arith.tok == "*": 446 | result = nr1 * nr2 447 | elif arith.tok == "/": 448 | result = nr1 / nr2 449 | else: 450 | raise CompileError("arithmetic operator not recognized: `{0}`".format(arith)) 451 | 452 | nr = Nr(str(result), [nr1_word, nr2_word, arith], result) 453 | context.stack.append(nr) 454 | 455 | 456 | def parse_word(context): 457 | token = context.tokens.pop(0) 458 | word = context.words[token.tok] 459 | assert isinstance(word, Var) or isinstance(word, Const), "word needs to be either a variable or a constant: `{0}`".format(word) 460 | context.stack.append(Nr(token.tok, [token], word.val)) 461 | 462 | 463 | def parse_token(context): 464 | tokens = context.tokens 465 | next = peek(tokens) 466 | token = next.tok 467 | 468 | try: 469 | context.stack.append(parse_number(context)) 470 | return 471 | except ValueError: 472 | pass 473 | 474 | if token == 'hex': 475 | tokens.pop(0) 476 | context.base = 16 477 | elif token == ':': 478 | colon_compile(context) 479 | elif token == "(": 480 | parse_comment(context) 481 | # no compile time operations allowed currently 482 | elif token == 'constant': 483 | parse_const(context) 484 | elif token == 'variable': 485 | parse_var(context) 486 | elif token == 'array': 487 | parse_array(context) 488 | elif token in ['+', '-', '*']: 489 | parse_arith(context) 490 | else: 491 | parse_word(context) 492 | 493 | 494 | def parse(tokens): 495 | """Currently parse just supports fn, variable and constant definitions.""" 496 | context = Context() 497 | context.tokens = tokens 498 | 499 | while tokens: 500 | parse_token(context) 501 | 502 | if context.stack: 503 | raise CompileError("after parsing, there are still words on the stack!!:\n{0}".format( 504 | context.stack)) 505 | 506 | return context 507 | 508 | # output 509 | name_ass_table = { 510 | '-': 'minus', 511 | 'i': 'ii', 512 | 'j': 'jj', 513 | 'do': 'xdo', 514 | 'loop': 'xloop', 515 | '+loop': 'xplusloop', 516 | '.s': 'dots', 517 | '>r': 'tor', 518 | 'r>': 'rfrom', 519 | '1+': 'oneplus', 520 | '1-': 'oneminus', 521 | "[']": 'lit', # nice and hacky. this should just work as we don't really do compile time things (because of this weak-ass compiler). 522 | '<#': 'lessnum', 523 | '#s': 'nums', 524 | '#>': 'numgreater', 525 | } 526 | 527 | def try_ass_sub(name): 528 | sub_list = [ 529 | ('-', '_'), 530 | ('!', 'store'), 531 | ('@', 'fetch'), 532 | ('\+', 'plus'), 533 | ('\*', 'star'), 534 | ('0', 'zero'), 535 | ('2', 'two'), 536 | ('=', 'equal'), 537 | ('>', 'greater'), 538 | ('<', 'less'), 539 | ] 540 | 541 | for thing,sub in sub_list: 542 | name = re.sub(thing, sub, name) 543 | 544 | return name 545 | 546 | 547 | def name_to_ass(name): 548 | try: 549 | return name_ass_table[name] 550 | except KeyError: 551 | return try_ass_sub(name) 552 | 553 | 554 | def to_assembly(out, context): 555 | global LAST_WORD 556 | prev_word = LAST_WORD 557 | with open(out, 'w') as f: 558 | f.write("# compiled from Forth file\n\n") 559 | for stmt in context.stmts: 560 | prev_word = stmt.to_ass(f, prev_word) 561 | 562 | f.write(".set lastword, link_{0} /* last word */\n".format(prev_word)) 563 | 564 | # start 565 | def main(): 566 | parser = argparse.ArgumentParser(description='high-level Forth word compiler') 567 | parser.add_argument('file', help='The file that needs to be compiled') 568 | parser.add_argument('-o', default="", 569 | help='the output file') 570 | args = parser.parse_args() 571 | out = os.path.splitext(os.path.basename(args.file))[0] + ".s" if args.o == "" else args.o 572 | 573 | tokens = tokenize(args.file) 574 | context = parse(tokens) 575 | to_assembly(out, context) 576 | 577 | if __name__ == "__main__": 578 | main() 579 | -------------------------------------------------------------------------------- /tools/tiled2bin.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # convert tiled json data to binary map 3 | 4 | # currently this just writes the collision data tile array to binary 5 | 6 | import argparse 7 | import json 8 | import os 9 | import struct 10 | 11 | apartment = "/home/zeno/code/rath/assets/apartment-map.json" 12 | 13 | toi_map = { 14 | "collisions": 0, 15 | "kitchen": 1, 16 | "sink": 2, 17 | "toilet": 3, 18 | "bath": 4, 19 | "couch": 5, 20 | "tv": 6, 21 | "front-door": 7, 22 | "desk": 8, 23 | "bed": 9, 24 | "closet": 10, 25 | "clothes": 11, 26 | "gamecube": 12, 27 | "fridge": 13, 28 | "poster": 14, 29 | } 30 | 31 | def to_json(file): 32 | with open(file) as f: 33 | return json.load(f) 34 | 35 | def get_toi_data(data): 36 | global toi_map 37 | value_dict = {} 38 | for layer in data["layers"]: 39 | if layer["name"] in toi_map: 40 | value_dict[layer["name"]] = [1 if x != 0 else x for x in layer["data"]] 41 | return value_dict 42 | 43 | def zip_toi_data(toi_dict): 44 | collisions = toi_dict["collisions"] 45 | out_arr = [0x1 if x != 0 else x for x in collisions] 46 | for name, toi_list in toi_dict.items(): 47 | if name != "collisions": 48 | toi_val = toi_map[name] 49 | for i, val in enumerate(toi_list): 50 | if val != 0: 51 | out_arr[i] = 1 << toi_val 52 | return out_arr 53 | 54 | def to_file(array, out): 55 | bytes = struct.pack("{}H".format(len(array)), *array) 56 | with open(out, 'wb') as f: 57 | f.write(bytes) 58 | 59 | # start 60 | def main(): 61 | parser = argparse.ArgumentParser(description='convert tiled json data to binary map') 62 | parser.add_argument('file', help='a Tiled JSON file') 63 | parser.add_argument('-o', default="", 64 | help='the output file') 65 | 66 | args = parser.parse_args() 67 | out = os.path.splitext(os.path.basename(args.file))[0] + ".bin" if args.o == "" else args.o 68 | data = to_json(args.file) 69 | 70 | toi_dict = get_toi_data(data) 71 | output_array = zip_toi_data(toi_dict) 72 | to_file(output_array, out) 73 | 74 | if __name__ == "__main__": 75 | main() 76 | --------------------------------------------------------------------------------