├── .envrc ├── Makefile ├── .gitignore ├── images ├── demo2.png ├── editor │ ├── 1.png │ ├── 2.png │ ├── 3.png │ └── 4.png ├── star-def.png ├── double-def.png └── ram-screenshot.png ├── programs ├── comments.fs ├── music.fs ├── fibonacci.fs ├── words.fs ├── ddot.fs ├── dot-quote.fs ├── factorial.fs ├── slide.fs ├── prime.fs ├── case.fs ├── cursor.fs ├── print-stack.fs ├── number.fs ├── dtest.fs ├── memview.fs ├── pen.fs ├── rand.fs ├── keypress.fs ├── editor.fs ├── see.fs └── test.fs ├── .github └── workflows │ └── build.yml ├── spasm-ng.nix ├── flake.nix ├── extract.py ├── fmake.py ├── flake.lock ├── DOCUMENTATION.md ├── README.md ├── LICENSE └── forth.asm /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | spasm forth.asm forth.8xp -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.8xp 3 | result 4 | -------------------------------------------------------------------------------- /images/demo2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/demo2.png -------------------------------------------------------------------------------- /images/editor/1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/editor/1.png -------------------------------------------------------------------------------- /images/editor/2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/editor/2.png -------------------------------------------------------------------------------- /images/editor/3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/editor/3.png -------------------------------------------------------------------------------- /images/editor/4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/editor/4.png -------------------------------------------------------------------------------- /images/star-def.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/star-def.png -------------------------------------------------------------------------------- /images/double-def.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/double-def.png -------------------------------------------------------------------------------- /images/ram-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/siraben/ti84-forth/HEAD/images/ram-screenshot.png -------------------------------------------------------------------------------- /programs/comments.fs: -------------------------------------------------------------------------------- 1 | \ Define comment style. 2 | 3 | : ( IMMED 4 | BEGIN 5 | GETC 41 = IF 6 | EXIT 7 | THEN 8 | AGAIN 9 | ; 10 | -------------------------------------------------------------------------------- /programs/music.fs: -------------------------------------------------------------------------------- 1 | \ Display key codes interactively and play the notes 2 | 3 | : SONG 4 | BEGIN 5 | KEY DUP 5 <> 6 | WHILE 7 | DUP CR . 40000 SMIT 8 | REPEAT 9 | DROP 10 | ; 11 | -------------------------------------------------------------------------------- /programs/fibonacci.fs: -------------------------------------------------------------------------------- 1 | \ Recursive Fibonacci. Not very efficient as N goes up. 2 | : FIB 3 | DUP 2 < 4 | IF 5 | \ BASE CASE, DO NOTHING 6 | ELSE 7 | 1- DUP 1- RECURSE 8 | SWAP RECURSE 9 | + 10 | THEN 11 | ; 12 | -------------------------------------------------------------------------------- /programs/words.fs: -------------------------------------------------------------------------------- 1 | \ Taken directly from jonesforth 2 | 3 | : WORDS 4 | LATEST @ 5 | BEGIN 6 | ?DUP 7 | WHILE 8 | DUP ?HIDDEN NOT IF 9 | DUP ID. 10 | SPACE 11 | KEY DROP 12 | THEN 13 | @ 14 | REPEAT 15 | CR 16 | ; 17 | -------------------------------------------------------------------------------- /programs/ddot.fs: -------------------------------------------------------------------------------- 1 | \ Display double length numbers. 2 | : D. 3 | BASE @ D/MOD 4 | 2DUP OR 5 | IF 6 | RECURSE 7 | ELSE 8 | 2DROP 9 | THEN 10 | 11 | DUP 10 < 12 | IF 13 | 48 14 | ELSE 15 | 10 - 65 16 | THEN + EMIT 17 | ; 18 | -------------------------------------------------------------------------------- /programs/dot-quote.fs: -------------------------------------------------------------------------------- 1 | \ Run-time behavior of ." 2 | : ." BEGIN 3 | GETC DUP 10 3 * 4 + = IF \ 10 3 * 4 + is equivalent to 34, but I 4 | \ haven't implemented number parsing yet. 5 | DROP EXIT 6 | THEN 7 | EMIT 8 | AGAIN 9 | ; 10 | \ ." HELLO, WORLD!" => HELLO, WORLD! 11 | -------------------------------------------------------------------------------- /programs/factorial.fs: -------------------------------------------------------------------------------- 1 | \ Factorial, recursive definition. 2 | 3 | \ Look ma, recursion is easy! Just use the RECURSE word! 4 | : FACT 5 | DUP 0= IF 6 | DROP 1 \ base case 7 | ELSE 8 | DUP 1- RECURSE \ compute factorial of n - 1 9 | * \ and multiply with n 10 | THEN 11 | ; 12 | \ 5 FACT . => 120 13 | -------------------------------------------------------------------------------- /programs/slide.fs: -------------------------------------------------------------------------------- 1 | \ Interactively use the top and bottom arrows of the calculator to 2 | \ edit the top stack item. 3 | 4 | : SLIDE 5 | BEGIN 6 | KEY DUP 5 <> 7 | WHILE 8 | PAGE 9 | CASE 10 | 3 OF 1+ ENDOF \ up arrow 11 | 4 OF 1- ENDOF \ down arrow 12 | ENDCASE 13 | TS CR 14 | REPEAT 15 | DROP 16 | ; 17 | -------------------------------------------------------------------------------- /programs/prime.fs: -------------------------------------------------------------------------------- 1 | : TRUE 1 ; 2 | : FALSE 0 ; 3 | 4 | : PRIME? \ ( N -- F ) 5 | DUP 2 < IF DROP FALSE 6 | ELSE DUP 2 = IF DROP TRUE 7 | ELSE DUP 1 AND 0= IF DROP FALSE 8 | ELSE 3 9 | BEGIN 2DUP DUP * >= 10 | WHILE 2DUP MOD 0= 11 | IF 2DROP FALSE EXIT 12 | THEN 2 + 13 | REPEAT 2DROP TRUE 14 | THEN THEN THEN ; 15 | -------------------------------------------------------------------------------- /programs/case.fs: -------------------------------------------------------------------------------- 1 | \ Allows use of a CASE statement to make things easier. 2 | 3 | : CASE IMMED 4 | 0 5 | ; 6 | 7 | : OF IMMED 8 | ' OVER , 9 | ' = , 10 | (COMP) IF 11 | ' DROP , 12 | ; 13 | 14 | : ENDOF IMMED 15 | (COMP) ELSE 16 | ; 17 | 18 | : ENDCASE IMMED 19 | ' DROP , 20 | BEGIN 21 | ?DUP 22 | WHILE 23 | (COMP) THEN 24 | REPEAT 25 | ; 26 | -------------------------------------------------------------------------------- /programs/cursor.fs: -------------------------------------------------------------------------------- 1 | : MIN 2DUP > IF NIP ELSE DROP THEN ; 2 | : MAX 2DUP < IF NIP ELSE DROP THEN ; 3 | 4 | : PEN 5 | 0 0 6 | BEGIN 7 | KEY DUP 5 <> 8 | WHILE 9 | PAGE 10 | CASE 11 | 1 OF SWAP 1+ 15 MIN SWAP ENDOF 12 | 2 OF SWAP 1- 15 MIN SWAP ENDOF 13 | 4 OF 1+ 7 MIN ENDOF 14 | 3 OF 1- 7 MIN ENDOF 15 | ENDCASE 16 | 2DUP 17 | AT-XY 18 | STAR 19 | REPEAT 20 | PAGE 21 | DROP 22 | ; 23 | 24 | PEN 25 | -------------------------------------------------------------------------------- /programs/print-stack.fs: -------------------------------------------------------------------------------- 1 | \ Adapted from jonesforth 2 | 3 | \ Interesting to note that this still works despite having a register 4 | \ (BC) dedicated to the top of the stack, because the register 5 | \ contents get pushed onto it before we print the entire stack, so it 6 | \ works out. 7 | 8 | : .S 9 | SP@ 10 | BEGIN 11 | DUP SP0 @ < 12 | WHILE 13 | DUP @ . 14 | SPACE 15 | 2 + 16 | REPEAT 17 | DROP 18 | ; 19 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: 'build' 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v4.1.6 10 | - uses: cachix/install-nix-action@v15 11 | - run: nix --experimental-features 'nix-command flakes' build -L 12 | - name: "Copy ti84-forth" 13 | run: cp result/forth.8xp . 14 | - name: "Upload artifact to github" 15 | uses: actions/upload-artifact@v4.3.3 16 | with: 17 | name: forth.8xp 18 | path: forth.8xp 19 | -------------------------------------------------------------------------------- /programs/number.fs: -------------------------------------------------------------------------------- 1 | \ Reading a number, Forth style. 2 | 3 | \ We use these definitions because it's "faster". 4 | : '0' 10 << 4+ << ; \ 48 5 | : '9' '0' 9 + ; \ 57 6 | 7 | ( c a b -- < a <= c OR c <= b > ) 8 | : WITHIN OVER - >R - R> <= ; 9 | 10 | : NUM? '0' '9' WITHIN ; 11 | 12 | : NUM IMMED 13 | 0 14 | BEGIN 15 | GETC DUP NUM? NOT 16 | IF 17 | DROP \ we're done reading 18 | STATE @ IF 19 | \ interpreting 20 | ELSE 21 | ' LIT , 22 | , \ compiling 23 | THEN 24 | EXIT 25 | ELSE 26 | '0' - SWAP 10 * + 27 | THEN 28 | AGAIN 29 | ; 30 | 31 | \ NUM 1234 . 32 | \ => 1234 33 | -------------------------------------------------------------------------------- /spasm-ng.nix: -------------------------------------------------------------------------------- 1 | { stdenv, fetchFromGitHub, gcc, gmp, openssl, zlib }: 2 | 3 | stdenv.mkDerivation rec { 4 | pname = "spasm-ng"; 5 | version = "unstable-2020-08-03"; 6 | 7 | src = fetchFromGitHub { 8 | owner = "alberthdev"; 9 | repo = "spasm-ng"; 10 | rev = "221898beff2442f459b80ab89c8e1035db97868e"; 11 | sha256 = "0xspxmp2fir604b4xsk4hi1gjv61rnq2ypppr7cj981jlhicmvjj"; 12 | }; 13 | 14 | nativeBuildInputs = [ gcc ]; 15 | 16 | buildInputs = [ gmp openssl zlib ]; 17 | 18 | enableParallelBuilding = true; 19 | 20 | hardeningDisable = [ "fortify" ]; 21 | 22 | installPhase = '' 23 | install -Dm755 spasm -t $out/bin 24 | ''; 25 | } 26 | -------------------------------------------------------------------------------- /programs/dtest.fs: -------------------------------------------------------------------------------- 1 | \ Testing double length routines 2 | \ requires rand.fs and ddot.fs 3 | VAR SEED 4 | 7 SEED ! 5 | 6 | : SETSEED \ SEED THE RNG WITH X 7 | DUP 0= OR \ MAP 0 TO -1 8 | SEED ! 9 | ; 10 | 11 | 7 SEED ! 12 | 13 | : RAND \ RETURN A 16-BIT RANDOM NUMBER X 14 | SEED @ 15 | DUP << << << << << << << << << << << << << XOR 16 | DUP >> >> >> >> >> >> >> >> >> XOR 17 | DUP << << << << << << << XOR 18 | DUP SEED ! 19 | ; 20 | 21 | HERE SETSEED 22 | 23 | : D+_TEST 24 | BEGIN 25 | KEY 5 <> PAGE 26 | WHILE 27 | RAND RAND 2DUP D. CR 28 | RAND RAND 2DUP D. CR 29 | ." ----------" CR 30 | D+ D. CR 31 | REPEAT 32 | ; 33 | -------------------------------------------------------------------------------- /programs/memview.fs: -------------------------------------------------------------------------------- 1 | \ View memory locations interactively. 2 | \ Number of bytes that the plot window can see. 3 | 4 | 767 CONST PLOTSZ 5 | 12 CONST STEP 6 | 36 CONST STEPL 7 | 8 | : PP PAGE PLOT ; 9 | \ Memory slice; view the memory location on the stack. 10 | : MEMSLICE ( addr -- ) 11 | PLOTSS PLOTSZ CMOVE PP 12 | ; 13 | 14 | : MEMVIEW ( addr -- addr ) 15 | BEGIN 16 | KEY DUP 5 <> 17 | WHILE 18 | OVER MEMSLICE 19 | CASE 20 | 3 OF STEP + ENDOF 21 | 4 OF STEP - ENDOF 22 | 1 OF STEPL + ENDOF 23 | 2 OF STEPL - ENDOF 24 | ENDCASE 25 | REPEAT 26 | DROP 27 | ; 28 | 29 | \ View memory starting from the string buffer: 30 | \ BUF MEMVIEW 31 | ." Memview loaded." 32 | -------------------------------------------------------------------------------- /programs/pen.fs: -------------------------------------------------------------------------------- 1 | \ Interactive Pen Program 2 | 3 | \ See case.fs for definition of CASE 4 | 5 | \ Key codes 6 | \ 3 7 | \ 2 1 8 | \ 4 9 | 10 | \ ENTER 11 | \ 5 12 | 13 | VARIABLE PX 14 | VARIABLE PY 15 | 16 | : REDRAW 17 | PAGE 18 | PX ? 19 | PY ? 20 | ; 21 | 22 | : PEN_UP 23 | 1 PY +! 24 | ; 25 | 26 | : PEN_DOWN 27 | 65535 PY +! 28 | ; 29 | 30 | : PEN_RIGHT 31 | 1 PX +! 32 | ; 33 | 34 | : PEN_LEFT 35 | 65535 PX +! 36 | ; 37 | 38 | : PEN 39 | BEGIN 40 | KEY DUP 5 <> 41 | WHILE 42 | REDRAW 43 | CASE 44 | 3 OF PEN_UP ENDOF 45 | 4 OF PEN_DOWN ENDOF 46 | 1 OF PEN_RIGHT ENDOF 47 | 2 OF PEN_LEFT ENDOF 48 | ENDCASE 49 | REPEAT 50 | DROP 51 | ; 52 | -------------------------------------------------------------------------------- /programs/rand.fs: -------------------------------------------------------------------------------- 1 | \ Random number generator. 2 | 3 | VAR SEED 4 | 7 SEED ! 5 | 6 | : SETSEED \ SEED THE RNG WITH X 7 | DUP 0= OR \ MAP 0 TO -1 8 | SEED ! 9 | ; 10 | 11 | 7 SEED ! 12 | 13 | : RAND \ RETURN A 16-BIT RANDOM NUMBER X 14 | SEED @ 15 | DUP << << << << << << << << << << << << << XOR 16 | DUP >> >> >> >> >> >> >> >> >> XOR 17 | DUP << << << << << << << XOR 18 | DUP SEED ! 19 | ; 20 | 21 | HERE SETSEED 22 | 23 | : PP PAGE PLOT ; 24 | 25 | : RANDF 0 DO RAND OVER ! 2+ LOOP DROP ; 26 | 27 | 383 CONST PLOTSZ 28 | 29 | : RANDT PLOTSS PLOTSZ RANDF PP ; 30 | 31 | : RANDS 32 | BEGIN 33 | KEY 5 <> 34 | WHILE 35 | RANDT 36 | REPEAT 37 | ; 38 | 39 | ." RAND loaded." 40 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "A Forth interpreter for the TI-84 Plus calculators"; 3 | inputs = { 4 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 5 | utils.url = "github:numtide/flake-utils"; 6 | }; 7 | 8 | outputs = { self, nixpkgs, utils }: 9 | utils.lib.eachDefaultSystem (system: 10 | with import nixpkgs { inherit system; }; { 11 | defaultPackage = stdenv.mkDerivation { 12 | pname = "ti84-forth"; 13 | version = "head"; 14 | src = ./.; 15 | nativeBuildInputs = [ spasm-ng ]; 16 | buildPhase = '' 17 | spasm forth.asm forth.8xp 18 | ''; 19 | 20 | installPhase = '' 21 | mkdir -p $out 22 | mv forth.8xp $out/ 23 | ''; 24 | }; 25 | } 26 | ); 27 | } 28 | -------------------------------------------------------------------------------- /programs/keypress.fs: -------------------------------------------------------------------------------- 1 | \ Interactive Keypresses 2 | 3 | \ Let's make a program to interactively display the keypresses of the 4 | \ user. We have an `AKEY` word that returns the calculator keypress as 5 | \ an ASCII number on the stack using a conversion table (see `key_table` 6 | \ for the exact conversion). The following is a valid program that you 7 | \ can enter into the calculator. 8 | 9 | : SHOW_KEYS \ define a new word called SHOW_KEYS 10 | AKEY \ read an ASCII character from the user 11 | BEGIN 12 | DUP 0 <> \ test if the last key entered was not ENTER 13 | \ , as AKEY returns 0 in such a case 14 | WHILE 15 | DUP . SPACE SPACE EMIT CR \ duplicate the character, 16 | \ type two spaces, print 17 | \ it and type a newline 18 | AKEY \ read another character 19 | REPEAT \ repeat the body while the condition is true 20 | DROP \ the last key entered was ENTER, so drop it and return 21 | ; 22 | -------------------------------------------------------------------------------- /extract.py: -------------------------------------------------------------------------------- 1 | import argparse 2 | from PIL import Image 3 | import numpy as np 4 | 5 | def subrect(bitmap, x, y, width, height, subsample): 6 | sh = height // subsample 7 | sw = width // subsample 8 | return bitmap[y:y + sh * subsample:subsample, x:x + sw * subsample:subsample] 9 | 10 | def decode_bytes(bitmap): 11 | bitmap_flat = (bitmap.ravel() == 0).astype(np.uint8) 12 | return np.packbits(bitmap_flat) 13 | 14 | def png_to_bytes(image_path): 15 | img = Image.open(image_path).convert('L') 16 | data = np.array(img) 17 | offset = 2 18 | bit_size = 4 19 | height, width = data.shape 20 | transformed_data = subrect(data, offset, offset, width - 2 * offset, height - 2 * offset, bit_size) 21 | return decode_bytes(transformed_data) 22 | 23 | def main(): 24 | parser = argparse.ArgumentParser(description='Extract and decode binary data from a PNG image.') 25 | parser.add_argument('image_path', type=str, help='Path to the PNG image file') 26 | parser.add_argument('-o', '--output', type=str, help='Path to save the decoded output') 27 | args = parser.parse_args() 28 | 29 | decoded_bytes = png_to_bytes(args.image_path) 30 | decoded_string = decoded_bytes.tobytes().decode(errors='ignore') 31 | 32 | if args.output: 33 | with open(args.output, 'w') as out_file: 34 | out_file.write(decoded_string) 35 | else: 36 | print(decoded_string) 37 | 38 | if __name__ == '__main__': 39 | main() 40 | -------------------------------------------------------------------------------- /fmake.py: -------------------------------------------------------------------------------- 1 | import argparse 2 | import subprocess 3 | import sys 4 | import os 5 | 6 | def hexdump_to_asm(file_path): 7 | output_asm = f"{os.path.splitext(file_path)[0]}.asm" 8 | with open(file_path, 'rb') as f: 9 | hex_data = f.read().hex() 10 | 11 | formatted_hex = "" 12 | for i in range(0, len(hex_data), 32): 13 | line = hex_data[i:i+32] 14 | formatted_line = ", ".join([f"$" + line[j:j+2] for j in range(0, len(line), 2)]) 15 | formatted_hex += f".db {formatted_line}\n" 16 | 17 | # Add a null byte at the end 18 | formatted_hex += ".db $00\n" 19 | 20 | with open(output_asm, 'w') as f: 21 | f.write(formatted_hex) 22 | 23 | return output_asm 24 | 25 | def assemble_to_8xp(asm_path): 26 | output_8xp = f"{os.path.splitext(asm_path)[0]}.8xp" 27 | spasm_command = f"./spasm {asm_path} {output_8xp}" 28 | subprocess.run(spasm_command, shell=True) 29 | 30 | def fmake(file_path, assemble): 31 | asm_path = hexdump_to_asm(file_path) 32 | if assemble: 33 | assemble_to_8xp(asm_path) 34 | os.remove(asm_path) 35 | else: 36 | print(f"Assembly file created: {asm_path}") 37 | 38 | if __name__ == "__main__": 39 | parser = argparse.ArgumentParser(description='Convert Forth source files to TI-84+ executable format.') 40 | parser.add_argument('file_path', type=str, help='Path to the Forth source file.') 41 | parser.add_argument('--assemble', action='store_true', help='Assemble the .asm file to .8xp executable.') 42 | 43 | args = parser.parse_args() 44 | fmake(args.file_path, args.assemble) 45 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "nixpkgs": { 4 | "locked": { 5 | "lastModified": 1716330097, 6 | "narHash": "sha256-8BO3B7e3BiyIDsaKA0tY8O88rClYRTjvAp66y+VBUeU=", 7 | "owner": "NixOS", 8 | "repo": "nixpkgs", 9 | "rev": "5710852ba686cc1fd0d3b8e22b3117d43ba374c2", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "NixOS", 14 | "ref": "nixos-unstable", 15 | "repo": "nixpkgs", 16 | "type": "github" 17 | } 18 | }, 19 | "root": { 20 | "inputs": { 21 | "nixpkgs": "nixpkgs", 22 | "utils": "utils" 23 | } 24 | }, 25 | "systems": { 26 | "locked": { 27 | "lastModified": 1681028828, 28 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 29 | "owner": "nix-systems", 30 | "repo": "default", 31 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 32 | "type": "github" 33 | }, 34 | "original": { 35 | "owner": "nix-systems", 36 | "repo": "default", 37 | "type": "github" 38 | } 39 | }, 40 | "utils": { 41 | "inputs": { 42 | "systems": "systems" 43 | }, 44 | "locked": { 45 | "lastModified": 1710146030, 46 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 47 | "owner": "numtide", 48 | "repo": "flake-utils", 49 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "numtide", 54 | "repo": "flake-utils", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /programs/editor.fs: -------------------------------------------------------------------------------- 1 | \ An editor. Since we're using a lot of memory we're going to assign 2 | \ it to use AppBackupScreen. 3 | 4 | UALT 5 | : ( 6 | BEGIN 7 | GETC 41 = IF EXIT THEN 8 | AGAIN 9 | ; IMMED 10 | 11 | 3 CONST UP 12 | 4 CONST DN 13 | 1 CONST R 14 | 2 CONST L 15 | 10 CONST DEL 16 | 9 CONST CL 17 | 18 | : NT S" EDITOR " DROP ; 19 | 20 | : TYPE ( c-addr u -- ) 0 DO DUP C@ EMIT 1+ LOOP DROP ; 21 | 22 | : PL 16 TYPE ; 23 | 24 | ( Display the text area ) 25 | : TXT ( addr -- addr ) 26 | DUP 27 | 1 0 AT-XY 28 | 112 TYPE 29 | ; 30 | 31 | \ Short names conserve some space. 32 | ( addr -- addr ) 33 | : NL 16 + ; 34 | : PL 16 - ; 35 | : NP 80 + ; 36 | : PP 80 - ; 37 | 38 | VAR CT 39 | 40 | \ Set cursor to (0,0) 41 | : ORI 0 0 AT-XY ; 42 | 43 | \ Display the title. 44 | : T ORI CT @ INVTXT PL INVTXT ; 45 | 46 | \ Draw a frame. 47 | : F PAGE T TXT ; 48 | 49 | \ Convert a line number to character number. 50 | : CN ( linum -- charnum ) 51 | 16 * 52 | ; 53 | 54 | \ Mark line. 55 | : ML ( addr linum -- addr linum ) 56 | 2DUP 57 | DUP 1+ 0 AT-XY 58 | CN + INVTXT PL INVTXT 59 | ; 60 | 61 | : MF ( addr linum -- addr linum ) OVER F DROP ML ; 62 | 63 | ( addr count char -- ) 64 | : FILL -ROT 0 DO 2DUP C! 1+ LOOP 2DROP ; 65 | 66 | : DL ( addr linum -- addr linum ) 67 | 2DUP CN + 16 32 FILL 68 | ; 69 | 70 | : DT S" --- DELETE --- " DROP ; 71 | 72 | : DM ( addr -- addr ) 73 | DT CT ! 74 | 0 75 | BEGIN 76 | MF 77 | KEY DUP 10 <> 78 | WHILE 79 | CASE 80 | UP OF DUP 0= IF DROP 6 ELSE 1- THEN ENDOF 81 | DN OF DUP 6 = IF DROP 0 ELSE 1+ THEN ENDOF 82 | CL OF DL ENDOF 83 | ENDCASE 84 | REPEAT 85 | 2DROP 86 | ; 87 | 88 | : RT NT CT ! ; 89 | 90 | : EDIT ( addr -- addr ) 91 | TOG-SCRL 92 | BEGIN 93 | RT F 94 | KEY DUP 5 <> 95 | WHILE 96 | CASE 97 | UP OF PL ENDOF 98 | DN OF NL ENDOF 99 | R OF NP ENDOF 100 | L OF PP ENDOF 101 | DEL OF DM ENDOF 102 | ENDCASE 103 | REPEAT 104 | TOG-SCRL 105 | DROP 106 | PAGE 107 | ; 108 | -------------------------------------------------------------------------------- /programs/see.fs: -------------------------------------------------------------------------------- 1 | \ We want parenthetical comments. 2 | : ( IMMED 3 | BEGIN 4 | GETC 41 = IF 5 | EXIT 6 | THEN 7 | AGAIN 8 | ; 9 | 10 | ( Version of SEE that handles string literals.) 11 | 12 | : SEE 13 | WORD FIND ( find the dictionary entry to decompile ) 14 | 15 | ( Now we search again, looking for the next word in the dictionary. This gives us 16 | the length of the word that we will be decompiling. Well, mostly it does. ) 17 | HERE @ ( address of the end of the last compiled word ) 18 | LATEST @ ( word last curr ) 19 | BEGIN 20 | 2 PICK ( word last curr word ) 21 | OVER ( word last curr word curr ) 22 | <> ( word last curr word<>curr? ) 23 | WHILE ( word last curr ) 24 | NIP ( word curr ) 25 | DUP @ ( word curr prev which becomes: word last curr ) 26 | REPEAT 27 | 28 | DROP ( at this point, the stack is: start-of-word end-of-word ) 29 | SWAP ( end-of-word start-of-word ) 30 | 31 | ( begin the definition with : NAME [IMMEDIATE] ) 32 | 58 EMIT SPACE DUP ID. SPACE 33 | DUP ?IMMED IF ." IMMEDIATE " THEN 34 | 35 | >DFA ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) 36 | 37 | ( now we start decompiling until we hit the end of the word ) 38 | BEGIN ( end start ) 39 | 2DUP > 40 | WHILE 41 | DUP @ ( end start codeword ) 42 | 43 | CASE 44 | ' LIT OF ( is it LIT ? ) 45 | 2+ DUP @ ( get next word which is the integer constant ) 46 | . ( and print it ) 47 | ENDOF 48 | ' LITSTR OF ( is it LITSTRING ? ) 49 | 83 EMIT 34 EMIT SPACE ( print S" ) 50 | 2+ DUP @ ( get the length ) 51 | SWAP 2+ SWAP ( end start+2 length ) 52 | 2DUP TELL ( print the string ) 53 | 34 EMIT SPACE ( finish the string with a final quote ) 54 | + ( end start+4+len, aligned ) 55 | 1+ ( because we're about to add 4 below ) 56 | ENDOF 57 | ' 0BRANCH OF ( is it 0BRANCH ? ) 58 | ." 0BRANCH ( " 59 | 2+ DUP @ ( print the offset ) 60 | . 61 | ." ) " 62 | ENDOF 63 | ' BRANCH OF ( is it BRANCH ? ) 64 | ." BRANCH ( " 65 | 2+ DUP @ ( print the offset ) 66 | . 67 | ." ) " 68 | ENDOF 69 | ' ' OF ( is it ' TICK ? ) 70 | 39 EMIT SPACE 71 | 2+ DUP @ ( get the next codeword ) 72 | CFA> ( and force it to be printed as a dictionary entry ) 73 | ID. SPACE 74 | ENDOF 75 | ' EXIT OF ( is it EXIT? ) 76 | ( We expect the last word to be EXIT, and if it is then we don't print it 77 | because EXIT is normally implied by ;. EXIT can also appear in the middle 78 | of words, and then it needs to be printed. ) 79 | 2DUP ( end start end start ) 80 | 2+ ( end start end start+4 ) 81 | <> IF ( end start | we're not at the end ) 82 | ." EXIT " 83 | THEN 84 | ENDOF 85 | ( default case: ) 86 | DUP ( in the default case we always need to DUP before using ) 87 | CFA> ( look up the codeword to get the dictionary entry ) 88 | ID. SPACE ( and print it ) 89 | ENDCASE 90 | 91 | 2+ ( end start+4 ) 92 | REPEAT 93 | 94 | 59 EMIT CR 95 | 96 | 2DROP ( restore stack ) 97 | ; 98 | -------------------------------------------------------------------------------- /programs/test.fs: -------------------------------------------------------------------------------- 1 | \ This file tests the entire workflow. 2 | 3 | \ Run this command to generate the assembly file. 4 | 5 | \ hexdump -e '".db "16/1 "$%02x, " "\n"' test.fs | sed 's/$ ,/$00,/g' | sed 's/.$//' > test.asm && ./spasm test.asm test.8xp || rm test.asm 6 | 7 | \ What it does is convert this file into a list of ASCII bytes and run 8 | \ the assembler on it to generate a valid "program". All you need to 9 | \ do next is flash it. 10 | 11 | \ After flashing the program and the interpreter, in the REPL simply 12 | \ type "LOAD TEST", then it will work! 13 | 14 | \ Larger comments. We need them. Note that this only works 15 | \ multi-line in loaded files. In the REPL you have to end the comment 16 | \ with a ) before you hit ENTER. 17 | 18 | : ( IMMED 19 | BEGIN 20 | GETC 41 = IF 21 | EXIT 22 | THEN 23 | AGAIN 24 | ; 25 | 26 | ( 27 | This should not be parsed, thanks to the definition of ( above. 28 | 29 | Format of a floating point number: 30 | 31 | |-------------+------+----------+-------------+---+---+---+---+---+---| 32 | | Byte number | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 33 | |-------------+------+----------+-------------+---+---+---+---+---+---| 34 | | Purpose | Sign | Exponent | Significand | " | " | " | " | " | " | 35 | |-------------+------+----------+-------------+---+---+---+---+---+---| 36 | 37 | Significand numbers are stored BCD encoded: 38 | 39 | 12345 => $12 $34 $50 40 | So we need to convert ASCII 0-9 into BCD. 41 | ) 42 | : SEE 43 | WORD FIND ( find the dictionary entry to decompile ) 44 | 45 | ( Now we search again, looking for the next word in the dictionary. This gives us 46 | the length of the word that we will be decompiling. Well, mostly it does. ) 47 | HERE @ ( address of the end of the last compiled word ) 48 | LATEST @ ( word last curr ) 49 | BEGIN 50 | 2 PICK ( word last curr word ) 51 | OVER ( word last curr word curr ) 52 | <> ( word last curr word<>curr? ) 53 | WHILE ( word last curr ) 54 | NIP ( word curr ) 55 | DUP @ ( word curr prev which becomes: word last curr ) 56 | REPEAT 57 | 58 | DROP ( at this point, the stack is: start-of-word end-of-word ) 59 | SWAP ( end-of-word start-of-word ) 60 | 61 | ( begin the definition with : NAME [IMMEDIATE] ) 62 | 58 EMIT SPACE DUP ID. SPACE 63 | DUP ?IMMED IF ." IMMEDIATE " THEN 64 | 65 | >DFA ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) 66 | 67 | ( now we start decompiling until we hit the end of the word ) 68 | BEGIN ( end start ) 69 | 2DUP > 70 | WHILE 71 | DUP @ ( end start codeword ) 72 | 73 | CASE 74 | ' LIT OF ( is it LIT ? ) 75 | 2+ DUP @ ( get next word which is the integer constant ) 76 | . ( and print it ) 77 | ENDOF 78 | ' LITSTR OF ( is it LITSTRING ? ) 79 | 83 EMIT 34 EMIT SPACE ( print S" ) 80 | 2+ DUP @ ( get the length ) 81 | SWAP 2+ SWAP ( end start+2 length ) 82 | 2DUP TELL ( print the string ) 83 | 34 EMIT SPACE ( finish the string with a final quote ) 84 | + ( end start+4+len, aligned ) 85 | 1+ ( because we're about to add 4 below ) 86 | ENDOF 87 | ' 0BRANCH OF ( is it 0BRANCH ? ) 88 | ." 0BRANCH ( " 89 | 2+ DUP @ ( print the offset ) 90 | . 91 | ." ) " 92 | ENDOF 93 | ' BRANCH OF ( is it BRANCH ? ) 94 | ." BRANCH ( " 95 | 2+ DUP @ ( print the offset ) 96 | . 97 | ." ) " 98 | ENDOF 99 | ' ' OF ( is it ' TICK ? ) 100 | 39 EMIT SPACE 101 | 2+ DUP @ ( get the next codeword ) 102 | CFA> ( and force it to be printed as a dictionary entry ) 103 | ID. SPACE 104 | ENDOF 105 | ' EXIT OF ( is it EXIT? ) 106 | ( We expect the last word to be EXIT, and if it is then we don't print it 107 | because EXIT is normally implied by ;. EXIT can also appear in the middle 108 | of words, and then it needs to be printed. ) 109 | 2DUP ( end start end start ) 110 | 2+ ( end start end start+4 ) 111 | <> IF ( end start | we're not at the end ) 112 | ." EXIT " 113 | THEN 114 | ENDOF 115 | ( default case: ) 116 | DUP ( in the default case we always need to DUP before using ) 117 | CFA> ( look up the codeword to get the dictionary entry ) 118 | ID. SPACE ( and print it ) 119 | ENDCASE 120 | 121 | 2+ ( end start+4 ) 122 | REPEAT 123 | 124 | 59 EMIT CR 125 | 126 | 2DROP ( restore stack ) 127 | ; 128 | 129 | ." TEST loaded." 130 | ." We have used " USED . ." bytes of RAM." 131 | -------------------------------------------------------------------------------- /DOCUMENTATION.md: -------------------------------------------------------------------------------- 1 | # Forth Word Documentation 2 | All stack elements are 16-bit unsigned integers. 3 | ## CODE words 4 | ### EXIT ( -- ) 5 | ### DUP ( n -- n n ) 6 | Duplicates the top element of the stack. 7 | ### + ( a b -- a+b ) 8 | Adds the top two elements of the stack. 9 | ### - ( a b -- a-b ) 10 | Subtracts the top element of the stack from the one immediately before 11 | it. 12 | ### AND ( a b -- a&b ) 13 | Bitwise `and` of the top two elements of the stack. 14 | ### OR ( a b -- a||b ) 15 | Bitwise `or` of the top two elements of the stack. 16 | ### XOR ( a b -- a^b ) 17 | Bitwise `xor` of the top two elements of the stack. 18 | ### << ( a -- a<<1 ) 19 | Left shift of the top element of the stack. 20 | ### >> ( a -- a>>1 ) 21 | Right shift of the top element of the stack. 22 | ### INVERT 23 | ### DROP ( a b -- a ) 24 | Drop the top element of the stack. 25 | ### SWAP ( a b -- b a ) 26 | Swap the top two elements of the stack. 27 | ### OVER ( a b -- a b a ) 28 | Push the second-top element of the stack onto the top of the stack. 29 | ### ROT 30 | ### -ROT 31 | ### 2DROP 32 | ### 2DUP 33 | ### 2SWAP 34 | ### 1+ ( n -- n+1 ) 35 | Increment the top element of the stack. 36 | ### 1- ( n -- n-1 ) 37 | Decrement the top element of the stack. 38 | ### 2+ ( n -- n+2 ) 39 | Increment the top element of the stack by 2. 40 | ### 2- ( n -- n-2 ) 41 | Decrement the top element of the stack by 2. 42 | ### 4+ ( n -- n+4 ) 43 | Increment the top element of the stack by 4. 44 | ### 4- ( n -- n-4 ) 45 | Decrement the top element of the stack by 4. 46 | ### >R ( a -- ) 47 | ### R> ( -- a) 48 | ### RDROP ( -- ) 49 | ### LIT 50 | ### LITSTR 51 | ### TELL 52 | ### STRLEN 53 | ### STRCHR 54 | ### ! ( val addr -- ) 55 | ### @ ( addr -- val ) 56 | ### +! 57 | ### -! 58 | ### C! 59 | ### C@ 60 | ### C@C! 61 | ### CMOVE 62 | ### EXECUTE 63 | ### BASE 64 | ### STATE 65 | ### LATEST 66 | ### SP0 67 | ### [ 68 | ### ] 69 | ### ?SE 70 | ### HERE 71 | ### DOCOL 72 | ### BUF 73 | ### BUFSZ 74 | ### WBUF 75 | ### WBUFSZ 76 | ### RP0 77 | ### H0 78 | ### F_IMMED 79 | ### F_HIDDEN 80 | ### F_LENMASK 81 | ### SCR 82 | ### PLOTSS 83 | ### ' 84 | ### , 85 | ### SP@ 86 | ### SP! 87 | ### RP@ 88 | ### RP! 89 | ### BRANCH 90 | ### 0BRANCH 91 | ### ?DUP 92 | ### = ( n1 n2 -- b ) 93 | ### <> ( n1 n2 -- b ) 94 | ### >= ( n1 n2 -- b ) 95 | ### <= ( n1 n2 -- b ) 96 | ### < ( n1 n2 -- b ) 97 | ### > ( n1 n2 -- b ) 98 | ### 0= ( n1 -- b ) 99 | ### RAND ( -- n ) 100 | ### ASK 101 | ### KEY 102 | ### KEYC 103 | Non-blocking form of `KEY`. 104 | ### EMIT ( a -- ) 105 | Print the character with the ASCII code form the top of the stack. 106 | ### . ( a -- ) 107 | Pop the top element from the stack and print it. 108 | ### ? ( addr -- ) 109 | Print the value pointed to by `addr`. 110 | ### AKEY ( -- a ) 111 | Block until a key that corresponds to a printable ASCII character is 112 | given, then push that value onto the stack. 113 | ### TO_ASCII ( a -- b ) 114 | Convert a value given by `KEY` to the corresponding ASCII character code. 115 | ### * ( a b -- a*b ) 116 | Multiply the top two elements on the stack. 117 | ### /MOD 118 | ### CR 119 | Carriage return. 120 | ### AT-XY 121 | ### PUTS ( addr -- ) 122 | Print a NUL-delimited string. 123 | ### PUTLN ( addr -- ) 124 | Print a NUL-delimited string followed by a carriage return. 125 | ### GETS ( -- ) 126 | Get characters from the user until `[ENTER]` is pressed, storing the 127 | result in the memory location`BUF`. 128 | ### GETC ( -- a ) 129 | Get the next character from `BUF`. 130 | ### UNGETC ( -- ) 131 | Unget the last character from `BUF`. 132 | ### WORD ( -- addr len ) 133 | Read a full, space-delimited word from `BUF` and push the address of 134 | `WBUF` followed by the length of the word onto the stack. 135 | ### ?IMMED ( addr -- b ) 136 | Given a pointer returned from `FIND`, return whether or not the word 137 | is marked `IMMEDIATE`. Follows boolean convention. 138 | ### IMMED ( -- ) 139 | Mark the last word (or currently-being-defined word) as `IMMEDIATE`. 140 | ### >NFA ( fptr -- addr ) 141 | Given a `FIND`-returned pointer, return the address of the start of 142 | the word's name string. 143 | ### >CFA ( fptr -- addr ) 144 | Given a `FIND`-returned pointer, return the address of the start of 145 | the word's Code Field Address (CFA). 146 | ### STR= ( addr1 addr2 -- b ) 147 | Given two addresses of NUL-terminated string, check whether they are 148 | equal character-by-character. 149 | ### FIND ( addr len -- fptr ) 150 | Given the address of a word string and its length, return a `FIND` 151 | pointer to the word in the dictionary. Return `0` if the word is not 152 | found. 153 | ### WB 154 | Writeback the (possibly) modified contents from `data_start` to `data_end`. 155 | ### CREATE 156 | ### DOCOL_H 157 | Writes the three bytes corresponding to `call docol` to the memory 158 | location pointed to by `HERE`. 159 | ### (DOES>) 160 | Created by `DOES>`, or can be called as well. Sets the `call` 161 | destination of the `LATEST` word's Code Field Address to the address 162 | directly after `DOES>`, which is the instruction pointer at the time 163 | `DOES>` is invoked. See `DOES>` for more information. 164 | ### DOES> 165 | Used in words that can create new words. See the following example: 166 | ```forth 167 | : CONSTANT 168 | WORD CREATE DOCOL_H , 169 | DOES> @ 170 | ; 171 | ``` 172 | 173 | The word `CONSTANT` in the example reads a word, creates the link and 174 | name header, followed by three bytes corresponding to `call docol`, 175 | followed by the top element of the stack. `DOES>` denotes the end of 176 | `CONSTANT`'s action and the start of the action of what the word 177 | __created by__ `CONSTANT` will do. In other words, we can use it like 178 | this: 179 | 180 | ```forth 181 | 31415 CONSTANT PI 182 | PI . \ => 31415 183 | ``` 184 | The words following `DOES>` are executed on the same stack, but with 185 | the top element of the stack begin the address of the word defined by 186 | `CONSTANT`'s children. That's why we can just deference the pointer 187 | with `@` and thus get the constant value out. 188 | 189 | What's happening is that `DOES>` is an immediate word that compiles 190 | `(DOES>)` followed by the 3 bytes representing `call dodoes` to the 191 | current word being defined (i.e. `CONSTANT`). When `CONSTANT` is 192 | invoked, the invocation of `(DOES>)` sets the destination address of 193 | the `call` instruction in the _new_ word (whatever it may be) being 194 | defined (in this case, `PI`) to the byte _after_ `(DOES>)`, so that 195 | the new word starts its Code Field Address with `call XXXX`, 196 | where `XXXX` is the address after the location of `(DOES>)` in 197 | `CONSTANT`. Then, `(DOES>)` acts like `EXIT`, resuming execution. 198 | 199 | This means you can share the same body code between words created by a 200 | word using `DOES>`, reducing wasted space. 201 | 202 | ### PAGE 203 | Clear the screen. 204 | ### HIDDEN 205 | ### ?HIDDEN ( fptr -- b ) 206 | Given a `FIND` pointer, return whether or not the word is hidden. 207 | ### NIP ( a b -- b ) 208 | ### TUCK ( a b -- b a b ) 209 | Tucks the top element two locations prior. 210 | ### '0' 211 | ### '9' 212 | ### I 213 | ### SMIT ( freq dur -- ) 214 | Sound emit. Play the "frequency" with the duration. The convention 215 | is that the lower the frequency number the higher it actually is in 216 | real life. 217 | ### PLAY 218 | ### PLOT ( -- ) 219 | ### GETP 220 | ### DARKP 221 | ### TOGP 222 | ### LITP 223 | ### PN 224 | ### BYE 225 | Exit the program. 226 | 227 | ## WORD Words 228 | ### SQ 229 | ### .Q 230 | ### USED ( -- n ) 231 | Returns how many bytes have been used (starting from `H0`). 232 | ### SIMG 233 | ### LIMG 234 | ### >DFA 235 | ### : 236 | ### ; 237 | ### MOD 238 | ### / 239 | ### NEGATE 240 | ### TRUE 241 | ### FALSE 242 | ### NOT 243 | ### LITERAL 244 | ### ID. 245 | ### HIDE 246 | ### IF 247 | ### THEN 248 | ### ELSE 249 | ### BEGIN 250 | ### UNTIL 251 | ### AGAIN 252 | ### WHILE 253 | ### REPEAT 254 | ### CHAR 255 | ### (COMP) 256 | ### CONST 257 | ### ALLOT 258 | ### CELLS 259 | ### RECURSE 260 | ### VAR 261 | ### DO 262 | ### LOOP 263 | ### +LOOP 264 | ### FORGET 265 | ### WITHIN 266 | ### NUM? 267 | ### NUM ( -- n ) 268 | ### CFA> 269 | ### PICK 270 | ### U. ( n -- ) 271 | ### UWIDTH 272 | ### SPACES ( n -- ) 273 | ### U.R 274 | ### U. 275 | ### . 276 | ### .S 277 | ### SEE 278 | ### WORDS 279 | ### CASE 280 | ### OF 281 | ### ENDOF 282 | ### ENDCASE 283 | ### WR 284 | ### STAR 285 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Forth implementation for the TI-84+ calculator 2 | ![Defining DOUBLE](images/double-def.png) 3 | 4 | ## Features 5 | - A 16-bit Forth on an 8-bit chip 6 | - Contains ~225 words (and counting) for everything from memory 7 | management to drawing pixels, decompilation, and even playing sounds 8 | over the I/O port. 9 | - Support for writeback (persistent data across program runs). Use 10 | `SIMG` (save image) and `LIMG` (load image) to save the words you've 11 | defined in a session. 12 | - Highly readable and customizable implementation, see `forth.asm`. 13 | 14 | ## Getting the interpreter 15 | Download the latest binary from the 16 | [Releases](https://github.com/siraben/ti84-forth/releases) page or get 17 | the bleeding edge output from the [GitHub Actions 18 | CI](https://github.com/siraben/ti84-forth/actions). 19 | 20 | ### The Real Thing 21 | - A TI-84+ calculator! 22 | - [TI Connect CE](https://education.ti.com/en/products/computer-software/ti-connect-ce-sw) 23 | - (Optional) A 2.5 mm to 3.5 mm audio cable to connect the I/O port 24 | with a speaker. 25 | 26 | Flash `forth.8xp` to your calculator. Make sure there's enough space 27 | and that you have backed up your calculator! An easy way to back up 28 | RAM contents is by creating a group, refer to the manual on how to do 29 | this. 30 | 31 | ## Why TI-84+? 32 | This is a calculator that is more or less ubiquitous among high school 33 | and university students throughout the world. It's not going extinct 34 | anytime soon (except perhaps to newer models such as the TI-84 CE). 35 | But let's face it. TI-BASIC is not a nice language; it's slow and 36 | suffers from lack of low-level bindings. There's no REPL. We want a 37 | language that gives the programmer the full power of the 38 | calculator—treating it as the computer it is. In fact, people already 39 | do, by writing assembly programs, but assembly has its share of 40 | disadvantages. 41 | 42 | ## Why Forth? 43 | Assembly is painful to program in. Programs crash at the slightest 44 | hint of error. Development is a slow process, and you have to keep 45 | reinventing the wheel with each program. 46 | 47 | Wouldn't it be great to have a programming language on the TI-84+ 48 | that's much faster than TI-BASIC but easier to understand and as low 49 | level as assembly? Forth is just that. (Read _Starting FORTH_ for an 50 | excellent introduction to Forth). It's low level, it's simple, but 51 | also _easy to type_, especially when you're on a calculator with a 52 | non-QWERTY keyboard. It is a very powerful language, allowing you to 53 | do things like change the syntax of the language itself. `IF`, 54 | `WHILE`, `CONSTANT` etc. statements are all implemented in Forth! 55 | Think of it as an untyped C with a REPL and the power of Lisp macros. 56 | 57 | It's also easy to implement incrementally through continuous testing. 58 | In fact, once the base REPL was implemented, most of the programming 59 | and testing happened _on_ the calculator itself! 60 | 61 | ## Building 62 | ### Nix 63 | ```sh 64 | nix build 65 | ``` 66 | ### Mac/Linux 67 | - [spasm-ng Z80 assembler](https://github.com/alberthdev/spasm-ng) 68 | - If you're on a Mac, you will need to install `openssl` as a 69 | dependency, for instance on Homebrew: 70 | ```shell 71 | brew install openssl 72 | cd /usr/local/include 73 | ln -s ../opt/openssl/include/openssl . 74 | ``` 75 | - Compile the assembler with `make` (check required packages for 76 | your system). 77 | 78 | Copy `forth.asm` into the cloned folder. Then run: 79 | 80 | ```shell 81 | ./spasm forth.asm forth.8xp 82 | ``` 83 | 84 | ### Emulated 85 | There are many emulators out there, one that doesn't require 86 | installation is 87 | [jsTIfied](https://www.cemetech.net/projects/jstified/). Read the 88 | website's details for more information. You'll need to obtain a ROM 89 | image as well, which I can't provide here, but a simple web search 90 | might help. 91 | 92 | ## Using the Interpreter 93 | Run the program with `Asm(prgmFORTH)`, hit `2nd` then `ALPHA` to enter 94 | alpha lock mode, and now you can type the characters from `A-Z`. Here 95 | are a couple of things to keep in mind. 96 | 97 | - Left and right arrows are bound to character delete and space insert 98 | respectively. 99 | - Hitting `CLEAR` clears the current input line. 100 | - Hitting `ENTER` sends it over to the interpreter. 101 | 102 | If you want to see the keymap, find the label `key_table` in 103 | `forth.asm`. This table maps the keys received by `KEY` to the 104 | appropriate character. 105 | 106 | ### Typing ASCII Characters 107 | See the `2nd` or `ALPHA` key combos (in blue on the calculator) for 108 | information on how to type the following characters: `[]{}"?:`. 109 | 110 | | Character | Key Sequence | 111 | | :---: | :---: | 112 | | `;` | `2nd .` | 113 | | `!` | `2nd PRGM` | 114 | | `@` | `2nd APPS` | 115 | | `=` | `2nd MATH` | 116 | | `'` | `2nd +` | 117 | | `<` | `2nd X,T,Θ,n` | 118 | | `>` | `2nd STAT` | 119 | | `\` | `2nd ÷` | 120 | | `_` | `2nd VARS` | 121 | 122 | ## Exiting the Interpreter 123 | Type `BYE` and hit `ENTER`. 124 | 125 | Here is the more concise "Loading Forth Programs onto the Calculator" section: 126 | 127 | ## Loading Forth Programs onto the Calculator 128 | 129 | Use the provided `fmake.py` script to convert Forth source files to the TI-84+ executable format. 130 | 131 | Run the script to generate the assembly file: 132 | 133 | ```sh 134 | python fmake.py hello.fs 135 | ``` 136 | 137 | To also assemble it to a `.8xp` executable, add the `--assemble` flag: 138 | 139 | ```sh 140 | python fmake.py hello.fs --assemble 141 | ``` 142 | 143 | Transfer `hello.8xp` to your calculator using [TI Connect CE](https://education.ti.com/en/products/computer-software/ti-connect-ce-sw) and load it into the interpreter by running `LOAD HELLO` in the Forth REPL on your calculator. 144 | 145 | ## Example Programs 146 | See `programs/` for program samples, including practical ones. 147 | 148 | ## Available Words 149 | ```text 150 | EXIT DUP + - AND OR XOR << >> INVERT DROP SWAP OVER ROT -ROT 2DROP 151 | 2DUP 2SWAP 1+ 1- 2+ 2- >R R> R@ 2>R 2R> RDROP 2RDROP LIT LITSTR S" .Q 152 | TELL STRLEN STRCHR ! @ +! -! C! C@ C@C! CMOVE EXECUTE BASE PREC 153 | STATE LATEST SP0 [ ] ?SE HERE DOCOL BUF BUFSZ WBUFP WBUF WBUFSZ RP0 H0 154 | F_IMMED F_HIDDEN F_LENMASK SCR ABS PLOTSS ' , C, SP@ SP! RP@ RP! 155 | BRANCH 0BRANCH ?DUP = <> >= <= < > 0= KEY KEYC EMIT T. ? AKEY 156 | TO_ASCII * /MOD SQRT FRAND F. FREAD F* FSQUARE F= FDUP FDROP FSWAP F+ 157 | F/ FRCI F- FSQRT MD5 D/MOD UM* D+ M+ DS SPACE CR AT-XY PUTS PUTLN GETS 158 | GETC UNGETC WORD ?IMMED IMMED >NFA >CFA STR= FIND WB USED SIMG LIMG 159 | >DFA CREATE DOCOL_H : ; (DOES>) DOES> PAGE HIDDEN ?HIDDEN MOD / NEGATE 160 | TRUE FALSE NOT LITERAL NIP TUCK ID. HIDE IF THEN ELSE BEGIN UNTIL 161 | AGAIN WHILE REPEAT CHAR (COMP) CONST ALLOT CELLS RECURSE VAR DO LOOP 162 | +LOOP FORGET '0' '9' WITHIN NUM? CFA> PICK U. UWIDTH SPACES U.R U. 163 | . DEPTH .S HEX DEC SEE WORDS CASE OF ENDOF ENDCASE I J CSCR CBLK FBLK 164 | RUN LOAD SMIT PLOT WR PN BYE STAR 165 | ``` 166 | Note that floating point routines are commented out by default to save space. 167 | 168 | ## Screenshots 169 | ### Combine words in powerful, practical ways 170 | Combine low-level memory words with drawing words and user input words 171 | to create an arrow-key scrollable screen for viewing RAM memory. See 172 | the 20 (or less) lines of code at `programs/memview.fs`. 173 | 174 | ![What forth.asm looks like loaded into RAM](images/ram-screenshot.png) 175 | 176 | ### TI-84+ inside 177 | ![key-prog program](images/demo2.png) 178 | 179 | ### Load programs 180 | Simple unfinished modal text editor with a scrollable screen. 181 | 182 | ![Unfinished text editor](images/editor/1.png) 183 | 184 | ## Design Notes 185 | ### Use of Macros 186 | Judicious use of macros has greatly improved the readability of the code. 187 | This was directly inspired by the _jonesforth_ implementation (see 188 | Reading List). 189 | ### Register Allocation 190 | One notable feature of this Forth is the use of a register to keep 191 | track of the top element in the stack. 192 | 193 | | Z80 Register | Forth VM Register | 194 | | :---: | :---: | 195 | | DE | Instruction pointer (IP) | 196 | | HL | Working register (W) | 197 | | BC | Top of stack (TOS) | 198 | | IX | Return stack pointer (RSP) | 199 | | SP | Parameter stack pointer (PSP) | 200 | 201 | ### Reading List 202 | Documentation can vary from very well-documented to resorting to 203 | having to read the source code of `spasm-ng` to figure out how 204 | `#macro` worked. See examples such as `defcode` and `defword`. I 205 | couldn't make `defconst` or `defvar`, however, but this was fixed by 206 | writing it out manually. 207 | 208 | - [General Z80 guide](http://jgmalcolm.com/z80/#advanced) 209 | - [Moving Forth](http://www.bradrodriguez.com/papers/moving1.htm) 210 | - [Learn TI-83 Plus Assembly In 28 Days](http://tutorials.eeems.ca/ASMin28Days/welcome.html) 211 | - [KnightOS Kernel](https://github.com/KnightOS/kernel) 212 | - [Starting FORTH](https://www.forth.com/starting-forth/) 213 | - [Jonesforth](http://git.annexia.org/?p=jonesforth.git) 214 | 215 | ## To be Implemented 216 | - [x] Ability to read/write programs 217 | - [x] `WB` word to write back ~~2048~~ 400 (see *Current Limitations*) 218 | bytes of data starting from the address of `SCRATCH`. 219 | - [x] Ability to "execute" strings (so that programs can be 220 | interpreted). 221 | - [x] User input 222 | - [x] String reading routines 223 | - [x] Number reading routines (possible with `programs/number.fs`) 224 | - [x] Output 225 | - [x] Displaying strings 226 | - [x] Proper support for compile/interpret mode 227 | - [x] Assembler to convert Forth words into `.dw` data segments to be 228 | pasted into the program. 229 | - [x] Ability to switch to a "plot" 230 | - [x] REPL 231 | - [x] Basic Read/Eval/Print/Loop 232 | - [x] Allowing more than one word at a time input 233 | - [x] Respect hidden flag to avoid infinite looping. (`:` makes the 234 | word hidden). 235 | - [x] Reading numbers (support for 0-10 inclusive hardcoded, but not 236 | a general algorithm). See `programs/number.fs` 237 | - [ ] Document Forth words (partially done) 238 | - [ ] Add Z80 assembler in Forth (so ASM programs can be made!) 239 | - [x] Implement `DOES>` 240 | - [x] Implement `SIMG` (save image) and `LIMG` (load image) to save 241 | and load sessions. 242 | - [x] Add sound capabilities 243 | - [x] Add a way to put data on the screen as pixels (for export via 244 | screenshots). 245 | - [ ] Add computer program to allow the user to select the words for a 246 | custom Forth system. 247 | - [x] Implement `extract.py` to extract and decode binary data from a PNG image, allowing analysis and debugging of the stored image data. 248 | 249 | ## Current Limitations 250 | - [x] REPL prints out "ok" at the end of each word parsed, `QUIT` not 251 | implemented. 252 | - [ ] Indirect threading means we cannot use scratch space in addresses 253 | higher than `$C000` as if the program counter exceeds `$C000` it 254 | crashes the OS. 255 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /forth.asm: -------------------------------------------------------------------------------- 1 | .NOLIST 2 | 3 | ;;; Macros to make life easier. 4 | 5 | 6 | ;; Push BC to the return stack. 7 | ;; 4 + 19 + 4 + 19 = 46 8 | #define PUSH_BC_RS dec ix 9 | #defcont \ ld (ix + 0), b 10 | #defcont \ dec ix 11 | #defcont \ ld (ix + 0), c 12 | 13 | ;; Pop the top entry of the return stack to BC. 14 | ;; 19 + 10 + 19 + 10 = 58 15 | #define POP_BC_RS ld c, (ix + 0) 16 | #defcont \ inc ix 17 | #defcont \ ld b, (ix + 0) 18 | #defcont \ inc ix 19 | 20 | ;; Push HL to the return stack. 21 | ;; 4 + 19 + 4 + 19 = 46 22 | #define PUSH_HL_RS dec ix 23 | #defcont \ ld (ix + 0), h 24 | #defcont \ dec ix 25 | #defcont \ ld (ix + 0), l 26 | 27 | #define POP_HL_RS ld l, (ix + 0) 28 | ;; 19 + 10 + 19 + 10 = 58 29 | #defcont \ inc ix 30 | #defcont \ ld h, (ix + 0) 31 | #defcont \ inc ix 32 | 33 | ;; Push DE to the return stack. 34 | ;; 4 + 19 + 4 + 19 = 46 35 | #define PUSH_DE_RS dec ix 36 | #defcont \ ld (ix + 0), d 37 | #defcont \ dec ix 38 | #defcont \ ld (ix + 0), e 39 | 40 | ;; Pop the top entry of the return stack to DE. 41 | ;; 19 + 10 + 19 + 10 = 58 42 | #define POP_DE_RS ld e, (ix + 0) 43 | #defcont \ inc ix 44 | #defcont \ ld d, (ix + 0) 45 | #defcont \ inc ix 46 | 47 | 48 | ;; Convience macros to transfer 16-bit register contents. 49 | 50 | #define BC_TO_HL ld h, b 51 | #defcont \ ld l, c 52 | 53 | ;; 4 + 4 = 8 54 | #define HL_TO_BC ld b, h 55 | #defcont \ ld c, l 56 | 57 | #define HL_TO_DE ld d, h 58 | #defcont \ ld e, l 59 | 60 | #define BC_TO_DE ld d, b 61 | #defcont \ ld e, c 62 | 63 | ;; Our register allocations 64 | ;; BC = TOS IX = RSP 65 | ;; DE = IP IY = UP 66 | ;; HL = W SP = PSP 67 | 68 | ;; NEXT, the basis of many Forth CODE words. 69 | ;; Defined as a jump to reduce code size. 70 | #define NEXT jp next_sub 71 | 72 | #include "inc/ti83plus.inc" 73 | 74 | 75 | start: 76 | .org 9D93h 77 | .db $BB,$6D 78 | b_call _RunIndicOff 79 | b_call _ClrLCDFull 80 | b_call _HomeUp 81 | 82 | ;; This b_call pushes to the floating point stack, at memory 83 | ;; location $9824, below AppBackupScreen at $9872. 84 | b_call _PushRealO1 85 | 86 | pop bc ;; Save the place where this program needs to go. 87 | ld hl, prog_exit 88 | ld (hl), c 89 | inc hl 90 | ld (hl), b 91 | push bc 92 | 93 | ;; For some weird reason, either the spasm-ng assembler can't 94 | ;; store the string "[", so we have to fix it by changing the 95 | ;; value of rbrac's string. 96 | 97 | ld hl, name_lbrac+3 98 | ld (hl), 193 99 | 100 | ;; Same goes for S" and ." 101 | ld a, 34 102 | ld (name_s_quote+4), a 103 | ld (name_dot_quote+4), a 104 | 105 | ;; Setup data segment 106 | ld de, here_start 107 | ld hl, var_here 108 | ld (save_sp), sp 109 | ld (var_sz), sp 110 | ld (hl), e 111 | inc hl 112 | ld (hl), d 113 | ld ix, return_stack_top 114 | 115 | ld bc, 9999 116 | ld de, interpret_loop 117 | NEXT 118 | 119 | docol: 120 | PUSH_DE_RS 121 | pop de 122 | NEXT 123 | 124 | 125 | next_sub: ;; Cycle count (total 47) 126 | ld a, (de) ;; 7 127 | ld l, a ;; 4 128 | inc de ;; 6 129 | ld a, (de) ;; 7 130 | ld h, a ;; 4 131 | inc de ;; 6 132 | jp (hl) ;; 13 133 | 134 | 135 | done: 136 | ;; We reach here at the end of the program. 137 | ld hl, 9999 138 | call cpHLBC 139 | jp nz, print_stack_error 140 | 141 | done_cont: 142 | b_call _GetKey 143 | b_call _ClrScrnFull 144 | b_call _PopRealO1 145 | ;; Even if we blew up the stack during execution, we can try to restore it and exit cleanly. 146 | ld sp, (save_sp) 147 | ld hl, (prog_exit) 148 | jp (hl) 149 | print_stack_error: 150 | ld hl, possible_error_msg 151 | b_call _PutS 152 | jp done_cont 153 | possible_error_msg: .db "Warning: Stack not empty or underflowed.",0 154 | 155 | 156 | #macro defcode(name,len,flags,label) 157 | ;; This is the first word to be defined, so set the link. 158 | #ifndef prev 159 | #define prev 0 160 | #else 161 | #define prev eval(-_) 162 | #endif 163 | _: 164 | #define label_str concat("\"",label,"\"") 165 | #define name_label concat("\"name_",label,"\"") 166 | #define name_str concat("\"",name,"\"") 167 | clr() 168 | wr(name_label,":") 169 | wr(".dw ", eval(prev)) 170 | wr(".db ", eval(len+flags)) 171 | wr(".db ", "\"",name_str,"\",0") 172 | wr(label_str, ":") 173 | run() 174 | 175 | #endmacro 176 | 177 | #define CALL_DOCOL call docol 178 | 179 | #define F_IMMED 128 180 | #define F_HIDDEN 64 181 | #define F_LEN $20 182 | #define F_LENMASK 31 183 | 184 | #macro defword(name,len,flags,label) 185 | 186 | ;; This is the first word to be defined, so set the link. 187 | #ifndef prev 188 | #define prev 0 189 | #else 190 | #define prev eval(-_) 191 | #endif 192 | _: 193 | #define label_str concat("\"",label,"\"") 194 | #define name_label concat("\"name_",label,"\"") 195 | #define name_str concat("\"",name,"\"") 196 | clr() 197 | wr(name_label,":") 198 | wr(".dw ", eval(prev)) 199 | wr(".db ", eval(len+flags)) 200 | wr(".db ", "\"",name_str,"\",0") 201 | wr(label_str, ":") 202 | run() 203 | CALL_DOCOL 204 | #endmacro 205 | 206 | defcode("EXIT",4,0,exit) 207 | POP_DE_RS 208 | NEXT 209 | 210 | defcode("DUP",3,0,dup) 211 | push bc 212 | NEXT 213 | 214 | defcode("+",1,0,add) 215 | pop hl 216 | add hl, bc 217 | HL_TO_BC 218 | NEXT 219 | 220 | defcode("-",1,0,sub) 221 | xor a 222 | pop hl 223 | sbc hl, bc 224 | HL_TO_BC 225 | NEXT 226 | 227 | ;; 16-bit AND operator, yay! 228 | defcode("AND",3,0,and) 229 | pop hl 230 | 231 | ;; AND lowest byte first. 232 | ld a, c 233 | and l 234 | ld c, a 235 | 236 | ld a, b 237 | and h 238 | ld b, a 239 | NEXT 240 | 241 | defcode("OR",2,0,or) 242 | pop hl 243 | 244 | ld a, c 245 | or l 246 | ld c, a 247 | 248 | ld a, b 249 | or h 250 | ld b, a 251 | NEXT 252 | 253 | defcode("XOR",3,0,xor) 254 | pop hl 255 | ld a, c 256 | xor l 257 | ld c, a 258 | 259 | ld a, b 260 | xor h 261 | ld b, a 262 | NEXT 263 | 264 | defcode("<<",2, 0, left_shift) 265 | xor a 266 | rl c 267 | rl b 268 | NEXT 269 | 270 | 271 | defcode(">>",2,0, right_shift) 272 | srl b 273 | rr c 274 | NEXT 275 | 276 | ;; Bitwise NOT. 277 | defcode("INVERT",6,0,invert) 278 | ld a, c 279 | cpl 280 | ld c, a 281 | 282 | ld a, b 283 | cpl 284 | ld b, a 285 | NEXT 286 | 287 | defcode("DROP",4,0,drop) 288 | pop bc 289 | NEXT 290 | 291 | defcode("SWAP",4,0,swap) 292 | pop hl 293 | push bc 294 | HL_TO_BC 295 | NEXT 296 | 297 | defcode("OVER",4,0,over) 298 | pop hl 299 | push hl 300 | push bc 301 | HL_TO_BC 302 | NEXT 303 | 304 | defcode("ROT",3,0,rot) 305 | ;; 46 + 10 + 10 + 14 + 14 + 4 + 8 + 58 = 164 306 | PUSH_DE_RS 307 | pop hl 308 | pop de 309 | push hl 310 | push bc 311 | ex de, hl 312 | HL_TO_BC 313 | POP_DE_RS 314 | NEXT 315 | 316 | defcode("-ROT",4,0,nrot) 317 | PUSH_DE_RS 318 | pop hl 319 | pop de 320 | push bc 321 | push de 322 | HL_TO_BC 323 | POP_DE_RS 324 | NEXT 325 | 326 | defcode("2DROP",5,0,two_drop) 327 | pop bc 328 | pop bc 329 | NEXT 330 | 331 | defcode("2DUP",4,0,two_dup) 332 | pop hl 333 | push hl 334 | push bc 335 | push hl 336 | NEXT 337 | 338 | ;; Register contents (return stack contents) 339 | ;; a b c d => c d a b 340 | defcode("2SWAP",5,0,two_swap) 341 | PUSH_DE_RS 342 | pop de 343 | ;; Now DE = C, BC = D, (old-DE) 344 | pop hl 345 | PUSH_HL_RS 346 | pop hl 347 | ;; DE = C, BC = D, HL = A (old-DE B) 348 | push de 349 | push bc 350 | push hl 351 | POP_BC_RS 352 | ;; c d a, BC = b 353 | POP_DE_RS 354 | NEXT 355 | 356 | defcode("2OVER",5,0,two_over) 357 | push bc 358 | pop bc 359 | pop hl 360 | pop bc 361 | pop hl 362 | push hl 363 | push bc 364 | dec sp 365 | dec sp 366 | dec sp 367 | dec sp 368 | push hl 369 | NEXT 370 | ;; TODO: 2NIP, 2TUCK, 2ROT 371 | 372 | defcode("1+", 2, 0, one_plus) 373 | inc bc 374 | NEXT 375 | 376 | 377 | defcode("1-", 2, 0, one_minus) 378 | dec bc 379 | NEXT 380 | 381 | defcode("2+", 2, 0, two_plus) 382 | inc bc 383 | inc bc 384 | NEXT 385 | 386 | defcode("2-", 2, 0, two_minus) 387 | dec bc 388 | dec bc 389 | NEXT 390 | 391 | defcode(">R", 2, 0, to_r) 392 | ;; 46 + 14 = 60 393 | PUSH_BC_RS 394 | pop bc 395 | NEXT 396 | 397 | defcode("R>", 2, 0, from_r) 398 | push bc 399 | POP_BC_RS 400 | NEXT 401 | 402 | defcode("R@", 2, 0, r_fetch) 403 | push bc 404 | ld c, (ix + 0) 405 | ld b, (ix + 1) 406 | NEXT 407 | 408 | defcode("2>R", 3, 0, two_to_r) 409 | pop hl 410 | PUSH_HL_RS 411 | PUSH_BC_RS 412 | pop bc 413 | NEXT 414 | 415 | defcode("2R>", 3, 0, two_r_from) 416 | push bc 417 | POP_BC_RS 418 | POP_HL_RS 419 | push hl 420 | NEXT 421 | 422 | defcode("RDROP",5,0,rdrop) 423 | POP_HL_RS 424 | NEXT 425 | 426 | defcode("2RDROP",6,0,two_rdrop) 427 | POP_HL_RS 428 | POP_HL_RS 429 | NEXT 430 | 431 | defcode("LIT",3,0,lit) 432 | ld a, (de) 433 | ld l, a 434 | inc de 435 | ld a, (de) 436 | ld h, a 437 | inc de 438 | push bc 439 | HL_TO_BC 440 | NEXT 441 | 442 | defcode("LITSTR",6,0,litstring) 443 | ;; String length 444 | ld a, (de) 445 | ld l, a 446 | inc de 447 | ld a, (de) 448 | ld h, a 449 | inc de 450 | 451 | push bc ;; old stack top 452 | push de ;; push address of string 453 | HL_TO_BC ;; BC now contains the string length 454 | 455 | ;; Skip the string. 456 | add hl, de 457 | ;; Skip null pointer. (Even though we have the length, because 458 | ;; we don't have a bcall Linux that can print out a string with 459 | ;; a certain length). 460 | 461 | inc hl 462 | ex de, hl 463 | NEXT 464 | 465 | defword("SQ",2,128,s_quote) 466 | .dw state, fetch, zbranch, 66, tick, litstring, comma, here, lit, 0 467 | .dw comma, getc, dup, lit, 34, neql, zbranch, 8, c_comma, branch, 65518, drop 468 | .dw lit, 0, c_comma, dup, here, swap, sub, lit, 3, sub, swap, store, branch, 38 469 | .dw here, getc, dup, lit, 34, zbranch, 12, over, store_byte, one_plus, branch, 65514 470 | .dw drop, here, sub, here, swap, exit 471 | 472 | 473 | defword(".Q",2,128,dot_quote) 474 | .dw state, fetch, zbranch, 30, get_char_forth, dup, lit, 34, eql 475 | .dw zbranch, 6, drop, exit, emit, branch, 65514, branch, 10, s_quote 476 | .dw tick, tell, comma, exit 477 | 478 | defcode("TELL",4,0,tell) 479 | pop bc 480 | BC_TO_HL 481 | b_call _PutS 482 | pop bc 483 | NEXT 484 | 485 | defcode("STRLEN",6,0,strlen) 486 | BC_TO_HL 487 | ;; Taken from the KnightOS kernel. 488 | push af 489 | push hl 490 | xor a 491 | ld b, a 492 | ld c, a 493 | cpir 494 | ; bc = -bc 495 | ld a,c \ cpl \ ld c, a \ ld a,b \ cpl \ ld b, a 496 | pop hl 497 | pop af 498 | NEXT 499 | 500 | ;; Return a pointer to the first occurrence of a character in a string 501 | ;; Taken from the KnightOS kernel. 502 | defcode("STRCHR",6,0,strchr) ; ( char str -- addr ) 503 | BC_TO_HL 504 | pop bc 505 | ld b, c 506 | 507 | strchr_loop: 508 | ld a, (hl) 509 | or a 510 | jr z, strchr_fail 511 | cp b 512 | jp z, strchr_succ 513 | inc hl 514 | jr strchr_loop 515 | strchr_fail: 516 | jp fal 517 | strchr_succ: 518 | HL_TO_BC 519 | NEXT 520 | 521 | defcode("!", 1,0,store) 522 | pop hl 523 | ld a, l 524 | ld (bc), a 525 | inc bc 526 | ld a, h 527 | ld (bc), a 528 | pop bc 529 | NEXT 530 | 531 | defcode("@", 1,0,fetch) 532 | ld a, (bc) 533 | ld l, a 534 | inc bc 535 | ld a, (bc) 536 | ld h, a 537 | HL_TO_BC 538 | NEXT 539 | 540 | ;; ( n addr -- ) 541 | defcode("+!",2,0,add_store) 542 | pop hl 543 | ld a, (bc) 544 | add a, l 545 | ld (bc), a 546 | inc bc 547 | ld a, (bc) 548 | adc a, h 549 | ld (bc), a 550 | pop bc 551 | NEXT 552 | 553 | defcode("-!",2,0,sub_store) 554 | pop hl 555 | push de 556 | ld a, (bc) 557 | ld e, a 558 | inc bc 559 | ld a, (bc) 560 | ld d, a 561 | dec bc 562 | xor a 563 | ex de, hl 564 | sbc hl, de 565 | 566 | ld a, l 567 | ld (bc), a 568 | inc bc 569 | ld a, h 570 | ld (bc), a 571 | pop de 572 | pop bc 573 | NEXT 574 | 575 | defcode("C!", 2,0, store_byte) 576 | pop hl 577 | ld a, l 578 | ld (bc), a 579 | pop bc 580 | NEXT 581 | 582 | defcode("C@", 2,0, fetch_byte) 583 | ld a, (bc) 584 | ld c, a 585 | ld b, 0 586 | NEXT 587 | 588 | defcode("C@C!",4,0,byte_copy) 589 | pop hl 590 | ld a, (bc) 591 | ld (hl), a 592 | inc hl 593 | inc bc 594 | push hl 595 | NEXT 596 | 597 | defcode("CMOVE",5,0,cmove) 598 | ;; ( source destination amount -- ) 599 | PUSH_DE_RS 600 | pop de 601 | pop hl 602 | ldir 603 | POP_DE_RS 604 | pop bc 605 | NEXT 606 | 607 | ;; BC points to a codeword, execute it! 608 | defcode("EXECUTE",7,0,execute) 609 | BC_TO_HL 610 | pop bc 611 | jp (hl) 612 | NEXT 613 | 614 | 615 | ;; Make some variables! 616 | 617 | ;; Well since there's only like 6 variables defined in Jonesforth it's 618 | ;; not forth the effort trying to debug a macro (which took up a lot 619 | ;; of time for defword and defcode!) 620 | 621 | #define PSP_PUSH(x) push bc \ ld bc, x 622 | 623 | #macro cell_alloc(name,initial) 624 | clr() 625 | #define name_str concat("\"",name,"\"") 626 | wr(name_str, ":") 627 | wr(".dw ", initial) 628 | run() 629 | #endmacro 630 | 631 | cell_alloc(var_base,10) 632 | defcode("BASE",4,0,base) 633 | push bc 634 | ld bc, var_base 635 | NEXT 636 | 637 | ;; Floating point precision. 638 | cell_alloc(var_precision,12) 639 | defcode("PREC",4,0,precision) 640 | push bc 641 | ld bc, var_precision 642 | NEXT 643 | 644 | ;; Are we compiling or are we interpreting? 645 | cell_alloc(var_state,1) 646 | defcode("STATE",5,0,state) 647 | push bc 648 | ld bc, var_state 649 | NEXT 650 | 651 | ;; Address of the most recently defined word. 652 | ;; We have to do a very hacky thing. 653 | var_latest: 654 | .dw name_star 655 | defcode("LATEST",6,0,latest) 656 | push bc 657 | ld bc, var_latest 658 | NEXT 659 | 660 | ;; Base of the parameter stack. 661 | cell_alloc(var_sz, 0) 662 | defcode("SP0",3,0,sz) 663 | push bc 664 | ld bc, var_sz 665 | NEXT 666 | 667 | ;; The "x" gets replaced with "[" at program start, see "start:" 668 | defcode("x",1,128,lbrac) 669 | ld hl, var_state 670 | ld (hl), 1 671 | inc hl 672 | ld (hl), 0 673 | NEXT 674 | 675 | defcode("]",1,0,rbrac) 676 | ld hl, var_state 677 | ld (hl), 0 678 | inc hl 679 | ld (hl), 0 680 | NEXT 681 | 682 | cell_alloc(var_stack_empty,1) 683 | defcode("?SE", 3, 0, stack_emptyq) 684 | push bc 685 | ld hl, (var_stack_empty) 686 | ld b, h 687 | ld c, l 688 | NEXT 689 | 690 | cell_alloc(var_here,0) 691 | defcode("HERE",4,0,here) 692 | push bc 693 | ld bc, var_here 694 | NEXT 695 | 696 | cell_alloc(var_num_status,0) 697 | defcode("NUMST", 5, 0, num_status) 698 | push bc 699 | ld bc, var_num_status 700 | NEXT 701 | 702 | 703 | ;; Here are some constants. 704 | defcode("DOCOL", 5, 0, __docol) 705 | PSP_PUSH(docol) 706 | NEXT 707 | 708 | defcode("BUF", 3, 0, __string_buffer) 709 | PSP_PUSH(string_buffer) 710 | NEXT 711 | 712 | defcode("BUFSZ", 5, 0, __string_buffer_size) 713 | PSP_PUSH(STRING_BUFFER_SIZE) 714 | NEXT 715 | 716 | defcode("WBUFP", 5, 0, __word_buffer_ptr) 717 | PSP_PUSH(word_buffer_ptr) 718 | NEXT 719 | 720 | defcode("WBUF", 4, 0, __word_buffer) 721 | PSP_PUSH(word_buffer) 722 | NEXT 723 | 724 | defcode("RP0", 3, 0, rz) 725 | PSP_PUSH(return_stack_top) 726 | NEXT 727 | 728 | defcode("H0", 2, 0, hz) 729 | PSP_PUSH(here_start) 730 | NEXT 731 | 732 | defcode("F_IMMED",7,0,__F_IMMED) 733 | PSP_PUSH(F_IMMED) 734 | NEXT 735 | 736 | defcode("F_HIDDEN",8,0,__F_HIDDEN) 737 | PSP_PUSH(F_HIDDEN) 738 | NEXT 739 | 740 | defcode("F_LENMASK",9,0,__F_LENMASK) 741 | PSP_PUSH(F_LENMASK) 742 | NEXT 743 | 744 | defcode("SCR",3,0,__scratch) 745 | PSP_PUSH(scratch) 746 | NEXT 747 | 748 | defcode("ABS",3,0,__abs) 749 | PSP_PUSH(AppBackUpScreen) 750 | NEXT 751 | 752 | defword("UALT",4,0, use_alt) 753 | .dw lit, AppBackUpScreen, here, store, exit 754 | 755 | defcode("PLOTSS",6,0,__plot_s_screen) 756 | PSP_PUSH(plotSScreen) 757 | NEXT 758 | 759 | defcode("'",1,0,tick) 760 | ld a, (de) 761 | ld l, a 762 | inc de 763 | ld a, (de) 764 | ld h, a 765 | inc de 766 | push bc 767 | HL_TO_BC 768 | NEXT 769 | 770 | defcode(",",1,0,comma) 771 | call _comma 772 | pop bc 773 | NEXT 774 | _comma: 775 | ;; Remember that var_here is a pointer, so you need to do 776 | ;; double indirection! 777 | push de 778 | 779 | ld hl, (var_here) 780 | 781 | ld (hl), c 782 | inc hl 783 | ld (hl), b 784 | inc hl 785 | 786 | ld de, var_here 787 | ex de, hl 788 | ld (hl), e 789 | inc hl 790 | ld (hl), d 791 | 792 | pop de 793 | 794 | ret 795 | 796 | defcode("C,",2,0,c_comma) 797 | call _c_comma 798 | pop bc 799 | NEXT 800 | _c_comma 801 | push de 802 | ld hl, (var_here) 803 | ld (hl), c 804 | inc hl 805 | 806 | ld de, var_here 807 | ex de, hl 808 | ld (hl), e 809 | inc hl 810 | ld (hl), d 811 | 812 | pop de 813 | 814 | ret 815 | 816 | defcode("SP@", 3, 0, sp_fetch) 817 | push bc 818 | ld hl, 0 819 | add hl, sp 820 | HL_TO_BC 821 | NEXT 822 | 823 | defcode("SP!", 3, 0, sp_store) 824 | BC_TO_HL 825 | ld sp, hl 826 | pop bc ;; new top of stack 827 | NEXT 828 | 829 | defcode("RP@",3,0,rp_fetch) 830 | push bc 831 | push ix 832 | pop bc 833 | NEXT 834 | 835 | defcode("RP!",3,0,rp_store) 836 | push bc 837 | pop ix 838 | pop bc 839 | NEXT 840 | 841 | defcode("BRANCH", 6, 0, branch) 842 | ex de, hl 843 | ld e,(hl) 844 | inc hl 845 | ld d,(hl) 846 | dec hl 847 | add hl, de 848 | ex de, hl 849 | NEXT 850 | 851 | ;; cpHLDE [Maths] 852 | ;; Compares HL to DE. 853 | ;; Output: 854 | ;; Same as z80 CP instruction. 855 | cpHLDE: 856 | or a 857 | sbc hl, de 858 | add hl,de 859 | ret 860 | ;; cpHLBC [Maths] 861 | ;; Compares HL to BC. 862 | ;; Output: 863 | ;; Same as z80 CP instruction. 864 | cpHLBC: 865 | or a 866 | sbc hl, bc 867 | add hl,bc 868 | ret 869 | ;; cpBCDE [Maths] 870 | ;; Compares DE to BC. 871 | ;; Output: 872 | ;; Same as z80 CP instruction. 873 | cpBCDE: 874 | push hl 875 | ld h, b 876 | ld l, c 877 | or a 878 | sbc hl, de 879 | pop hl 880 | ret 881 | 882 | defcode("JUMP", 4, 0, jump) 883 | ld a, (de) 884 | ld l, a 885 | inc de 886 | ld a, (de) 887 | ld h, a 888 | HL_TO_DE 889 | NEXT 890 | 891 | defcode("0JUMP", 5, 0, zjump) 892 | xor a 893 | cp c 894 | jp z, zjump_maybe 895 | jp nz, zjump_fail 896 | 897 | zjump_maybe: 898 | xor a 899 | cp b 900 | jp nz, zjump_fail 901 | pop bc 902 | jp jump 903 | 904 | zjump_fail: 905 | inc de 906 | inc de 907 | pop bc 908 | NEXT 909 | 910 | defcode("0BRANCH", 7, 0, zbranch) 911 | ld a, c 912 | cp 0 913 | jp z, zbranch_maybe 914 | jp nz, zbranch_fail 915 | 916 | zbranch_maybe: 917 | ld a, b 918 | cp 0 919 | jp nz,zbranch_fail 920 | pop bc 921 | jp branch 922 | zbranch_fail: 923 | ;; The top of the stack wasn't zero. Skip the offset and resume execution. 924 | inc de 925 | inc de 926 | 927 | pop bc ;; New top of stack 928 | 929 | NEXT 930 | 931 | defcode("?DUP",4,0,qdup) 932 | ld hl, 0 933 | call cpHLBC 934 | jp nz, dup 935 | NEXT 936 | 937 | defcode("=", 1,0,eql) 938 | pop hl 939 | call cpHLBC 940 | jp z, tru 941 | jp fal 942 | 943 | defcode("<>", 2,0, neql) 944 | pop hl 945 | call cpHLBC 946 | jp z, fal 947 | jp tru 948 | 949 | defcode(">=", 2,0,greater_eq) 950 | pop hl 951 | call cpHLBC 952 | jp nc, tru 953 | jp fal 954 | 955 | defcode("<=", 2,0,less_eq) 956 | BC_TO_HL 957 | pop bc 958 | call cpHLBC 959 | jp nc, tru 960 | jp fal 961 | 962 | defcode("<",1,0,less_than) 963 | pop hl 964 | call cpHLBC 965 | jp c, tru 966 | jp fal 967 | 968 | defcode(">",1,0,greater_than) 969 | pop hl 970 | push hl 971 | push bc 972 | call cpHLBC 973 | pop bc 974 | pop hl 975 | jp nc, gt_check_neq 976 | jp fal 977 | gt_check_neq: 978 | call cpHLBC 979 | jp z, fal 980 | jp tru 981 | 982 | defcode("0=",2,0,zeql) 983 | ld hl, 0 984 | call cpHLBC 985 | jp c, fal 986 | jp tru 987 | 988 | 989 | ;; Place a truth value on the top of the stack. 990 | tru: 991 | ld bc, 1 992 | NEXT 993 | 994 | ;; Place a false value on the top of the stack. 995 | fal: 996 | ld bc, 0 997 | NEXT 998 | 999 | ;; Refer to https://github.com/KnightOS/kernel/blob/830f4ac87c50fa42faf634ab3ee476f0ab85b741/src/00/strings.asm 1000 | ;; for string routines. 1001 | 1002 | printhl_safe: 1003 | push hl 1004 | push af 1005 | push de 1006 | b_call _DispHL 1007 | pop de 1008 | pop af 1009 | pop hl 1010 | ret 1011 | 1012 | 1013 | str_println: 1014 | b_call _PutS 1015 | b_call _Newline 1016 | ret 1017 | 1018 | str_print: 1019 | b_call _PutS 1020 | ret 1021 | 1022 | defcode("KEY", 3, 0, key) 1023 | call key_asm 1024 | push bc 1025 | ld c, a 1026 | ld b, 0 1027 | NEXT 1028 | 1029 | key_asm: 1030 | push bc 1031 | push de 1032 | b_call _GetKey 1033 | pop de 1034 | pop bc 1035 | ret 1036 | 1037 | ;; Get a key but non-blocking. 1038 | defcode("KEYC", 4, 0, keyc) 1039 | push bc 1040 | b_call _GetCSC 1041 | ld c, a 1042 | ld b, 0 1043 | NEXT 1044 | 1045 | defcode("EMIT",4,0,emit) 1046 | ld a, c 1047 | b_call _PutC 1048 | pop bc 1049 | NEXT 1050 | 1051 | defcode("EMITS", 5, 0, emit_small) 1052 | ld a, c 1053 | push de 1054 | b_call _VPutMap 1055 | pop de 1056 | pop bc 1057 | NEXT 1058 | 1059 | 1060 | ;; Print the top of the stack. 1061 | defcode("T.", 1, 0, t_dot) 1062 | BC_TO_HL 1063 | call printhl_safe 1064 | ld a, ' ' 1065 | b_call _PutC 1066 | pop bc 1067 | NEXT 1068 | 1069 | defcode("?", 1, 0, peek_addr) 1070 | ld a, (bc) 1071 | ld l, a 1072 | inc bc 1073 | ld a, (bc) 1074 | ld h, a 1075 | call printhl_safe 1076 | pop bc 1077 | NEXT 1078 | 1079 | ;; Convert a key code into an ASCII character by way of a 1080 | ;; lookup table. 1081 | 1082 | ;; We need both because sometimes we might want to check for a 1083 | ;; specific key that doesn't correspond to something 1084 | ;; printable. 1085 | defcode("AKEY",4,0,akey) 1086 | push de 1087 | call akey_asm 1088 | pop de 1089 | 1090 | push bc 1091 | ld b, 0 1092 | ld c, a 1093 | NEXT 1094 | 1095 | ;; Trashes hl, de, returns the ASCII character in register A If the 1096 | ;; user pressed enter, this is recorded as $00. This routine keeps 1097 | ;; asking for input until a character that is in the table is input. 1098 | akey_asm: 1099 | ;; First portion is copied from key. 1100 | b_call _GetKey 1101 | ;; a contains the byte received. 1102 | ld h, 0 1103 | ld l , a 1104 | cp kSpace 1105 | jp z, akey_return_space 1106 | ld de, key_table 1107 | ;; Add the offset 1108 | add hl, de 1109 | ld a, (hl) 1110 | cp ' ' 1111 | jp z, akey_asm 1112 | ret 1113 | 1114 | akey_return_space: 1115 | ld a, ' ' 1116 | ret 1117 | 1118 | defcode("TO_ASCII",8,0,to_ascii) 1119 | ;; First portion is copied from key. 1120 | push bc 1121 | push de 1122 | ld h, 0 1123 | ld l , c 1124 | ld de, key_table 1125 | ;; Add the offset 1126 | add hl, de 1127 | ld a, (hl) 1128 | ld c, a 1129 | ld b, 0 1130 | pop de 1131 | NEXT 1132 | 1133 | key_table: 1134 | .db " ",$00," " ;; 0 - 7 1135 | .db " " ;; 8 - 15 1136 | .db " " ;; 16 - 23 1137 | .db " " ;; 24 - 31 1138 | .db " " ;; 32 - 39 1139 | .db " !" ;; 40 - 47 1140 | .db " = ' " ;; 48 - 55 1141 | .db "_@> " ;; 56 - 63 1142 | .db " < " ;; 64 - 71 1143 | .db " " ;; 72 - 79 1144 | .db " " ;; 80 - 87 1145 | .db " " ;; 88 - 95 1146 | .db " " ;; 96 - 103 1147 | .db " " ;; 104 - 111 1148 | .db " " ;; 112 - 119 1149 | .db " " ;; 120 - 127 1150 | .db "+-*/^()",$C1 ;; 128 - 135 1151 | .db "] , .01" ;; 136 - 143 1152 | .db "23456789" ;; 144 - 151 1153 | .db " ABCDEF" ;; 152 - 159 1154 | .db "GHIJKLMN" ;; 160 - 167 1155 | .db "OPQRSTUV" ;; 168 - 175 1156 | .db "WXYZ " ;; 176 - 183 1157 | .db " " ;; 184 - 191 1158 | .db " : " ;; 192 - 199 1159 | .db " ?\" " ;; 200 - 207 1160 | .db " " ;; 208 - 215 1161 | .db " " ;; 216 - 223 1162 | .db " " ;; 224 - 231 1163 | .db " {};\\" ;; 232 - 239 1164 | .db " " ;; 240 - 247 1165 | .db " " ;; 248 - 255 1166 | 1167 | ;; mul16By16 [Maths] 1168 | ;; Performs an unsigned multiplication of DE and BC. 1169 | ;; Inputs: 1170 | ;; DE: Multiplier 1171 | ;; BC: Multiplicand 1172 | ;; Outputs: 1173 | ;; DEHL: Product of DE and BC. 1174 | 1175 | mul16By16: 1176 | push bc 1177 | push af 1178 | ld hl, 0 1179 | ld a, b 1180 | ld b, h 1181 | or a 1182 | rla \ jr nc, $+5 \ ld h, d \ ld l, e 1183 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1184 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1185 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1186 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1187 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1188 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1189 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, b 1190 | ld b, a 1191 | push hl 1192 | ld hl, 0 1193 | ld a, c 1194 | ld c, h 1195 | or a 1196 | rla \ jr nc, $+5 \ ld h, d \ ld l, e 1197 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1198 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1199 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1200 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1201 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1202 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1203 | add hl, hl \ rla \ jr nc, $+4 \ add hl, de \ adc a, c 1204 | ld d, b 1205 | pop bc 1206 | ld e, a 1207 | ld a, c 1208 | add a, h 1209 | ld h, a 1210 | ld a, e 1211 | adc a, b 1212 | ld e, a 1213 | jr nc, $ + 3 1214 | inc d 1215 | pop af 1216 | pop bc 1217 | ret 1218 | 1219 | defcode("*",1,0,mult) 1220 | PUSH_DE_RS 1221 | pop de ;; get the second element from the stack 1222 | call mul16by16 1223 | HL_TO_BC 1224 | POP_DE_RS 1225 | NEXT 1226 | 1227 | ;; ( a b -- remainder quotient ) 1228 | defcode("/MOD", 4, 0, divmod) 1229 | PUSH_DE_RS 1230 | ld d, b 1231 | ld e, c 1232 | pop bc 1233 | ld a, b 1234 | divACbyDE: 1235 | ld hl, 0 1236 | .db $CB, $31 ; sll c 1237 | rla 1238 | adc hl, hl 1239 | sbc hl, de 1240 | jr nc, $+4 1241 | add hl, de 1242 | dec c 1243 | .db $CB, $31 ; sll c 1244 | rla 1245 | adc hl, hl 1246 | sbc hl, de 1247 | jr nc, $+4 1248 | add hl, de 1249 | dec c 1250 | .db $CB, $31 ; sll c 1251 | rla 1252 | adc hl, hl 1253 | sbc hl, de 1254 | jr nc, $+4 1255 | add hl, de 1256 | dec c 1257 | .db $CB, $31 ; sll c 1258 | rla 1259 | adc hl, hl 1260 | sbc hl, de 1261 | jr nc, $+4 1262 | add hl, de 1263 | dec c 1264 | .db $CB, $31 ; sll c 1265 | rla 1266 | adc hl, hl 1267 | sbc hl, de 1268 | jr nc, $+4 1269 | add hl, de 1270 | dec c 1271 | .db $CB, $31 ; sll c 1272 | rla 1273 | adc hl, hl 1274 | sbc hl, de 1275 | jr nc, $+4 1276 | add hl, de 1277 | dec c 1278 | .db $CB, $31 ; sll c 1279 | rla 1280 | adc hl, hl 1281 | sbc hl, de 1282 | jr nc, $+4 1283 | add hl, de 1284 | dec c 1285 | .db $CB, $31 ; sll c 1286 | rla 1287 | adc hl, hl 1288 | sbc hl, de 1289 | jr nc, $+4 1290 | add hl, de 1291 | dec c 1292 | .db $CB, $31 ; sll c 1293 | rla 1294 | adc hl, hl 1295 | sbc hl, de 1296 | jr nc, $+4 1297 | add hl, de 1298 | dec c 1299 | .db $CB, $31 ; sll c 1300 | rla 1301 | adc hl, hl 1302 | sbc hl, de 1303 | jr nc, $+4 1304 | add hl, de 1305 | dec c 1306 | .db $CB, $31 ; sll c 1307 | rla 1308 | adc hl, hl 1309 | sbc hl, de 1310 | jr nc, $+4 1311 | add hl, de 1312 | dec c 1313 | .db $CB, $31 ; sll c 1314 | rla 1315 | adc hl, hl 1316 | sbc hl, de 1317 | jr nc, $+4 1318 | add hl, de 1319 | dec c 1320 | .db $CB, $31 ; sll c 1321 | rla 1322 | adc hl, hl 1323 | sbc hl, de 1324 | jr nc, $+4 1325 | add hl, de 1326 | dec c 1327 | .db $CB, $31 ; sll c 1328 | rla 1329 | adc hl, hl 1330 | sbc hl, de 1331 | jr nc, $+4 1332 | add hl, de 1333 | dec c 1334 | .db $CB, $31 ; sll c 1335 | rla 1336 | adc hl, hl 1337 | sbc hl, de 1338 | jr nc, $+4 1339 | add hl, de 1340 | dec c 1341 | .db $CB, $31 ; sll c 1342 | rla 1343 | adc hl, hl 1344 | sbc hl, de 1345 | jr nc, $+4 1346 | add hl, de 1347 | dec c 1348 | 1349 | ld b, a 1350 | ;; Remainder, then quotient. 1351 | push hl 1352 | POP_DE_RS 1353 | NEXT 1354 | 1355 | ;; ( n^2 -- n ) 1356 | defcode("SQRT",4,0,sqrt) 1357 | ;; Input: LA 1358 | ;; Output: D 1359 | push de 1360 | ld a, c 1361 | ld l, b 1362 | sqrt_la: 1363 | ld de, 0040h ; 40h appends "01" to D 1364 | ld h, d 1365 | 1366 | ld b, 7 1367 | 1368 | ; need to clear the carry beforehand 1369 | or a 1370 | 1371 | sqrt_loop: 1372 | sbc hl, de 1373 | jr nc, $+3 1374 | add hl, de 1375 | ccf 1376 | rl d 1377 | rla 1378 | adc hl, hl 1379 | rla 1380 | adc hl, hl 1381 | 1382 | djnz sqrt_loop 1383 | 1384 | sbc hl, de ; optimised last iteration 1385 | ccf 1386 | rl d 1387 | ld b, 0 1388 | ld c, d 1389 | pop de 1390 | NEXT 1391 | 1392 | 1393 | ;; defcode("FRAND",5,0,f_rand) 1394 | ;; push bc 1395 | ;; push de 1396 | ;; b_call _Random 1397 | ;; b_call _PushRealO1 1398 | ;; pop de 1399 | ;; pop bc 1400 | ;; NEXT 1401 | 1402 | ;; defcode("F.",2,0,f_dot) 1403 | ;; push bc 1404 | ;; push de 1405 | ;; b_call _PopRealO1 1406 | ;; ld a, (var_precision) 1407 | ;; b_call _FormReal 1408 | ;; pop de 1409 | ;; ld hl, $848e 1410 | ;; b_call _PutS 1411 | ;; pop bc 1412 | ;; NEXT 1413 | 1414 | ;; ;; Read a floating point number. 1415 | ;; ;; Parameter stack : ( addr len -- ) 1416 | ;; ;; Floating point stack: ( -- f ) 1417 | ;; defcode("FREAD",5,0,f_read) 1418 | ;; NEXT 1419 | 1420 | ;; defcode("F*",2,0,f_mult) 1421 | ;; push bc 1422 | ;; push de 1423 | ;; b_call _PopRealO1 1424 | ;; b_call _PopRealO2 1425 | ;; b_call _FPMult 1426 | ;; b_call _PushOP1 1427 | ;; pop de 1428 | ;; pop bc 1429 | ;; NEXT 1430 | 1431 | ;; defcode("FSQUARE",7,0,f_square) 1432 | ;; push bc 1433 | ;; push de 1434 | ;; b_call _PopRealO1 1435 | ;; b_call _FPSquare 1436 | ;; b_call _PushOP1 1437 | ;; pop de 1438 | ;; pop bc 1439 | ;; NEXT 1440 | 1441 | ;; defcode("F=",2,0,f_eql) 1442 | ;; push bc 1443 | ;; push de 1444 | ;; b_call _PopRealO1 1445 | ;; b_call _PopRealO2 1446 | ;; b_call _CpOP1OP2 1447 | ;; pop de 1448 | ;; pop bc 1449 | ;; jp z, tru 1450 | ;; jp fal 1451 | 1452 | 1453 | ;; defcode("FDUP",4,0,f_dup) 1454 | ;; push bc 1455 | ;; push de 1456 | ;; b_call _PopRealO1 1457 | ;; b_call _PushOP1 1458 | ;; b_call _PushOP1 1459 | ;; pop de 1460 | ;; pop bc 1461 | ;; NEXT 1462 | 1463 | ;; defcode("FDROP",5,0,f_drop) 1464 | ;; push bc 1465 | ;; push de 1466 | ;; b_call _PopRealO1 1467 | ;; pop de 1468 | ;; pop bc 1469 | ;; NEXT 1470 | 1471 | ;; defcode("FSWAP",5,0,f_swap) 1472 | ;; push bc 1473 | ;; push de 1474 | ;; b_call _PopRealO1 1475 | ;; b_call _PopRealO2 1476 | ;; b_call _PushRealO1 1477 | ;; b_call _PushRealO2 1478 | ;; pop de 1479 | ;; pop bc 1480 | ;; NEXT 1481 | 1482 | ;; defcode("F+",2,0,f_add) 1483 | ;; push bc 1484 | ;; push de 1485 | ;; b_call _PopRealO1 1486 | ;; b_call _PopRealO2 1487 | ;; b_call _FPAdd 1488 | ;; b_call _PushOP1 1489 | ;; pop de 1490 | ;; pop bc 1491 | ;; NEXT 1492 | 1493 | ;; defcode("F/",2,0,f_div) 1494 | ;; push bc 1495 | ;; push de 1496 | ;; b_call _PopRealO2 1497 | ;; b_call _PopRealO1 1498 | ;; b_call _FPDiv 1499 | ;; b_call _PushOP1 1500 | ;; pop de 1501 | ;; pop bc 1502 | ;; NEXT 1503 | 1504 | 1505 | ;; defcode("FRCI",4,0,f_recip) 1506 | ;; push bc 1507 | ;; push de 1508 | ;; b_call _PopRealO1 1509 | ;; b_call _FPRecip 1510 | ;; b_call _PushOP1 1511 | ;; pop de 1512 | ;; pop bc 1513 | ;; NEXT 1514 | 1515 | ;; defcode("F-",2,0,f_sub) 1516 | ;; push bc 1517 | ;; push de 1518 | ;; b_call _PopRealO2 1519 | ;; b_call _PopRealO1 1520 | ;; b_call _FPSub 1521 | ;; b_call _PushOP1 1522 | ;; pop de 1523 | ;; pop bc 1524 | ;; NEXT 1525 | 1526 | ;; defcode("FSQRT",5,0,f_sqrt) 1527 | ;; push bc 1528 | ;; push de 1529 | ;; b_call _PopRealO1 1530 | ;; b_call _SqRoot 1531 | ;; b_call _PushOP1 1532 | ;; pop de 1533 | ;; pop bc 1534 | ;; NEXT 1535 | 1536 | ;; ;; ( addr len -- hash_addr ) 1537 | ;; defcode("MD5",3,0,md_five) 1538 | ;; b_call $808d ;; md5init 1539 | ;; pop hl 1540 | ;; push de 1541 | ;; push ix 1542 | ;; b_call $8090 ;; md5update 1543 | ;; b_call $8090 ;; md5update 1544 | ;; b_call $8090 ;; md5update 1545 | ;; b_call $8090 ;; md5update 1546 | ;; b_call $8018 ;; md5final 1547 | ;; ld bc, $8292 1548 | ;; pop ix 1549 | ;; pop de 1550 | ;; NEXT 1551 | 1552 | ;; Double length number routines. 1553 | ;; Convention for this Forth: ( high low -- ) 1554 | ;; ( high low divisor -- remainder quotient_high quotient_low ) 1555 | defcode("D/MOD",5,0,double_divmod) 1556 | PUSH_DE_RS 1557 | ld (save_ix), ix 1558 | BC_TO_DE ;; get the divisor 1559 | pop ix ;; get the low part 1560 | pop bc ;; get the high part 1561 | ld a, b 1562 | call div32By16 1563 | ld b, a 1564 | 1565 | ;; Push remainder 1566 | push hl 1567 | ;; BC contains the high quotient 1568 | push bc 1569 | 1570 | ld b, ixh 1571 | ld c, ixl 1572 | ;; Now it contains the low quotient 1573 | 1574 | ld ix, (save_ix) 1575 | POP_DE_RS 1576 | NEXT 1577 | 1578 | ;; From KnightOS kernel 1579 | ;; div32By16 [Maths] 1580 | ;; Performs `ACIX = ACIX / DE` 1581 | ;; Outputs: 1582 | ;; ACIX: ACIX / DE 1583 | ;; HL: Remainder 1584 | ;; B: 0 1585 | div32By16: 1586 | ld hl, 0 1587 | ld b, 32 1588 | dd_loop: 1589 | add ix, ix 1590 | rl c 1591 | rla 1592 | adc hl, hl 1593 | jr c, dd_overflow 1594 | sbc hl, de 1595 | jr nc, dd_setBit 1596 | add hl, de 1597 | djnz dd_loop 1598 | ret 1599 | dd_overflow: 1600 | or a 1601 | sbc hl, de 1602 | dd_setBit: 1603 | inc ixl 1604 | djnz dd_loop 1605 | ret 1606 | 1607 | ;; ( n1 n2 -- high_mult low_mult ) 1608 | defcode("UM*",3,0,um_star) 1609 | PUSH_DE_RS 1610 | pop de ;; get the second element from the stack 1611 | call mul16by16 1612 | HL_TO_BC 1613 | push de ;; push high part onto stack. 1614 | POP_DE_RS 1615 | NEXT 1616 | 1617 | defcode("D+",2,0,double_add) 1618 | BC_TO_HL 1619 | PUSH_DE_RS 1620 | pop bc 1621 | PUSH_BC_RS 1622 | pop de 1623 | add hl, de 1624 | HL_TO_BC 1625 | 1626 | POP_DE_RS 1627 | pop hl 1628 | adc hl,de 1629 | 1630 | push hl 1631 | POP_DE_RS 1632 | NEXT 1633 | 1634 | 1635 | ;; add16To32 [Maths] 1636 | ;; Performs `ACIX = ACIX + DE` 1637 | defcode("M+",2,0,m_plus) 1638 | ld (save_ix), ix 1639 | PUSH_DE_RS 1640 | BC_TO_DE 1641 | pop bc 1642 | ld a, b 1643 | add16to32: 1644 | add ix, de 1645 | jp nc, add16to32_done 1646 | or a 1647 | inc c 1648 | jp z, add16to32_done 1649 | add a, 1 1650 | add16to32_done: 1651 | ld b, a 1652 | push bc 1653 | push ix 1654 | pop bc 1655 | ld ix,(save_ix) 1656 | POP_DE_RS 1657 | NEXT 1658 | 1659 | ;; mul32By8 [Maths] 1660 | ;; Performs an unsigned multiplication of DEHL and A. 1661 | ;; Outputs: 1662 | ;; DEHL: product of DEHL and A 1663 | ;; ( 32bit_high 32bit_low 8bit -- 32*8high 32*8 low ) 1664 | defcode("DS", 2, 0, double_scale) 1665 | mul32By8: 1666 | PUSH_DE_RS 1667 | ld a, c 1668 | pop hl 1669 | pop de 1670 | push bc \ push ix 1671 | ld ixl, 8 1672 | push de 1673 | push hl 1674 | ld hl, 0 1675 | ld d, h 1676 | ld e, l 1677 | mul32by8_loop: 1678 | add hl, hl 1679 | rl e 1680 | rl d 1681 | rla 1682 | jr nc, mul32by8_noAdd 1683 | pop bc 1684 | add hl, bc 1685 | ex (sp), hl 1686 | push hl 1687 | adc hl, de 1688 | pop de 1689 | ex de, hl 1690 | ex (sp), hl 1691 | push bc 1692 | mul32by8_noAdd: 1693 | dec ixl 1694 | jr nz, mul32by8_loop 1695 | pop bc 1696 | pop bc 1697 | pop ix \ pop bc 1698 | push de 1699 | HL_TO_BC 1700 | POP_DE_RS 1701 | NEXT 1702 | 1703 | defcode("SPACE",5,0,space) 1704 | ld a, ' ' 1705 | b_call _PutC 1706 | NEXT 1707 | 1708 | defcode("CR",2,0,cr) 1709 | b_call _Newline 1710 | NEXT 1711 | 1712 | defcode("AT-XY",5,0,at_xy) 1713 | ld a, c 1714 | ld (curCol), a 1715 | pop bc 1716 | ld a, c 1717 | ld (curRow), a 1718 | pop bc 1719 | NEXT 1720 | 1721 | defcode("ATS-XY",6,0,ats_xy) 1722 | ld a, c 1723 | ld (PenCol), a 1724 | pop bc 1725 | ld a, c 1726 | ld (PenRow), a 1727 | pop bc 1728 | NEXT 1729 | 1730 | ;; Display a null-terminated string starting at the address 1731 | ;; given to by the TOS. 1732 | 1733 | defcode("PUTS",4,0,putstr) 1734 | BC_TO_HL 1735 | b_call _PutS 1736 | pop bc 1737 | NEXT 1738 | 1739 | defcode("PUTLN",5,0,putstrln) 1740 | BC_TO_HL 1741 | b_call _PutS 1742 | b_call _NewLine 1743 | pop bc 1744 | NEXT 1745 | 1746 | ;; Get a full string of input (i.e. buffer user input for WORD and number etc.) 1747 | ;; Input: none 1748 | ;; Output: none 1749 | ;; Side effect: 1750 | ;; string_buffer contains the user input. 1751 | ;; gets_ptr points to the start of the buffer 1752 | 1753 | ;; We also want immediate feedback to the user. 1754 | #define STRING_BUFFER_SIZE 64 1755 | 1756 | string_buffer: .fill STRING_BUFFER_SIZE,0 1757 | gets_ptr: .dw string_buffer 1758 | 1759 | defcode("GETS",4,0,get_str_forth) 1760 | push de 1761 | push bc 1762 | call get_str 1763 | pop bc 1764 | pop de 1765 | NEXT 1766 | 1767 | get_str: 1768 | ld hl, gets_ptr 1769 | ld de, string_buffer 1770 | 1771 | ;; Reinitialize the gets_ptr to point to the buffered input. 1772 | ld (hl), e 1773 | inc hl 1774 | ld (hl), d 1775 | dec hl 1776 | 1777 | xor a 1778 | ld b, a ;; B will store how many characters we have read. 1779 | ld (CurCol), a 1780 | 1781 | ;; GetKey destroys BC DE HL 1782 | key_loop: 1783 | push hl 1784 | push de 1785 | push bc 1786 | b_call _GetKey 1787 | pop bc 1788 | pop de 1789 | pop hl 1790 | 1791 | cp kEnter 1792 | jp nz, not_enter 1793 | 1794 | ;; Got [ENTER]. Finish up. Maybe the user hit [ENTER] 1795 | ;; without entering anything, we need to check for that too. 1796 | 1797 | ;; We should echo enter. 1798 | ld a, ' ' 1799 | b_call _PutC 1800 | 1801 | ld a, b 1802 | or a 1803 | jp z, no_chars 1804 | 1805 | xor a 1806 | ld (de), a 1807 | 1808 | ret 1809 | 1810 | no_chars: 1811 | xor a 1812 | ld (de), a 1813 | inc de 1814 | ld (de), a 1815 | ret 1816 | not_enter: 1817 | ;; Maybe it's the delete key? 1818 | cp kDel 1819 | jp z, is_del 1820 | 1821 | ;; For convenience, the left arrow key in alpha mode also 1822 | ;; works as a DEL. 1823 | 1824 | cp kLeft 1825 | jp nz, not_del 1826 | 1827 | is_del: 1828 | ;; Yep. Let's give some feedback. 1829 | ld a, b 1830 | or a 1831 | ;; We're still at 0 characters! Restart. 1832 | jp z, key_loop 1833 | 1834 | ld hl, CurCol 1835 | ld a, (hl) 1836 | dec (hl) 1837 | 1838 | ;; Check if 0th column. 1839 | or a 1840 | jr nz, not_backup_line 1841 | ;; Original column was 0, so we need to back up to the 1842 | ;; previous line. 1843 | ld (hl), 15 1844 | dec hl 1845 | dec (hl) 1846 | 1847 | not_backup_line: 1848 | dec de 1849 | dec b 1850 | ld a, ' ' 1851 | b_call _PutMap 1852 | jp key_loop 1853 | 1854 | not_del: 1855 | cp kClear 1856 | jr nz, not_clear 1857 | 1858 | ;; We have to clear everything! 1859 | ld c, b 1860 | ;; Divide C by 16. 1861 | sra c 1862 | sra c 1863 | sra c 1864 | sra c 1865 | 1866 | ld hl, CurRow 1867 | ld a,b 1868 | or a 1869 | ;; No characters left. 1870 | jr z, key_loop 1871 | 1872 | ld a, (hl) 1873 | sub c 1874 | ld c, a 1875 | ld (hl), a 1876 | 1877 | inc hl 1878 | ld (hl), 0 1879 | ld a, ' ' 1880 | 1881 | clear_loop: 1882 | b_call _PutC 1883 | djnz clear_loop 1884 | 1885 | ld (hl), b 1886 | dec hl 1887 | ld (hl), c 1888 | ld de, string_buffer 1889 | jp key_loop 1890 | 1891 | not_clear: 1892 | ld c, a 1893 | ld a, b 1894 | cp STRING_BUFFER_SIZE 1895 | jr z, key_loop 1896 | ld a, c 1897 | 1898 | ;; Special keys that actually write a space. 1899 | cp kSpace 1900 | jp z, write_space 1901 | 1902 | cp kRight ;; right arrow, alpha mode 1903 | jp z, write_space 1904 | 1905 | ;; Convert to ASCII. 1906 | ld h, 0 1907 | ld l, a 1908 | 1909 | push de 1910 | ld de, key_table 1911 | add hl, de 1912 | pop de 1913 | 1914 | ld a, (hl) 1915 | ;; We got a space back as per the table, so it's not printable. Try again. 1916 | cp ' ' 1917 | jp z, key_loop 1918 | jp write_char 1919 | write_space: 1920 | ld a, ' ' 1921 | write_char: 1922 | b_call _PutC 1923 | ld (de), a 1924 | inc de 1925 | inc b 1926 | jp key_loop 1927 | 1928 | ;; Get the next character from the buffer. 1929 | ;; A contains the next character from the buffer. 1930 | defcode("GETC", 4, 0, get_char_forth) 1931 | call get_char_asm 1932 | push bc 1933 | ld b, 0 1934 | ld c, a 1935 | NEXT 1936 | get_char_asm: 1937 | push hl 1938 | push de 1939 | ld hl, gets_ptr 1940 | ld de, (gets_ptr) 1941 | 1942 | ld a, (de) 1943 | or a 1944 | jp z, get_char_end 1945 | inc de 1946 | ld (hl), e 1947 | inc hl 1948 | ld (hl), d 1949 | get_char_end: 1950 | pop de 1951 | pop hl 1952 | ret 1953 | 1954 | defcode("UNGETC", 6, 0, unget_char_forth) 1955 | 1956 | call unget_char 1957 | 1958 | NEXT 1959 | ;; The current gets_ptr may be at a different string buffer, so we can't compare it. 1960 | unget_char: 1961 | push hl 1962 | push de 1963 | ld hl, (gets_ptr) 1964 | ;; b_call _CpHLDE 1965 | ;; scf 1966 | ;; jr z, unget_char_done 1967 | dec hl 1968 | ld (gets_ptr), hl 1969 | unget_char_done: 1970 | pop hl 1971 | ret 1972 | 1973 | ;; Skipping spaces, get the next word from the user. Remember that 1974 | ;; this needs to be flexible enough to be called from Forth as well. 1975 | ;; We expect it to return a pointer to the next word following 1976 | ;; gets_ptr. 1977 | 1978 | ;; ( -- base_addr len ) 1979 | #define BUFSIZE 16 1980 | word_buffer: .fill BUFSIZE, 0 1981 | word_buffer_ptr: .dw 0 1982 | defcode("WORD",4,0,word) 1983 | ;; Save IP and TOS. 1984 | push bc 1985 | push de 1986 | word_restart: 1987 | ld hl, word_buffer_ptr 1988 | ld de, word_buffer 1989 | ;; Initialize word_buffer_ptr to point at the actual start. 1990 | ld (hl), e 1991 | inc hl 1992 | ld (hl), d 1993 | dec hl 1994 | jp skip_space 1995 | word_retry: 1996 | push hl 1997 | push de 1998 | push bc 1999 | call get_str 2000 | pop bc 2001 | pop de 2002 | pop hl 2003 | skip_space: 2004 | call get_char_asm 2005 | or a 2006 | jp z, empty_word ;; get_char_asm returned nothing, so we need to retry 2007 | ;; with get_str 2008 | cp ' ' 2009 | jp z, skip_space 2010 | cp '\n' ;; if we're reading from a converted text file. 2011 | jp z, skip_space 2012 | cp '\t' 2013 | jp z, skip_space 2014 | cp '\\' 2015 | jp z, skip_comment 2016 | jp actual_word 2017 | ;; We really need a word. Ask again! 2018 | empty_word: 2019 | push hl 2020 | ld hl, ok_msg 2021 | b_call _PutS 2022 | b_call _NewLine 2023 | pop hl 2024 | jp word_retry 2025 | skip_comment: 2026 | ;; We could be reading from a text file. 2027 | call get_char_asm 2028 | 2029 | ;; Ran out of input. 2030 | or a 2031 | jp z, empty_word 2032 | 2033 | ;; Newline found. Then go to start. 2034 | cp '\n' 2035 | jp z, skip_space 2036 | 2037 | ;; Some other character. 2038 | jp skip_comment 2039 | 2040 | actual_word: 2041 | ld c, 1 2042 | ;; A contains the character. 2043 | ld hl, (word_buffer_ptr) 2044 | actual_word_write: 2045 | ld (hl), a 2046 | actual_word_loop: 2047 | inc hl 2048 | call get_char_asm 2049 | or a 2050 | jp z, word_done 2051 | cp ' ' 2052 | jp z, word_done 2053 | cp '\n' 2054 | jp z, word_done 2055 | cp '\t' 2056 | jp z, word_done 2057 | 2058 | ;; A is another non-space, printable character. 2059 | inc c 2060 | jp actual_word_write 2061 | 2062 | word_done: 2063 | ;; Either read NUL or a space. 2064 | xor a 2065 | ld (hl), a 2066 | pop de 2067 | ld hl, word_buffer 2068 | ld b, 0 ;; c should contain the number of characters. 2069 | push hl 2070 | NEXT 2071 | 2072 | 2073 | 2074 | ;; Is this word immediate? (assuming it's a pointer returned by FIND) 2075 | defcode("?IMMED",6,0, qimmed) 2076 | inc bc 2077 | inc bc 2078 | ld a, (bc) 2079 | bit 7, a 2080 | jp z, fal 2081 | jp tru 2082 | 2083 | ;; Make the last word immediate 2084 | defcode("IMMED",5,128, immediate) 2085 | ld hl, (var_latest) 2086 | inc hl 2087 | inc hl 2088 | ld a, 128 2089 | xor (hl) 2090 | ld (hl), a 2091 | NEXT 2092 | 2093 | 2094 | ;; Convert a pointer returned by FIND to the start of the name 2095 | ;; field address (something I made up). 2096 | defcode(">NFA",4,0,to_nfa) 2097 | inc bc 2098 | inc bc 2099 | inc bc 2100 | NEXT 2101 | 2102 | ;; Convert a pointer returned by FIND to the start of the code 2103 | ;; field address. 2104 | defcode(">CFA",4,0,to_cfa) 2105 | inc bc 2106 | inc bc ;; Skip the link pointer. 2107 | ld a, (bc) ;; Get the length and flags of the word. 2108 | and F_LENMASK ;; Remove flags except for length. 2109 | ld h, 0 2110 | ld l, a 2111 | inc bc 2112 | add hl, bc 2113 | inc hl 2114 | HL_TO_BC 2115 | NEXT 2116 | 2117 | ;; Are two strings equal? 2118 | ;; ( s1 s2 -- bool ) 2119 | defcode("STR=",4,0,streql) 2120 | PUSH_DE_RS 2121 | pop de 2122 | BC_TO_HL 2123 | call strcmp 2124 | jp z, tru 2125 | jp fal 2126 | 2127 | ;; ( string-ptr length-- pointer to word ) 2128 | defcode("FIND",4,0,find) 2129 | pop bc ;; FIXME: Check length. 2130 | push de 2131 | BC_TO_HL 2132 | ld de, (var_latest) 2133 | inc de 2134 | inc de ;; Skip link pointer and length 2135 | inc de 2136 | 2137 | find_loop: 2138 | call strcmp 2139 | jp z, find_succeed 2140 | jp nz, find_retry 2141 | 2142 | find_succeed: 2143 | ;; We found the word. But is it hidden? 2144 | dec de 2145 | ;; Now we're at the length/flags pointer. 2146 | ld a, (de) 2147 | bit 6, a 2148 | jp nz, find_succ_hidden 2149 | dec de 2150 | dec de 2151 | pop hl 2152 | ex de,hl 2153 | HL_TO_BC 2154 | NEXT 2155 | find_retry: 2156 | dec de 2157 | find_succ_hidden: 2158 | dec de 2159 | dec de 2160 | push hl 2161 | ld a, (de) 2162 | ld l, a 2163 | inc de 2164 | ld a, (de) 2165 | ld h, a 2166 | dec de 2167 | ld a, l 2168 | or a 2169 | jp z, find_maybe_fail 2170 | 2171 | find_retry_cont: 2172 | inc hl 2173 | inc hl 2174 | inc hl 2175 | ex de,hl 2176 | pop hl 2177 | jp find_loop 2178 | find_maybe_fail: 2179 | ld a, h 2180 | cp 0 ;; or a 2181 | jp z, find_fail 2182 | jp nz, find_retry_cont 2183 | find_fail: 2184 | pop hl 2185 | pop de 2186 | jp fal 2187 | 2188 | ;; From KnightOS kernel. 2189 | ;; strcmp [Strings] 2190 | ;; Determines if two strings are equal, and checks alphabetical sort order. 2191 | ;; Inputs: 2192 | ;; HL: String pointer 2193 | ;; DE: String pointer 2194 | ;; Outputs: 2195 | ;; Z: Set if equal, reset if not equal 2196 | ;; C: Set if string HL is alphabetically earlier than string DE 2197 | strcmp: 2198 | push hl 2199 | push de 2200 | strcmp_loop: 2201 | ld a, (de) 2202 | or a 2203 | jr z, strcmp_end 2204 | cp (hl) 2205 | jr nz, strcmp_exit 2206 | inc hl 2207 | inc de 2208 | jr strcmp_loop 2209 | strcmp_end: 2210 | ld a, (hl) 2211 | or a 2212 | strcmp_exit: 2213 | ccf 2214 | pop de 2215 | pop hl 2216 | ret 2217 | 2218 | defcode("WB",2,0,writeback) 2219 | push bc 2220 | push de 2221 | b_call _PopRealO1 ;; from the floating point stack 2222 | b_call _PushRealO1 2223 | b_call _ChkFindSym 2224 | 2225 | ld hl, data_start - $9D95 + 4 ; have to add 4 because of tasmcmp token 2226 | ; (2 bytes) and for size bytes (2 bytes) 2227 | add hl, de ;hl now points to data location in original program. 2228 | ex de, hl ;write back. 2229 | ld hl, data_start 2230 | ld bc, data_end - data_start 2231 | ldir 2232 | 2233 | pop de 2234 | pop bc 2235 | NEXT 2236 | 2237 | 2238 | ;; How many bytes have we used? 2239 | defword("USED",4,0,used) 2240 | .dw here, fetch, hz, sub, exit 2241 | 2242 | defword("SIMG",4,0,save_image) 2243 | .dw here, fetch, lit, save_here, store 2244 | .dw latest, fetch, lit, save_latest, store 2245 | .dw __scratch, hz, used, cmove, writeback, exit 2246 | 2247 | ;; Load the scratch buffer back into the current state. 2248 | defword("LIMG",4,0,load_image) 2249 | .dw lit, save_here, fetch, here, store 2250 | .dw lit, save_latest, fetch, latest, store 2251 | .dw hz, lit, scratch, lit, save_here, fetch, hz, sub, cmove, exit 2252 | 2253 | defword(">DFA",4,0,to_dfa) 2254 | .dw to_cfa, lit, 3, add, exit 2255 | 2256 | defcode("CREATE",6,0,create) ;; ( name length -- ) 2257 | ;; Create link pointer and update var_latest to point to it. 2258 | ld hl, (var_here) 2259 | PUSH_DE_RS 2260 | ld de, (var_latest) 2261 | ld (hl), e 2262 | inc hl 2263 | ld (hl), d 2264 | dec hl 2265 | 2266 | ;; HL points to the new link pointer, so we should write its value into var_latest 2267 | ld de, var_latest 2268 | ld a, l 2269 | ld (de), a 2270 | inc de 2271 | ld a, h 2272 | ld (de), a 2273 | 2274 | inc hl 2275 | inc hl 2276 | ;; Now we have to write the length of the new word. 2277 | ld a, c 2278 | ld (hl), a 2279 | inc hl 2280 | 2281 | ;; LDIR loads the value at (HL) to (DE), increments both, 2282 | ;; decrements BC, loops until BC = 0. 2283 | ex de, hl 2284 | pop hl 2285 | ld b, 0 ;; sanitize input, maybe? 2286 | ldir 2287 | 2288 | xor a 2289 | ld (de), a 2290 | inc de 2291 | 2292 | ld hl, var_here 2293 | ld (hl), e 2294 | inc hl 2295 | ld (hl), d 2296 | 2297 | POP_DE_RS 2298 | pop bc 2299 | NEXT 2300 | 2301 | ;; Recall that Forth words start with a call to docol. The 2302 | ;; opcode of call is CD B6 9D seems to be the 2303 | ;; address of DOCOL right now, but we shouldn't hardcode it so 2304 | ;; we'll let the assembler do its job. 2305 | defcode("DOCOL_H",7,0,docol_header) 2306 | push de 2307 | ld de, (var_here) 2308 | ;; Opcode of CALL 2309 | ld a, $CD 2310 | ld (de), a 2311 | inc de 2312 | ld hl, docol 2313 | ;; Yes, this is correct. We are writing a call docol instruction manually. 2314 | ld a, l 2315 | ld (de), a 2316 | inc de 2317 | ld a, h 2318 | ld (de), a 2319 | inc de 2320 | ld hl, var_here 2321 | ld (hl), e 2322 | inc hl 2323 | ld (hl), d 2324 | pop de 2325 | NEXT 2326 | 2327 | defword(":",1,0,colon) 2328 | .dw word, create, docol_header 2329 | .dw latest, fetch, hidden 2330 | .dw rbrac, exit 2331 | 2332 | defword(";",1,128, semicolon) 2333 | .dw lit, exit, comma 2334 | .dw latest, fetch, hidden 2335 | .dw lbrac, exit 2336 | 2337 | ;; Compile a call in the new word where call DOCOL used to be. 2338 | defcode("(DOES>)",7,0,does_brac) 2339 | push bc 2340 | ld bc, (var_latest) 2341 | inc bc 2342 | inc bc ;; Skip the link pointer. 2343 | ld a, (bc) ;; Get the length and flags of the word. 2344 | and F_LENMASK ;; Remove flags except for length. 2345 | ld h, 0 2346 | ld l, a 2347 | inc bc 2348 | add hl, bc 2349 | inc hl 2350 | inc hl 2351 | ;; Now we need to overwrite the destination of call docol with DE 2352 | ld (hl), e 2353 | inc hl 2354 | ld (hl), d 2355 | pop bc 2356 | 2357 | ;; Mimic exit 2358 | POP_DE_RS 2359 | NEXT 2360 | 2361 | ;; DE contains the address of the next instruction to go to 2362 | ;; Which is the "action" part of the word being defined with DOES>. 2363 | 2364 | defcode("DOES>",5,128,does_start) 2365 | push de 2366 | ld de, (var_here) 2367 | ld hl, does_brac 2368 | ld a, l 2369 | ld (de), a 2370 | inc de 2371 | ld a, h 2372 | ld (de), a 2373 | inc de 2374 | ld a, $CD 2375 | ld (de), a 2376 | inc de 2377 | 2378 | ld hl, dodoes 2379 | ld a, l 2380 | ld (de), a 2381 | inc de 2382 | ld a, h 2383 | ld (de), a 2384 | inc de 2385 | 2386 | ld hl, var_here 2387 | ld (hl), e 2388 | inc hl 2389 | ld (hl), d 2390 | pop de 2391 | NEXT 2392 | 2393 | dodoes: 2394 | PUSH_DE_RS 2395 | ;; Get return address of the DOES> body 2396 | pop de 2397 | BC_TO_HL 2398 | ;; The top of the stack contains the address of the data folloinwg 2399 | ;; call dodoes. We want this on the top of the stack. 2400 | pop bc 2401 | push hl 2402 | NEXT 2403 | 2404 | defcode("PAGE",4,0,page) 2405 | push bc 2406 | push de 2407 | ld a, 0 2408 | ld (currow), a 2409 | ld (curcol), a 2410 | b_call _ClrScrnFull 2411 | pop de 2412 | pop bc 2413 | NEXT 2414 | 2415 | defcode("TOG-SCRL",8,0,toggle_scroll) 2416 | ld a, (IY + AppFlags) 2417 | ld l, %00000100 2418 | xor l 2419 | ld (IY + AppFlags), a 2420 | NEXT 2421 | 2422 | defcode("INVTXT",6,0,inverse_text) 2423 | ld a, (IY + TextFlags) 2424 | ld l, %00001000 2425 | xor l 2426 | ld (IY + TextFlags), a 2427 | NEXT 2428 | 2429 | defcode("HIDDEN",6,0,hidden) 2430 | BC_TO_HL 2431 | inc hl 2432 | inc hl 2433 | ld a, 64 2434 | xor (hl) 2435 | ld (hl), a 2436 | pop bc 2437 | NEXT 2438 | 2439 | defcode("?HIDDEN",7,0,qhidden) 2440 | BC_TO_HL 2441 | inc hl 2442 | inc hl 2443 | ld a, 64 2444 | and (hl) 2445 | ld b, 0 2446 | ld c, a 2447 | NEXT 2448 | 2449 | defword("MOD",3,0, mod) 2450 | .dw divmod, drop, exit 2451 | 2452 | defword("/",1,0,div) 2453 | .dw divmod, swap, drop, exit 2454 | 2455 | defword("NEGATE",6,0,negate) 2456 | .dw lit, 0, swap, sub, exit 2457 | 2458 | defword("TRUE",4,0,true_val) 2459 | .dw lit, 1, exit 2460 | 2461 | defword("FALSE",5,0,false_val) 2462 | .dw lit, 0, exit 2463 | 2464 | defword("NOT",3,0,not) 2465 | .dw zeql, exit 2466 | 2467 | defword("LITERAL",7,128,literal) 2468 | .dw tick, lit, comma, comma, exit 2469 | 2470 | defcode("NIP",3,0,nip) 2471 | pop hl 2472 | NEXT 2473 | 2474 | defcode("TUCK",4,0,tuck) 2475 | pop hl 2476 | push bc 2477 | push hl 2478 | NEXT 2479 | 2480 | defword("ID.",3,0,id_dot) 2481 | .dw lit, 3, add, putstr, exit 2482 | 2483 | defword("HIDE",4,0,hide) 2484 | .dw word, find, hidden, exit 2485 | 2486 | defword("IF",2,128,if) 2487 | .dw tick, zbranch, comma, here, fetch, lit, 0, comma, exit 2488 | 2489 | defword("THEN",4,128,then) 2490 | .dw dup, here, fetch, swap, sub, swap, store, exit 2491 | 2492 | defword("ELSE",4,128,else) 2493 | .dw tick, branch, comma, here, fetch, lit, 0, comma, swap, dup, here 2494 | .dw fetch, swap, sub, swap, store, exit 2495 | 2496 | defword("BEGIN",5,128,begin) 2497 | .dw here, fetch, exit 2498 | 2499 | defword("UNTIL",5,128,until) 2500 | .dw tick, zbranch, comma, here, fetch, sub, comma, exit 2501 | 2502 | defword("AGAIN",5,128,again) 2503 | .dw tick, branch, comma, here, fetch, sub, comma, exit 2504 | 2505 | defword("WHILE",5,128,while) 2506 | .dw tick, zbranch, comma, here, fetch, lit, 0, comma, exit 2507 | 2508 | defword("REPEAT",6,128,repeat) 2509 | .dw tick, branch, comma, swap, here, fetch, sub, comma 2510 | .dw dup, here, fetch, swap, sub, swap, store, exit 2511 | 2512 | defword("CHAR",4,0,char) 2513 | .dw word, drop, fetch_byte, exit 2514 | 2515 | defword("(COMP)",6,128,compile) 2516 | .dw word, find, to_cfa, comma, exit 2517 | 2518 | defword("CONST",5,0,constant) 2519 | .dw word, create, docol_header, lit, lit, comma, comma 2520 | .dw lit, exit, comma, exit 2521 | 2522 | defword("ALLOT",5,0,allot) 2523 | .dw here, fetch, swap, here, add_store, exit 2524 | 2525 | defword("CELLS",4,0,cells) 2526 | .dw lit, 2, mult, exit 2527 | 2528 | defword("RECURSE",7,128,recurse) 2529 | .dw latest, fetch, to_cfa, comma, exit 2530 | 2531 | defword("VAR",3,0,variable) 2532 | .dw lit, 2, allot, word, create, docol_header, tick, lit, comma, comma 2533 | .dw tick, exit, comma, exit 2534 | 2535 | defword("DO",2,128, do) 2536 | .dw here, fetch, tick, to_r, comma, tick, to_r, comma, exit 2537 | 2538 | defword("LOOP",4,128, loop) 2539 | .dw tick, from_r, comma, tick, from_r, comma, tick, one_plus, comma, tick, two_dup, comma 2540 | .dw tick, eql, comma, tick, zbranch, comma, here, fetch, sub, comma, tick, two_drop, comma, exit 2541 | 2542 | 2543 | defword("+LOOP",5,128, add_loop) 2544 | .dw tick, from_r, comma, tick, from_r, comma, tick, rot, comma, tick, add, comma, tick, two_dup, comma 2545 | .dw tick, eql, comma, tick, zbranch, comma, here, fetch, sub, comma, tick, two_drop, comma, exit 2546 | 2547 | defword("FORGET",6,0,forget) 2548 | .dw word, find, dup, fetch, latest, store, here, store, exit 2549 | 2550 | defcode("'0'",3,0,zeroc) 2551 | push bc 2552 | ld bc, 48 2553 | NEXT 2554 | 2555 | defcode("'9'",3,0,ninec) 2556 | push bc 2557 | ld bc, 57 2558 | NEXT 2559 | 2560 | defword("WITHIN",6,0,within) 2561 | .dw over, sub, to_r, sub, from_r, less_eq, exit 2562 | 2563 | defword("NUM?",4,0,numq) 2564 | .dw zeroc, ninec, within, exit 2565 | 2566 | defword("PARSE-NUM", 9, 0, parse_num) 2567 | .dw dup, fetch_byte, dup, numq, zjump, parse_num_fail 2568 | .dw zeroc, sub 2569 | 2570 | parse_num_continue: 2571 | .dw swap, one_plus, swap 2572 | 2573 | parse_num_loop: 2574 | .dw over, fetch_byte, zjump, parse_num_done 2575 | .dw over, fetch_byte, numq, zjump, parse_num_fail 2576 | .dw over, fetch_byte, zeroc, sub, swap, lit, 10, mult, add 2577 | .dw jump, parse_num_continue 2578 | 2579 | parse_num_done: 2580 | .dw swap, drop 2581 | .dw lit, 1, num_status, store, exit 2582 | 2583 | parse_num_fail: 2584 | .dw two_drop, lit, 0, num_status, store, exit 2585 | 2586 | defword("CFA>",4,0, cfa_to) 2587 | .dw latest, fetch, qdup, zbranch, 22, two_dup, swap 2588 | .dw less_than, zbranch, 6, nip, exit, fetch, branch, -24, drop, lit, 0, exit 2589 | 2590 | defword("PICK",4,0,pick) 2591 | .dw one_plus, left_shift, sp_fetch, add, fetch, exit 2592 | 2593 | defword("U.",2,0,u_dot_) 2594 | .dw base, fetch, divmod, qdup, zbranch, 4, u_dot_, dup, lit, 10, less_than 2595 | .dw zbranch, 10, lit, 48, branch, 12, lit, 10, sub, lit, 65, add, emit, exit 2596 | 2597 | defword("UWIDTH",6,0,u_width) 2598 | .dw base, fetch, div, qdup, zbranch, 10, u_width, one_plus, branch, 6, lit, 1, exit 2599 | 2600 | defword("SPACES",6,0,spaces) 2601 | .dw lit, 0, to_r, to_r, space, from_r, from_r, one_plus, two_dup, eql, zbranch, 65518 2602 | .dw two_drop, exit 2603 | 2604 | defword("U.R",3,0,u_dot_r) 2605 | .dw swap, dup, u_width, rot, swap, sub, spaces, u_dot_, exit 2606 | 2607 | defword("U.",2,0,u_dot) 2608 | .dw u_dot_, space, exit 2609 | 2610 | defword(".",1,0,print_tos) 2611 | .dw u_dot, exit 2612 | 2613 | defword("DEPTH",5,0,depth) 2614 | .dw sz, fetch, sp_fetch, sub, two_minus, right_shift, exit 2615 | 2616 | defword(".S",2,0,print_stack) 2617 | .dw lit, '<', emit, depth, u_dot_, lit, '>', emit, space 2618 | .dw sp_fetch, dup, sz, fetch, less_than, zbranch, 18, dup, fetch, u_dot 2619 | .dw lit, 2, add, branch, 65510, drop, exit 2620 | 2621 | defword("HEX",3,0,hex) 2622 | .dw lit, 16, base, store, exit 2623 | 2624 | defword("DEC",3,0,decimal) 2625 | .dw lit, 10, base, store, exit 2626 | 2627 | ;; This word was bootstrapped from an interpreted definition. 2628 | defword("SEE",3,0,see) 2629 | ;; New version in progress, doesn't seem to work well. 2630 | ;; .dw word, find, here, fetch, latest, fetch, lit, 2, pick, over, neql, zbranch, 12 2631 | ;; .dw nip, dup, fetch, branch, 65514, drop, swap, lit, 58, emit, space, dup, id_dot 2632 | ;; .dw space, dup, qimmed, zbranch, 19, litstring, 10 2633 | ;; .db "IMMEDIATE " 2634 | ;; .dw to_dfa, key, drop, two_dup, greater_than, zbranch, 293, dup, fetch, tick, lit 2635 | ;; .dw over, eql, zbranch, 16, drop, two_plus, dup, fetch, u_dot, branch, 257, tick 2636 | ;; .dw litstring, over, eql, zbranch, 54, drop, lit, 83, emit, two_plus, dup, fetch 2637 | ;; .dw dup, u_dot, lit, 34, emit, space, swap 2638 | ;; .dw two_plus, swap, two_dup, tell 2639 | ;; .dw lit, 34, emit, space, add, one_plus, branch, 193, tick, zbranch, over, eql 2640 | ;; .dw zbranch, 42, drop 2641 | ;; .dw litstring, 10 2642 | ;; .db "0BRANCH ( " 2643 | ;; .dw two_plus, dup, fetch, u_dot, litstring, 2 2644 | ;; .db ") " 2645 | ;; .dw branch, 141, tick, branch, over, eql, zbranch, 41, drop, litstring, 9 2646 | ;; .db "BRANCH ( " 2647 | ;; .dw two_plus, dup, fetch, u_dot, litstring, 2 2648 | ;; .db ") " 2649 | ;; .dw branch, 90, tick, tick, over, eql, zbranch, 28, drop, lit, 39, emit, space 2650 | ;; .dw two_plus, dup, fetch, cfa_to, id_dot, space, branch, 52, tick, exit, over 2651 | ;; .dw eql, zbranch, 30, drop, two_dup, two_plus, neql, zbranch, 14, litstring, 5 2652 | ;; .db "EXIT " 2653 | ;; .dw branch, 12, dup, cfa_to, id_dot, space, drop, two_plus, branch, 65235 2654 | ;; .dw lit, 59, emit, cr, two_drop, exit 2655 | 2656 | ;; Old version of SEE 2657 | .dw word, find, here, fetch, latest, fetch, lit, 2, pick, over, neql, zbranch, 12 2658 | .dw nip, dup, fetch, branch, 65514, drop, swap, lit, 58, emit, space, dup, id_dot 2659 | .dw space, dup, qimmed, zbranch, 10, lit, 73, emit, space, to_dfa, key, drop 2660 | .dw two_dup, greater_than, zbranch, 196, dup, fetch, tick, lit, over, eql, zbranch, 16 2661 | .dw drop, two_plus, dup, fetch, u_dot, branch, 160, tick, zbranch, over, eql, zbranch, 30 2662 | .dw drop, lit, 48, emit, lit, 66, emit, two_plus, dup, fetch, space, u_dot, branch, 120 2663 | .dw tick, branch, over, eql, zbranch, 24, drop, lit, 66, emit, space, two_plus, dup, fetch 2664 | .dw u_dot, branch, 86, tick, tick, over, eql, zbranch, 28, drop, lit, 39, emit, space, two_plus 2665 | .dw dup, fetch, cfa_to, id_dot, space, branch, 48, tick, exit, over, eql, zbranch, 26, drop 2666 | .dw two_dup, two_plus, neql, zbranch, 10, lit, 69, emit, space, branch, 12, dup, cfa_to 2667 | .dw id_dot, space, drop, two_plus, branch, 65332, lit, 59, emit, cr, two_drop, exit 2668 | 2669 | defword("WORDS",5,0,words) 2670 | .dw latest, fetch, key, lit, 5, neql, zbranch, 32, dup, zbranch, 24, dup, qhidden, not, zbranch, 8 2671 | .dw dup, id_dot, space, fetch, branch, -38, cr, drop, exit 2672 | 2673 | defword("CASE",4,128,case) 2674 | .dw lit, 0, exit 2675 | 2676 | defword("OF", 2, 128, of) 2677 | .dw tick, over, comma, tick, eql, comma, if, tick, drop, comma, exit 2678 | 2679 | defword("ENDOF", 5, 128, endof) 2680 | .dw else, exit 2681 | 2682 | defword("ENDCASE", 7, 128, endcase) 2683 | .dw tick, drop, comma, qdup, zbranch, 8, then, branch, -10, exit 2684 | 2685 | defcode("I",1,0,curr_loop_index) 2686 | push bc 2687 | ld c, (ix + 2) 2688 | ld b, (ix + 3) 2689 | NEXT 2690 | 2691 | defcode("J",1,0,curr_loop_index2) 2692 | push bc 2693 | ld c, (ix + 6) 2694 | ld b, (ix + 7) 2695 | NEXT 2696 | 2697 | zero_blk_name_buffer: 2698 | ld hl, blk_name_buffer 2699 | xor a 2700 | ld (hl), a 2701 | inc hl 2702 | ld (hl), a 2703 | inc hl 2704 | ld (hl), a 2705 | inc hl 2706 | ld (hl), a 2707 | inc hl 2708 | ld (hl), a 2709 | inc hl 2710 | ld (hl), a 2711 | inc hl 2712 | ld (hl), a 2713 | inc hl 2714 | ld (hl), a 2715 | inc hl 2716 | ld (hl), a 2717 | 2718 | ret 2719 | 2720 | scr_name: .db "SCRATCH",0 2721 | ;; ( -- ) 2722 | defcode("CSCR",4,0,create_scratch) 2723 | call zero_blk_name_buffer 2724 | push bc 2725 | ld bc, scr_name 2726 | push bc 2727 | ld bc, 7 2728 | 2729 | ;; First make a variable name in OP1. 2730 | pop hl 2731 | push de 2732 | ld de, blk_name_buffer 2733 | ;; Indicate that this variable is a program. 2734 | ld a, ProgObj 2735 | ld (de), a 2736 | inc de 2737 | ;; Copy the 8-character name. 2738 | ldir 2739 | 2740 | push ix 2741 | ld hl, blk_name_buffer 2742 | b_call _Mov9ToOP1 2743 | ;; Allocate 255 bytes (default block size, change later if needed) 2744 | ld hl, 1024 2745 | b_call _CreateProg 2746 | pop ix 2747 | ;; DE contains the start of the memory location. 2748 | ld b, d 2749 | ld c, e 2750 | ex de, hl 2751 | pop de 2752 | 2753 | ld (hl), 0 2754 | inc hl 2755 | ld (hl), 4 2756 | inc bc 2757 | inc bc 2758 | NEXT 2759 | 2760 | 2761 | blk_name_buffer: .fill 9, 0 2762 | ;; ( name_string name_len -- block_start ) 2763 | defcode("CBLK",4,0,create_block) 2764 | call zero_blk_name_buffer 2765 | ;; First make a variable name in OP1. 2766 | pop hl 2767 | push de 2768 | ld de, blk_name_buffer 2769 | ;; Indicate that this variable is a program. 2770 | ld a, ProgObj 2771 | ld (de), a 2772 | inc de 2773 | ;; Copy the 8-character name. 2774 | ldir 2775 | 2776 | push ix 2777 | ld hl, blk_name_buffer 2778 | b_call _Mov9ToOP1 2779 | ;; Allocate 255 bytes (default block size, change later if needed) 2780 | ld hl, 255 2781 | b_call _CreateProg 2782 | pop ix 2783 | ;; DE contains the start of the memory location. 2784 | ld b, d 2785 | ld c, e 2786 | ex de, hl 2787 | pop de 2788 | 2789 | ld (hl), 255 2790 | inc hl 2791 | ld (hl), 0 2792 | inc bc 2793 | inc bc 2794 | NEXT 2795 | 2796 | ;; ( name_string name_len -- data_start ) 2797 | ;; Return 0 if not found. 2798 | defcode("FBLK",4,0,find_block) 2799 | call zero_blk_name_buffer 2800 | pop hl 2801 | push de 2802 | ld de, blk_name_buffer ;; skip the tag byte. 2803 | ld a, ProgObj 2804 | ld (de), a 2805 | inc de 2806 | ldir 2807 | 2808 | push ix 2809 | ld hl, blk_name_buffer 2810 | b_call _Mov9ToOP1 2811 | b_call _ChkFindSym 2812 | pop ix 2813 | jp c, fblk_fail 2814 | ld b, d 2815 | ld c, e 2816 | pop de 2817 | inc bc 2818 | inc bc 2819 | NEXT 2820 | fblk_fail: 2821 | pop de 2822 | jp fal 2823 | 2824 | ;; Switch the input stream to the pointer on the stack. 2825 | ;; ( prog_start_ptr -- ) 2826 | ;; When WORD runs out of input it calls GETS, which resets gets_ptr 2827 | defcode("RUN",3,0,run) 2828 | BC_TO_HL 2829 | ld (gets_ptr), hl 2830 | pop bc 2831 | ld de, interp 2832 | NEXT 2833 | 2834 | 2835 | load_not_found_msg1: .db "File ",0 2836 | load_not_found_msg2: .db " not found. ",0 2837 | load_long_name_msg: .db "Name must be 8 characters or shorter. ", 0 2838 | defword("LOAD",4,0,load_file) 2839 | .dw word, dup, lit, 8, greater_than, zbranch, 12 2840 | .dw lit, load_long_name_msg, putstrln, two_drop, exit 2841 | .dw find_block, dup, zbranch, 8, run, branch, 22 2842 | .dw lit, load_not_found_msg1, putstr, lit, word_buffer, putstr 2843 | .dw lit, load_not_found_msg2, putstrln, drop, exit 2844 | 2845 | 2846 | defcode("REFILL", 6, 0, refill) 2847 | call get_str 2848 | NEXT 2849 | 2850 | defword("QUIT", 4, 0, quit) 2851 | .dw sz, fetch, sp_store, refill, jump, interpret_loop 2852 | 2853 | 2854 | ;; Taken from http://z80-heaven.wikidot.com/sound 2855 | 2856 | ;; ( frequency duration -- ) 2857 | defcode("SMIT",4,0,sound_emit) 2858 | BC_TO_HL 2859 | pop bc 2860 | push de 2861 | call p_FreqOut 2862 | pop de 2863 | pop bc 2864 | NEXT 2865 | p_FreqOut: 2866 | ;Inputs: 2867 | ; HL is the duration of the note 2868 | ; BC is the frequency 2869 | xor a 2870 | FreqOutLoop1: 2871 | push bc 2872 | xor 3 ;this will toggle the lower two bits (the data being sent to the link port) 2873 | ld e,a 2874 | FreqOutLoop2: 2875 | ld a,h 2876 | or l 2877 | jr z,FreqOutDone 2878 | cpd 2879 | jp pe,FreqOutLoop2 2880 | ld a,e 2881 | scf 2882 | FreqOutDone: 2883 | pop bc 2884 | out (0),a 2885 | jr c,FreqOutLoop1 2886 | xor b 2887 | nop 2888 | nop 2889 | out (0),a ;reset the port, else the user will be really annoyed. 2890 | ret 2891 | 2892 | 2893 | defcode("PLOT",4,0,plot) 2894 | push bc 2895 | push de 2896 | b_call _GrBufCpy 2897 | pop de 2898 | pop bc 2899 | NEXT 2900 | 2901 | ;; Creating an editor. Rough idea: We want to have a block-editing 2902 | ;; system to be able to save and read programs. We use the small 2903 | ;; variable width font instead of the large one, so that we may place 2904 | ;; it on the screen. 2905 | 2906 | ;; ( address_to_write_to -- ) 2907 | defword("WR", 2, 0, write) 2908 | ;; The second get_str_forth is necessary as we don't want the 2909 | ;; interpreter to read the entered text 2910 | .dw cr, get_str_forth, cr, __string_buffer, swap, __string_buffer_size, cmove, get_str_forth, exit 2911 | 2912 | defcode("TELLS", 5, 0, tell_small) 2913 | BC_TO_HL 2914 | b_call _VPutS 2915 | b_call _NewLine 2916 | pop bc 2917 | NEXT 2918 | 2919 | defcode("BYE",3,128,bye) 2920 | jp done 2921 | 2922 | ;; MAKE SURE THIS IS THE LAST WORD TO BE DEFINED! 2923 | defword("STAR", 4, 0, star) 2924 | .dw lit, 42, emit, exit 2925 | 2926 | ok_msg: .db " ok",0 2927 | undef_msg: .db " ?",0 2928 | prog_exit: .dw 0 2929 | save_sp: .dw 0 2930 | save_ix: .dw 0 2931 | 2932 | return_stack_top .EQU $91DC + 294 2933 | 2934 | ;; 2935 | interp: 2936 | .dw get_str_forth, interpret, done 2937 | 2938 | ;; The interpreter 2939 | defword("INTERPRET", 9, 0, interpret) 2940 | interpret_loop: 2941 | .dw word, find, qdup, zjump, maybe_num 2942 | .dw lit, var_state, fetch, not, zjump, interpret_word 2943 | 2944 | compiling_word: 2945 | .dw dup, qimmed, zjump, compile_word 2946 | 2947 | interpret_word: 2948 | .dw to_cfa, execute, jump, interpret_loop 2949 | 2950 | compile_word: 2951 | .dw to_cfa, comma, jump, interpret_loop 2952 | 2953 | maybe_num: 2954 | .dw lit, word_buffer, parse_num 2955 | .dw num_status, fetch, zjump, undef 2956 | .dw lit, var_state, fetch, not, zjump, interpret_loop 2957 | 2958 | compile_num: 2959 | .dw lit, lit, comma, comma, jump, interpret_loop 2960 | undef: 2961 | ;; Go to interpret mode and clear the stack. 2962 | .dw lbrac, sz, fetch, sp_store 2963 | .dw lit, undef_msg, putstrln, jump, interpret_loop 2964 | 2965 | .dw done 2966 | 2967 | 2968 | data_start: 2969 | here_start: 2970 | scratch: 2971 | .fill 350, 0 2972 | save_latest: .dw star 2973 | save_here: .dw scratch 2974 | data_end: 2975 | --------------------------------------------------------------------------------