├── .gitignore ├── COPYING.txt ├── Makefile ├── README.md ├── misc └── z80.vim └── src ├── binary.asm ├── control.asm ├── dict.asm ├── maths.asm ├── memory.asm ├── stack.asm ├── tokens.asm ├── tools.asm └── zenv.asm /.gitignore: -------------------------------------------------------------------------------- 1 | *.lst 2 | *.bin 3 | *.tap 4 | *.swp 5 | *.xcf 6 | todo.txt 7 | zenv.vim 8 | -------------------------------------------------------------------------------- /COPYING.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021-2024 Christopher Leonard 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # ZEnv - Forth for the ZX Spectrum 2 | # Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 3 | # https://github.com/veltas/zenv 4 | 5 | # Makefile 6 | 7 | .PHONY: all 8 | all: bin/zenv.tap 9 | 10 | .PHONY: clean 11 | clean: 12 | -rm -r bin 13 | 14 | bin: 15 | mkdir -p $@ 16 | 17 | #zenv-unpadded.bin: zenv.asm 18 | bin/zenv.bin: $(wildcard src/*.asm) | bin 19 | sjasmplus --nologo src/zenv.asm --lst=bin/zenv.lst --raw="$@" 20 | 21 | bin/zenv.tap: bin/zenv.bin | bin 22 | bin2tap -b -cb 7 -cp 7 -ci 0 -o $@ $< 23 | 24 | bin/zenv.wav: bin/zenv.tap | bin 25 | tape2wav $< $@ 26 | 27 | # Stereo version for use with a stereo phone cable on the ZX Spectrum. 28 | bin/stereo.wav: bin/zenv.wav | bin 29 | ffmpeg -y -i $< -af "aeval=c=stereo:exprs=val(0)|-val(0)" $@ 30 | 31 | # ROM-style version? 32 | #zenv.bin: zenv-unpadded.bin 33 | # head -c $$(( 16384 - $$( wc -c $< | sed 's/ .*//' ) )) /dev/zero | cat $< - > $@ 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | zenv - Forth for the ZX Spectrum 2 | ================================ 3 | 4 | This project is a Forth environment for the ZX Spectrum. 5 | 6 | ![screenshot of zenv in emulator](https://i.imgur.com/trGIH86.png) 7 | 8 | Community 9 | --------- 10 | 11 | IRC channel [#zenv](https://webchat.oftc.net/?channels=#zenv) on OFTC. 12 | 13 | Design 14 | ------ 15 | 16 | zenv implements most of the ANS Forth core words and some extension/alternative 17 | word sets. 18 | 19 | zenv can be built with direct threading and tokenised direct threading (see 20 | `tokenised` variable in [src/zenv.asm](src/zenv.asm)). 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 25 | https://github.com/veltas/zenv 26 | -------------------------------------------------------------------------------- /misc/z80.vim: -------------------------------------------------------------------------------- 1 | " ZEnv - Forth for the ZX Spectrum 2 | " Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 3 | " https://github.com/veltas/zenv 4 | 5 | " Vim syntax file for Z80 assembly 6 | 7 | " Copy to e.g. ~/.vim/syntax/ to enable 8 | 9 | if exists("b:current_syntax") 10 | finish 11 | endif 12 | 13 | syntax case ignore 14 | 15 | syn match z80Keywords "\' 21 | 22 | syn match z80Number "\<\d\+\>" 23 | syn match z80Number "\<0[xX]\x\+\>" 24 | syn match z80Number "\<0[bB][01]\+\>" 25 | 26 | syn region z80String start=/\v"/ skip=/\v\\./ end=/\v"/ 27 | syn region z80String start=/\v(af)@2", 0 88 | i_leave: 89 | PUSH HL 90 | LD L, (IX+4) 91 | LD H, (IX+5) 92 | JP next 93 | 94 | 95 | HEADER _j, "J", 0 96 | _j: 97 | PUSH HL 98 | LD L, (IX+6) 99 | LD H, (IX+7) 100 | JP next 101 | 102 | 103 | HEADER _k, "K", 0 104 | _k: 105 | PUSH HL 106 | LD L, (IX+12) 107 | LD H, (IX+13) 108 | JP next 109 | -------------------------------------------------------------------------------- /src/dict.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Dictionary words 8 | 9 | 10 | ; \ Remove named word and everything in dictionary after 11 | ; ( " name" --) 12 | ; : FORGET 13 | HEADER forget, "FORGET", 0 14 | forget: 15 | CALL colon_code 16 | ; BL WORD 17 | DX bl: DX word 18 | ; ( str) 19 | ; SYM-LAST @ 20 | DX sym_last: DX fetch 21 | ; ( str sym) 22 | ; BEGIN 23 | .begin: 24 | ; ?DUP 0= IF CWHAT? THEN 25 | DX question_dup: DX zero_equals: DX if_raw: DB .then-$-1: DX cwhat_question 26 | .then: 27 | ; 2DUP >SYM ROT COUNT COMPARE WHILE 28 | DX two_dup: DX to_sym: DX rot: DX count: DX compare: DX if_raw 29 | DB .repeat-$-1 30 | ; @ 31 | DX fetch 32 | ; REPEAT 33 | DX again_raw 34 | DB .begin-$+256 35 | .repeat: 36 | ; NIP 37 | DX nip 38 | ; ( sym) 39 | ; DUP @ SWAP 40 | DX dup: DX fetch: DX swap 41 | ; ( prev-sym sym) 42 | ; H ! 43 | DX h_: DX store 44 | ; ( prev-sym) 45 | ; SYM-LAST ! ; 46 | DX sym_last: DX store: DX exit 47 | -------------------------------------------------------------------------------- /src/maths.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Mathematical word definitions 8 | 9 | 10 | HEADER plus, "+", 0 11 | plus: 12 | POP DE 13 | ADD HL, DE 14 | JP next 15 | 16 | 17 | HEADER minus, "-", 0 18 | minus: 19 | POP DE 20 | EX DE, HL 21 | OR A 22 | SBC HL, DE 23 | JP next 24 | 25 | 26 | HEADER zero_literal, "0", 0 27 | zero_literal: 28 | PUSH HL 29 | LD HL, 0 30 | JP next 31 | 32 | 33 | HEADER one_literal, "1", 0 34 | one_literal: 35 | PUSH HL 36 | LD HL, 1 37 | JP next 38 | 39 | 40 | HEADER star, "*", 0 41 | star: 42 | POP DE 43 | LD C, L 44 | LD A, H 45 | LD B, 16 46 | .loop: 47 | ADD HL, HL 48 | SLA C 49 | RLA 50 | JR NC, .skip_add 51 | ADD HL, DE 52 | .skip_add: 53 | DJNZ .loop 54 | JP next 55 | 56 | 57 | HEADER zero_equals, "0=", 0 58 | zero_equals: 59 | LD A, L 60 | OR H 61 | JR NZ, .not_equal 62 | DEC HL 63 | JP next 64 | .not_equal: 65 | LD HL, 0 66 | JP next 67 | 68 | 69 | HEADER zero_less, "0<", 0 70 | zero_less: 71 | ADD HL, HL 72 | SBC HL, HL 73 | JP next 74 | -------------------------------------------------------------------------------- /src/memory.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Memory manipulating words 8 | 9 | 10 | HEADER fetch, "@", 0 11 | fetch: 12 | LD E, (HL) 13 | INC HL 14 | LD D, (HL) 15 | EX DE, HL 16 | JP next 17 | 18 | 19 | HEADER c_fetch, "C@", 0 20 | c_fetch: 21 | LD E, (HL) 22 | LD D, 0 23 | EX DE, HL 24 | JP next 25 | 26 | 27 | HEADER store, "!", 0 28 | store: 29 | POP DE 30 | LD (HL), E 31 | INC HL 32 | LD (HL), D 33 | JP drop 34 | 35 | 36 | HEADER c_store, "C!", 0 37 | c_store: 38 | POP DE 39 | LD (HL), E 40 | JP drop 41 | 42 | 43 | HEADER plus_store, "+!", 0 44 | plus_store: 45 | POP DE 46 | LD C, (HL) 47 | INC HL 48 | LD B, (HL) 49 | EX DE, HL 50 | ADD HL, BC 51 | EX DE, HL 52 | LD (HL), D 53 | DEC HL 54 | LD (HL), E 55 | JP drop 56 | -------------------------------------------------------------------------------- /src/stack.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Stack operation words 8 | 9 | 10 | HEADER drop_, "DROP", 0 11 | drop_: 12 | JP drop 13 | 14 | 15 | HEADER two_drop, "2DROP", 0 16 | two_drop: 17 | POP HL 18 | JP drop 19 | 20 | 21 | HEADER dup, "DUP", 0 22 | dup: 23 | PUSH HL 24 | JP next 25 | 26 | 27 | HEADER two_swap, "2SWAP", 0 28 | two_swap: 29 | POP BC 30 | POP DE 31 | POP AF 32 | PUSH BC 33 | PUSH HL 34 | PUSH AF 35 | EX DE, HL 36 | JP next 37 | 38 | 39 | ; Token vector is included here as a space optimisation, it is page-aligned 40 | INCLUDE "tokens.asm" 41 | 42 | 43 | HEADER swap, "SWAP", 0 44 | create_code: 45 | swap: 46 | EX (SP), HL 47 | JP next 48 | 49 | 50 | HEADER two_dup, "2DUP", 0 51 | two_dup: 52 | POP DE 53 | PUSH DE 54 | PUSH HL 55 | PUSH DE 56 | JP next 57 | 58 | 59 | HEADER over, "OVER", 0 60 | over: 61 | POP DE 62 | PUSH DE 63 | PUSH HL 64 | EX DE, HL 65 | JP next 66 | 67 | 68 | HEADER tuck, "TUCK", 0 69 | tuck: 70 | POP DE 71 | PUSH HL 72 | PUSH DE 73 | JP next 74 | 75 | 76 | HEADER nip, "NIP", 0 77 | nip: 78 | POP DE 79 | JP next 80 | 81 | 82 | HEADER rot, "ROT", 0 83 | rot: 84 | POP AF 85 | POP DE 86 | PUSH AF 87 | PUSH HL 88 | EX DE, HL 89 | JP next 90 | 91 | 92 | HEADER minus_rot, "-ROT", 0 93 | minus_rot: 94 | POP DE 95 | POP AF 96 | PUSH HL 97 | PUSH AF 98 | EX DE, HL 99 | JP next 100 | 101 | 102 | HEADER r_fetch, "R@", 0 103 | r_fetch: 104 | PUSH HL 105 | LD L, (IX+0) 106 | LD H, (IX+1) 107 | JP next 108 | 109 | 110 | HEADER two_r_fetch, "2R@", 0 111 | two_r_fetch: 112 | PUSH HL 113 | LD L, (IX+0) 114 | LD H, (IX+1) 115 | LD E, (IX+2) 116 | LD D, (IX+3) 117 | PUSH DE 118 | JP next 119 | 120 | 121 | HEADER r_from, "R>", 0 122 | r_from: 123 | PUSH HL 124 | LD L, (IX+0) 125 | LD H, (IX+1) 126 | INC IXL 127 | INC IXL 128 | JP next 129 | 130 | 131 | HEADER two_r_from, "2R>", 0 132 | two_r_from: 133 | PUSH HL 134 | LD L, (IX+0) 135 | LD H, (IX+1) 136 | LD E, (IX+2) 137 | LD D, (IX+3) 138 | PUSH DE 139 | LD DE, 4 140 | ADD IX, DE 141 | JP next 142 | 143 | 144 | HEADER to_r, ">R", 0 145 | to_r: 146 | DEC IXL 147 | DEC IXL 148 | LD (IX+0), L 149 | LD (IX+1), H 150 | JP drop 151 | 152 | 153 | HEADER two_to_r, "2>R", 0 154 | two_to_r: 155 | LD DE, -4 156 | ADD IX, DE 157 | POP DE 158 | LD (IX+0), L 159 | LD (IX+1), H 160 | LD (IX+2), E 161 | LD (IX+3), D 162 | JP drop 163 | 164 | 165 | ; ( x_u ... x_0 u | x_u ... x_0 x_u) 166 | ; CODE PICK 167 | HEADER pick, "PICK", 0 168 | pick: 169 | ADD HL, HL 170 | ADD HL, SP 171 | LD E, (HL) 172 | INC L 173 | LD D, (HL) 174 | EX DE, HL 175 | JP next 176 | -------------------------------------------------------------------------------- /src/tokens.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Tokens vector 8 | 9 | 10 | IF tokenised 11 | ALIGN 0x100 12 | tokens: 13 | exit_tok: 14 | DW exit 15 | dup_tok: 16 | DW dup 17 | question_dup_tok: 18 | DW question_dup 19 | less_than_tok: 20 | DW less_than 21 | greater_than_tok: 22 | DW greater_than 23 | drop_tok: 24 | DW drop 25 | two_drop_tok: 26 | DW two_drop 27 | swap_tok: 28 | DW swap 29 | rot_tok: 30 | DW rot 31 | over_tok: 32 | DW over 33 | nip_tok: 34 | DW nip 35 | tuck_tok: 36 | DW tuck 37 | plus_tok: 38 | DW plus 39 | one_plus_tok: 40 | DW one_plus 41 | one_minus_tok: 42 | DW one_minus 43 | minus_tok: 44 | DW minus 45 | raw_char_tok: 46 | DW raw_char 47 | literal_raw_tok: 48 | DW literal_raw 49 | if_raw_tok: 50 | DW if_raw 51 | else_skip_tok: 52 | DW else_skip 53 | store_tok: 54 | DW store 55 | c_store_tok: 56 | DW c_store 57 | fetch_tok: 58 | DW fetch 59 | c_fetch_tok: 60 | DW c_fetch 61 | two_fetch_tok: 62 | DW two_fetch 63 | two_swap_tok: 64 | DW two_swap 65 | to_r_tok: 66 | DW to_r 67 | r_from_tok: 68 | DW r_from 69 | r_fetch_tok: 70 | DW r_fetch 71 | zero_literal_tok: 72 | DW zero_literal 73 | one_literal_tok: 74 | DW one_literal 75 | true_tok: 76 | DW true 77 | to_in_tok: 78 | DW to_in 79 | postpone_raw_tok: 80 | DW postpone_raw 81 | zero_equals_tok: 82 | DW zero_equals 83 | equals_tok: 84 | DW equals 85 | not_equals_tok: 86 | DW not_equals 87 | until_raw_tok: 88 | DW until_raw 89 | again_raw_tok: 90 | DW again_raw 91 | do_raw_tok: 92 | DW do_raw 93 | question_do_raw_tok: 94 | DW question_do_raw 95 | loop_raw_tok: 96 | DW loop_raw 97 | compile_comma_tok: 98 | DW compile_comma 99 | negate_tok: 100 | DW negate 101 | _abs_tok: 102 | DW _abs 103 | and_tok: 104 | DW and 105 | or_tok: 106 | DW or 107 | xor_tok: 108 | DW xor 109 | invert_tok: 110 | DW invert 111 | tick_in_tok: 112 | DW tick_in 113 | in_size_tok: 114 | DW in_size 115 | dot_quote_raw_tok: 116 | DW dot_quote_raw 117 | abort_quote_raw_tok: 118 | DW abort_quote_raw 119 | t_col_tok: 120 | DW t_col 121 | t_row_tok: 122 | DW t_row 123 | within_tok: 124 | DW within 125 | cell_plus_tok: 126 | DW cell_plus 127 | cells_tok: 128 | DW cells 129 | ENDIF 130 | -------------------------------------------------------------------------------- /src/tools.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Tools / utils 8 | 9 | 10 | ; \ Print hexdump of memory 11 | ; ( a u --) 12 | ; : HEXDUMP 13 | hexdump: 14 | CALL colon_code 15 | ; BASE @ -ROT HEX 16 | DX base: DX fetch: DX minus_rot: DX hex 17 | ; ( base a u) 18 | ; OVER + SWAP ?DO 19 | DX over: DX plus: DX swap: DX question_do_raw: DB .loop-$-1 20 | .do: 21 | ; ( base) 22 | ; I C@ 0 <# # # #> TYPE SPACE 23 | DX r_fetch: DX c_fetch: DX zero_literal: DX less_number_sign: DX number_sign 24 | DX number_sign: DX number_sign_greater: DX type: DX space 25 | ; LOOP 26 | DX loop_raw: DB .do-$+256 27 | .loop: 28 | ; BASE ! ; 29 | DX base: DX store: DX exit 30 | 31 | 32 | ; \ Print preview of memory, the character or dot 33 | ; ( a u --) 34 | ; : PREVIEW 35 | HEADER preview, "PREVIEW", 0 36 | preview: 37 | CALL colon_code 38 | ; OVER + SWAP ?DO 39 | DX over: DX plus: DX swap: DX question_do_raw: DB .loop-$-1 40 | .do: 41 | ; ( ) 42 | ; I C@ 43 | DX r_fetch: DX c_fetch 44 | ; ( c) 45 | ; DUP 128 33 WITHIN IF DROP [CHAR] . THEN 46 | DX dup: DX literal_raw: DW 128: DX raw_char: DB 33: DX within 47 | DX if_raw: DB .then-$-1: DX drop: DX raw_char: DB '.' 48 | .then: 49 | ; ( c|'.') 50 | ; EMIT 51 | DX emit 52 | ; LOOP ; 53 | DX loop_raw: DB .do-$+256 54 | .loop: 55 | DX exit 56 | 57 | 58 | ; \ Print hexdump and preview for specified memory 59 | ; ( a u --) 60 | ; : DUMP 61 | HEADER dump, "DUMP", 0 62 | dump: 63 | CALL colon_code 64 | ; CR 65 | DX cr 66 | ; TUCK 67 | DX tuck 68 | ; ( u a u) 69 | ; OVER + SWAP ?DO 70 | DX over: DX plus: DX swap: DX question_do_raw: DB .loop-$-1 71 | .do: 72 | ; ( u) 73 | ; I OVER 8 MIN 74 | DX r_fetch: DX over: DX raw_char: DB 8: DX min 75 | ; ( u a n) 76 | ; 2DUP HEXDUMP 77 | DX two_dup: DX hexdump 78 | ; 24 T-COL C! 79 | DX raw_char: DB 24: DX t_col: DX c_store 80 | ; PREVIEW 81 | DX preview 82 | ; 1+ 83 | DX one_plus 84 | ; 8 +LOOP 85 | DX raw_char: DB 8: DX plus_loop_raw: DB .do-$+256 86 | .loop: 87 | ; DROP CR ; 88 | DX drop: DX cr: DX exit 89 | -------------------------------------------------------------------------------- /src/zenv.asm: -------------------------------------------------------------------------------- 1 | ; vi:syntax=z80 2 | 3 | ; ZEnv - Forth for the ZX Spectrum 4 | ; Copyright 2021-2024 (C) - Christopher Leonard, MIT Licence 5 | ; https://github.com/veltas/zenv 6 | 7 | ; Master assembly/definitions file 8 | 9 | tokenised: EQU 1 10 | 11 | t_attr_init: EQU 0x38 12 | load_addr: EQU 0x8000 13 | disp_file_val: EQU 0x4000 14 | disp_size_val: EQU 0x1800 15 | attr_file_val: EQU 0x5800 16 | attr_size_val: EQU 0x300 17 | ula_val: EQU 0xFE 18 | keyq_len_val: EQU 8 19 | ; Address of PAD 20 | pad_val: EQU 0xFB00 21 | ; Address of line input buffer 22 | line_in_val: EQU 0xFC80 23 | line_in_size_val: EQU 32; 82 24 | ; Address WORD is stored in 25 | tick_word_val: EQU 0xFD80 26 | tick_word_size: EQU 0x81 27 | ; Address data stack starts at, SP must remain within one page 28 | param_stack_top: EQU 0xFE78 29 | param_stack_size: EQU 0x70 30 | ; Address return stack starts at, RP must remain within one page 31 | return_stack_top: EQU 0xFEF8 32 | return_stack_size: EQU 0x70 33 | ; Address of built-in font 34 | font: EQU 0x3D00 35 | 36 | 37 | this_header = 0 38 | 39 | MACRO HEADER ___symbol, ___text, ___immediate 40 | prev_header = this_header 41 | this_header = $ 42 | DW prev_header 43 | DB (.se - .ss) | (___immediate << 7) 44 | .ss: 45 | DM ___text 46 | .se: 47 | ENDM 48 | 49 | IF tokenised 50 | MACRO DX ___val 51 | IF EXIST ___val_tok 52 | DB (___val_tok - tokens) / 2 53 | ELSE 54 | DB (___val) >> 8, (___val) & 0xFF 55 | ENDIF 56 | ENDM 57 | ELSE 58 | MACRO DX ___val 59 | DW ___val 60 | ENDM 61 | ENDIF 62 | 63 | ORG load_addr 64 | 65 | DI 66 | 67 | ; Init interrupt handler 68 | LD A, 0x18 69 | LD (0xFFFF), A 70 | 71 | IM 2 72 | LD A, 0x3B 73 | LD I, A 74 | 75 | ; Init 0xFFF4 code to jump to our handler code 76 | LD HL, 0xFFF4 77 | ; Compile "JP interrupt" 78 | LD (HL), 0xC3 79 | INC HL 80 | LD DE, interrupt 81 | LD (HL), E 82 | INC HL 83 | LD (HL), D 84 | 85 | ; Enable interrupts 86 | EI 87 | 88 | ; Init stacks 89 | LD SP, param_stack_top 90 | LD IX, return_stack_top 91 | 92 | ; Run forth 93 | JP main 94 | 95 | 96 | ; CALL in instance code 97 | ; CALL does_code in 98 | does_code: 99 | POP AF 100 | POP DE 101 | PUSH HL 102 | EX DE, HL 103 | PUSH AF 104 | ; fall through 105 | 106 | 107 | ; CALL colon_code in code 108 | colon_code: 109 | ; Push current PC to RS 110 | DEC IXL 111 | DEC IXL 112 | PUSH IY 113 | POP BC 114 | LD (IX+0), C 115 | LD (IX+1), B 116 | ; Get new PC from stack 117 | pop_pc_next: 118 | POP IY 119 | drop: EQU pop_pc_next + 1 ; 'POP IY' is 'DB 0xFD \ POP HL', so +1 is 'drop' 120 | ; fall through 121 | 122 | 123 | ; JP next at end of code 124 | next: 125 | IF tokenised 126 | ; Load byte, advance PC 127 | LD A, (IY+0) 128 | INC IY 129 | CP 0x80 130 | JR NC, .not_token 131 | ; If token, load token address and jump 132 | ADD A, A 133 | LD E, A 134 | LD D, tokens >> 8 135 | LD A, (DE) 136 | LD C, A 137 | INC DE 138 | LD A, (DE) 139 | LD B, A 140 | PUSH BC 141 | RET 142 | .not_token: 143 | ; If not token, jump to big endian address 144 | LD D, A 145 | LD E, (IY+0) 146 | INC IY 147 | PUSH DE 148 | RET 149 | ELSE 150 | ; Load address, advance PC 151 | LD E, (IY+0) 152 | INC IY 153 | LD D, (IY+0) 154 | INC IY 155 | ; Jump to address 156 | PUSH DE 157 | RET 158 | ENDIF 159 | 160 | 161 | ; CALL this address, with DE set to code to call, uses next 162 | ; to return to calling code. 163 | asm_call: 164 | ; Push IP to ret stack 165 | LD BC, -4 166 | ADD IX, BC 167 | PUSH IY 168 | POP BC 169 | LD (IX+2), C 170 | LD (IX+3), B 171 | ; Move return pointer to ret stack 172 | POP BC 173 | LD (IX+0), C 174 | LD (IX+1), B 175 | ; Set IP to instruction below 176 | LD IY, asm_call_param 177 | ; Jump to provided DE 178 | PUSH DE 179 | RET 180 | asm_call_param: 181 | DX asm_exit 182 | asm_exit: 183 | LD E, (IX+0) 184 | LD D, (IX+1) 185 | LD C, (IX+2) 186 | LD B, (IX+3) 187 | PUSH BC 188 | POP IY 189 | LD BC, 4 190 | ADD IX, BC 191 | PUSH DE 192 | RET 193 | 194 | 195 | ; Interrupt handling body 196 | interrupt: 197 | PUSH AF 198 | PUSH BC 199 | PUSH DE 200 | PUSH HL 201 | EX AF, AF' 202 | PUSH AF 203 | EXX 204 | PUSH BC 205 | PUSH DE 206 | PUSH HL 207 | PUSH IX 208 | PUSH IY 209 | LD (.save_sp), SP 210 | LD DE, -4 211 | ADD IX, DE 212 | 213 | ; Call forth interrupt routine 214 | LD DE, (tick_int+3) 215 | CALL asm_call 216 | 217 | ; Restore context, return from interrupt 218 | LD SP, (.save_sp) 219 | POP IY 220 | POP IX 221 | POP HL 222 | POP DE 223 | POP BC 224 | POP AF 225 | EXX 226 | POP HL 227 | POP DE 228 | POP BC 229 | EX AF, AF' 230 | POP AF 231 | EI 232 | RETI 233 | 234 | .save_sp: 235 | DW 0 236 | 237 | 238 | constant_code: 239 | POP DE 240 | PUSH HL 241 | EX DE, HL 242 | LD E, (HL) 243 | INC HL 244 | LD D, (HL) 245 | EX DE, HL 246 | JP next 247 | 248 | 249 | dictionary_start: 250 | 251 | 252 | INCLUDE "stack.asm" 253 | INCLUDE "memory.asm" 254 | INCLUDE "maths.asm" 255 | INCLUDE "binary.asm" 256 | INCLUDE "control.asm" 257 | INCLUDE "tools.asm" 258 | INCLUDE "dict.asm" 259 | 260 | 261 | HEADER false, "FALSE", 0 262 | false: 263 | JP zero_literal 264 | 265 | 266 | HEADER literal_raw, "(LITERAL)", 0 267 | literal_raw: 268 | PUSH HL 269 | LD L, (IY+0) 270 | INC IY 271 | LD H, (IY+0) 272 | INC IY 273 | JP next 274 | 275 | 276 | HEADER bye, "BYE", 0 277 | bye: 278 | RST 0x00 279 | 280 | 281 | HEADER execute, "EXECUTE", 0 282 | execute: 283 | POP DE 284 | EX DE, HL 285 | PUSH DE 286 | RET 287 | 288 | 289 | HEADER one_plus, "1+", 0 290 | one_plus: 291 | INC HL 292 | JP next 293 | 294 | 295 | HEADER char_plus, "CHAR+", 0 296 | char_plus: 297 | JR one_plus 298 | 299 | 300 | HEADER one_minus, "1-", 0 301 | one_minus: 302 | DEC HL 303 | JP next 304 | 305 | 306 | HEADER two_store, "2!", 0 307 | two_store: 308 | POP BC 309 | POP DE 310 | LD (HL), C 311 | INC HL 312 | LD (HL), B 313 | INC HL 314 | LD (HL), E 315 | INC HL 316 | LD (HL), D 317 | JP drop 318 | 319 | 320 | HEADER two_star, "2*", 0 321 | two_star: 322 | SLA L 323 | RL H 324 | JP next 325 | 326 | 327 | HEADER cells, "CELLS", 0 328 | cells: 329 | JR two_star 330 | 331 | 332 | HEADER two_slash, "2/", 0 333 | two_slash: 334 | SRA H 335 | RR L 336 | JP next 337 | 338 | 339 | HEADER two_fetch, "2@", 0 340 | two_fetch: 341 | LD E, (HL) 342 | INC HL 343 | LD D, (HL) 344 | INC HL 345 | LD C, (HL) 346 | INC HL 347 | LD B, (HL) 348 | PUSH BC 349 | EX DE, HL 350 | JP next 351 | 352 | 353 | HEADER two_over, "2OVER", 0 354 | two_over: 355 | PUSH HL 356 | LD HL, 4 357 | ADD HL, SP 358 | LD E, (HL) 359 | INC L 360 | LD D, (HL) 361 | INC L 362 | LD C, (HL) 363 | INC L 364 | LD B, (HL) 365 | PUSH BC 366 | EX DE, HL 367 | JP next 368 | 369 | 370 | HEADER question_dup, "?DUP", 0 371 | question_dup: 372 | LD A, L 373 | OR H 374 | JR Z, .no_dup 375 | PUSH HL 376 | .no_dup: 377 | JP next 378 | 379 | 380 | HEADER sp_store, "SP!", 0 381 | sp_store: 382 | LD SP, HL 383 | JP next 384 | 385 | 386 | HEADER rp_store, "RP!", 0 387 | rp_store: 388 | PUSH HL 389 | POP IX 390 | JP drop 391 | 392 | 393 | HEADER _abs, "ABS", 0 394 | _abs: 395 | LD A, H 396 | AND 0x80 397 | JP Z, next 398 | EX DE, HL 399 | LD HL, 0 400 | OR A 401 | SBC HL, DE 402 | .next: 403 | JP next 404 | 405 | 406 | HEADER align, "ALIGN", 1 407 | align: 408 | JR _abs.next 409 | 410 | 411 | HEADER aligned, "ALIGNED", 1 412 | aligned: 413 | JR _abs.next 414 | 415 | 416 | HEADER chars, "CHARS", 1 417 | chars: 418 | JR _abs.next 419 | 420 | 421 | HEADER cell_plus, "CELL+", 0 422 | cell_plus: 423 | INC HL 424 | INC HL 425 | JP next 426 | 427 | 428 | HEADER cmove, "CMOVE", 0 429 | cmove: 430 | LD C, L 431 | LD B, H 432 | POP DE 433 | POP HL 434 | LD A, C 435 | OR B 436 | JR Z, .skip 437 | LDIR 438 | .skip: 439 | JP drop 440 | 441 | 442 | HEADER cmove_up, "CMOVE>", 0 443 | cmove_up: 444 | LD C, L 445 | LD B, H 446 | POP HL 447 | POP DE 448 | LD A, C 449 | OR B 450 | JR Z, .skip 451 | ADD HL, BC 452 | DEC HL 453 | EX DE, HL 454 | ADD HL, BC 455 | DEC HL 456 | LDDR 457 | .skip: 458 | JP drop 459 | 460 | 461 | HEADER loop_raw, "(LOOP)", 0 462 | loop_raw: 463 | PUSH HL 464 | ; DE = iterator 465 | LD E, (IX+0) 466 | LD D, (IX+1) 467 | ; HL = limit 468 | LD L, (IX+2) 469 | LD H, (IX+3) 470 | INC DE 471 | OR A 472 | SBC HL, DE 473 | JR NZ, .loop 474 | LD BC, 6 475 | ADD IX, BC 476 | INC IY 477 | JP drop 478 | .loop: 479 | LD (IX+0), E 480 | LD (IX+1), D 481 | LD E, (IY+0) 482 | LD D, 0xFF 483 | ADD IY, DE 484 | JP drop 485 | 486 | 487 | HEADER plus_loop_raw, "(+LOOP)", 0 488 | plus_loop_raw: 489 | ; DE = iterator 490 | LD E, (IX+0) 491 | LD D, (IX+1) 492 | ; BC = limit 493 | LD C, (IX+2) 494 | LD B, (IX+3) 495 | ; HL = increment 496 | EX DE, HL 497 | ; HL = iterator 498 | ; DE = increment 499 | ; HL = HL-BC 500 | OR A 501 | SBC HL, BC 502 | LD A, D 503 | AND 0x80 504 | ADD HL, DE 505 | JR Z, .non_negative 506 | JR C, .next_loop 507 | JR .end_loop 508 | .non_negative: 509 | ; End loop when iterator-limit + increment carries 510 | JR C, .end_loop 511 | .next_loop: 512 | ; HL = new iterator 513 | ADD HL, BC 514 | LD (IX+0), L 515 | LD (IX+1), H 516 | LD E, (IY+0) 517 | LD D, 0xFF 518 | ADD IY, DE 519 | .exit: 520 | JP drop 521 | .end_loop: 522 | LD BC, 6 523 | ADD IX, BC 524 | INC IY 525 | JR .exit 526 | 527 | 528 | HEADER over_two, "OVER2", 0 529 | over_two: 530 | POP AF 531 | POP DE 532 | PUSH DE 533 | PUSH AF 534 | PUSH HL 535 | EX DE, HL 536 | JP next 537 | 538 | 539 | HEADER fill, "FILL", 0 540 | fill: 541 | EX DE, HL 542 | POP BC 543 | POP HL 544 | LD A, B 545 | OR C 546 | JR Z, .exit 547 | LD (HL), E 548 | DEC BC 549 | LD A, B 550 | OR C 551 | JP Z, .exit 552 | LD E, L 553 | LD D, H 554 | INC DE 555 | LDIR 556 | .exit: 557 | JP drop 558 | 559 | 560 | HEADER tick_s, "'S", 0 561 | tick_s: 562 | PUSH HL 563 | LD HL, 0 564 | ADD HL, SP 565 | JP next 566 | 567 | 568 | HEADER tick_r, "'R", 0 569 | tick_r: 570 | PUSH HL 571 | PUSH IX 572 | JP drop 573 | 574 | 575 | ; : DU< ( $u1 $u2 - $u1<$u2?) 576 | HEADER du_less_than, "DU<", 0 577 | du_less_than: 578 | LD C, L 579 | LD B, H 580 | POP DE 581 | POP HL 582 | OR A 583 | SBC HL, BC 584 | POP HL 585 | JR Z, common_less_than 586 | JR common_du_less_than 587 | 588 | 589 | HEADER u_less_than, "U<", 0 590 | u_less_than: 591 | EX DE, HL 592 | POP HL 593 | common_less_than: 594 | OR A 595 | SBC HL, DE 596 | common_du_less_than: 597 | LD HL, 0 598 | JR C, .lt 599 | JP next 600 | .lt: 601 | DEC HL 602 | JP next 603 | 604 | 605 | HEADER less_than, "<", 0 606 | less_than: 607 | POP DE 608 | LD BC, 0x8000 609 | ADD HL, BC 610 | EX DE, HL 611 | ADD HL, BC 612 | JR common_less_than 613 | 614 | 615 | HEADER else_skip, "(ELSE)", 0 616 | else_skip: 617 | INC IY 618 | LD E, (IY-1) 619 | LD D, 0 620 | ADD IY, DE 621 | JP next 622 | 623 | 624 | HEADER again_raw, "(AGAIN)", 0 625 | again_raw: 626 | LD E, (IY+0) 627 | LD D, 0xFF 628 | ADD IY, DE 629 | JP next 630 | 631 | 632 | HEADER c_plus_store, "C+!", 0 633 | c_plus_store: 634 | POP DE 635 | LD A, (HL) 636 | ADD A, E 637 | LD (HL), A 638 | JP drop 639 | 640 | 641 | HEADER raw_char, "(CHAR)", 0 642 | raw_char: 643 | PUSH HL 644 | LD L, (IY+0) 645 | LD H, 0 646 | INC IY 647 | JP next 648 | 649 | 650 | HEADER if_raw, "(IF)", 0 651 | if_raw: 652 | INC IY 653 | LD A, L 654 | OR H 655 | JR NZ, .end 656 | EX DE, HL 657 | LD E, (IY-1) 658 | ADD IY, DE 659 | .end: 660 | JP drop 661 | 662 | 663 | HEADER of_raw, "(OF)", 0 664 | of_raw: 665 | INC IY 666 | POP DE 667 | OR A 668 | SBC HL, DE 669 | JR NZ, .skip 670 | JP drop 671 | .skip: 672 | LD C, (IY-1) 673 | LD B, 0 674 | ADD IY, BC 675 | EX DE, HL 676 | JP next 677 | 678 | 679 | HEADER ms, "MS", 0 680 | ms: 681 | EX DE, HL 682 | .ms_loop: 683 | LD A, E 684 | OR D 685 | JP Z, .end 686 | ; waste time 687 | LD BC, (0x8000) 688 | ; waste time 689 | LD B, (HL) 690 | LD BC, 132 691 | .loop: 692 | DEC BC 693 | LD A, C 694 | OR B 695 | JR NZ, .loop 696 | DEC DE 697 | JR .ms_loop 698 | .end: 699 | JP drop 700 | 701 | 702 | ; CODE P@ ( addr -- cx ) \ Read byte from port 703 | HEADER p_fetch, "P@", 0 704 | p_fetch: 705 | LD C, L 706 | LD B, H 707 | IN L, (C) 708 | LD H, 0 709 | p_fetch_next: 710 | JP next 711 | 712 | 713 | ; CODE P! ( cx addr -- ) \ Write byte to port 714 | HEADER p_store, "P!", 0 715 | p_store: 716 | LD C, L 717 | LD B, H 718 | POP DE 719 | OUT (C), E 720 | POP HL 721 | JR p_fetch_next 722 | 723 | 724 | HEADER halt_, "HALT", 0 725 | halt_: 726 | HALT 727 | JR p_fetch_next 728 | 729 | 730 | HEADER tuck2, "TUCK2", 0 731 | tuck2: 732 | POP DE 733 | POP BC 734 | PUSH HL 735 | PUSH BC 736 | PUSH DE 737 | JP next 738 | 739 | 740 | HEADER d_plus, "D+", 0 741 | d_plus: 742 | PUSH HL 743 | POP AF 744 | POP BC 745 | POP DE 746 | POP HL 747 | PUSH AF 748 | ADD HL, BC 749 | POP BC 750 | PUSH HL 751 | EX DE, HL 752 | ADC HL, BC 753 | JP next 754 | 755 | 756 | HEADER _di, "DI", 0 757 | _di: 758 | DI 759 | JP next 760 | 761 | 762 | HEADER _ei, "EI", 0 763 | _ei: 764 | EI 765 | JP next 766 | 767 | 768 | HEADER until_raw, "(UNTIL)", 0 769 | until_raw: 770 | LD A, L 771 | OR H 772 | POP HL 773 | JR NZ, until_raw_done 774 | until_raw_loop: 775 | LD C, (IY+0) 776 | LD B, 0xFF 777 | ADD IY, BC 778 | until_raw_next: 779 | JP next 780 | until_raw_done: 781 | INC IY 782 | JR until_raw_next 783 | 784 | 785 | HEADER equals, "=", 0 786 | equals: 787 | POP BC 788 | XOR A 789 | SBC HL, BC 790 | JR Z, .equal 791 | LD L, A 792 | LD H, A 793 | JP next 794 | .equal: 795 | DEC HL 796 | JP next 797 | 798 | 799 | HEADER lshift, "LSHIFT", 0 800 | lshift: 801 | EX DE, HL 802 | POP HL 803 | XOR A 804 | OR E 805 | JR Z, lshift_finish 806 | LD B, E 807 | .loop: 808 | ADD HL, HL 809 | DJNZ .loop 810 | lshift_finish: 811 | JP next 812 | 813 | 814 | HEADER rshift, "RSHIFT", 0 815 | rshift: 816 | EX DE, HL 817 | POP HL 818 | XOR A 819 | OR E 820 | JR Z, lshift_finish 821 | LD B, E 822 | .loop: 823 | SRL H 824 | RR L 825 | DJNZ .loop 826 | JR lshift_finish 827 | 828 | 829 | HEADER d_two_star, "D2*", 0 830 | d_two_star: 831 | POP DE 832 | SLA E 833 | RL D 834 | RL L 835 | RL H 836 | PUSH DE 837 | JP next 838 | 839 | 840 | HEADER du_two_slash, "DU2/", 0 841 | du_two_slash: 842 | POP DE 843 | SRL H 844 | RR L 845 | RR D 846 | RR E 847 | PUSH DE 848 | JP next 849 | 850 | 851 | ; CODE D- 852 | HEADER d_minus, "D-", 0 853 | d_minus: 854 | PUSH HL 855 | POP AF 856 | POP BC 857 | POP DE 858 | POP HL 859 | PUSH AF 860 | OR A 861 | SBC HL, BC 862 | EX DE, HL 863 | POP BC 864 | SBC HL, BC 865 | PUSH DE 866 | JP next 867 | 868 | 869 | ; CODE DUB/MOD ( ud byte -- ud2 rem-byte ) \ Divide ud by unsigned byte 870 | HEADER dub_slash_mod, "DUB/MOD", 0 871 | dub_slash_mod: 872 | LD C, L 873 | POP DE 874 | POP HL 875 | LD B, 32 876 | XOR A 877 | .loop: 878 | ADD HL, HL 879 | RL E 880 | RL D 881 | RLA 882 | CP C 883 | JR C, .div_larger 884 | INC L 885 | SUB C 886 | .div_larger: 887 | DJNZ .loop 888 | PUSH HL 889 | PUSH DE 890 | LD L, A 891 | LD H, B 892 | JP next 893 | 894 | 895 | ; CODE ITONE ( u1 u2 -- ) \ half-oscillations period 896 | HEADER itone, "ITONE", 0 897 | itone: 898 | LD A, (t_attr+3) 899 | RRCA 900 | RRCA 901 | RRCA 902 | AND 7 903 | EX DE, HL 904 | LD HL, 0 905 | SBC HL, DE 906 | ; DE = period 907 | EX DE, HL 908 | POP BC 909 | LD HL, 0 910 | OR A 911 | ; HL = half-oscillations 912 | SBC HL, BC 913 | ; B = OUT value 914 | LD B, A 915 | ; Quit if HL = 0 916 | LD A, L 917 | OR A, H 918 | JP NZ, .skip 919 | JP drop 920 | .skip: 921 | ; Push period 922 | PUSH DE 923 | LD A, B 924 | .loop1_with_delay: 925 | ADD A, 0 926 | NOP 927 | .loop1: 928 | OUT (ula_val), A 929 | XOR 1<<4 930 | .loop2_with_delay: 931 | ADD A, 0 932 | NOP 933 | .loop2: 934 | INC E 935 | JR NZ, .loop2_with_delay 936 | INC D 937 | JR NZ, .loop2 938 | 939 | POP DE 940 | PUSH DE 941 | INC L 942 | JR NZ, .loop1_with_delay 943 | INC H 944 | JR NZ, .loop1 945 | 946 | POP HL 947 | JP drop 948 | 949 | 950 | ; \ -1 if s1s2, 0 if s1=s2 951 | ; CODE COMPARE ( a1 u1 a2 u2 -- n ) 952 | HEADER compare, "COMPARE", 0 953 | compare: 954 | LD C, L 955 | LD B, H 956 | POP DE 957 | POP HL 958 | PUSH HL 959 | OR A 960 | SBC HL, BC 961 | JR C, .u2_larger 962 | JR Z, .u1_u2_equal 963 | POP HL 964 | LD C, L 965 | LD B, H 966 | LD A, 1 967 | JR .cont 968 | .u1_u2_equal: 969 | POP HL 970 | LD A, 0 971 | JR .cont 972 | .u2_larger: 973 | POP HL 974 | LD A, -1 975 | .cont: 976 | POP HL 977 | PUSH AF 978 | ; HL = a1, DE = a2, BC = min(u1,u2) 979 | LD A, C 980 | OR B 981 | JR Z, .skip_loop 982 | .loop: 983 | LD A, (DE) 984 | INC DE 985 | CPI 986 | JR C, .s1_larger 987 | JR NZ, .s2_larger 988 | JP PE, .loop 989 | .skip_loop: 990 | POP AF 991 | LD L, A 992 | LD H, 0 993 | JP next 994 | 995 | .s1_larger: 996 | LD HL, 1 997 | JR .cont2 998 | 999 | .s2_larger: 1000 | LD HL, -1 1001 | .cont2: 1002 | POP DE 1003 | JP next 1004 | 1005 | 1006 | ; ( n1 n2 -- d) 1007 | ; CODE UM* 1008 | HEADER um_star, "UM*", 0 1009 | um_star: 1010 | EX DE, HL 1011 | POP BC 1012 | LD HL, 0 1013 | LD A, 16 1014 | .loop: 1015 | ADD HL, HL 1016 | RL E 1017 | RL D 1018 | JR NC, .skip 1019 | ADD HL, BC 1020 | JR NC, .skip 1021 | INC DE 1022 | .skip: 1023 | DEC A 1024 | JR NZ, .loop 1025 | EX DE, HL 1026 | PUSH DE 1027 | JP next 1028 | 1029 | 1030 | ; ( d n1 n2 -- d) 1031 | ; CODE UM*/ 1032 | HEADER um_star_slash, "UM*/", 0 1033 | um_star_slash: 1034 | POP BC 1035 | POP DE 1036 | POP AF 1037 | ; Save IY and n2 1038 | PUSH IY 1039 | PUSH HL 1040 | PUSH AF 1041 | POP HL 1042 | 1043 | ; DEHL = d, BC = n1 1044 | LD IY, 0 1045 | LD A, 32 1046 | .loop: 1047 | ADD IY, IY 1048 | RL L 1049 | RL H 1050 | RL E 1051 | RL D 1052 | JR NC, .skip 1053 | ADD IY, BC 1054 | JR NC, .skip 1055 | INC L 1056 | JR NZ, .skip 1057 | INC H 1058 | JR NZ, .skip 1059 | INC E 1060 | JR NZ, .skip 1061 | INC D 1062 | .skip: 1063 | DEC A 1064 | JR NZ, .loop 1065 | ; DEHLIY = result 1066 | 1067 | EXX 1068 | POP BC 1069 | LD HL, 0 1070 | EXX 1071 | ; BC' = n2 1072 | ; HL' = rem 1073 | 1074 | LD B, 48 1075 | .loop2: 1076 | ADD IY, IY 1077 | ADC HL, HL 1078 | RL E 1079 | RL D 1080 | EXX 1081 | ADC HL, HL 1082 | OR A 1083 | SBC HL, BC 1084 | JR C, .skip2 1085 | EXX 1086 | INC IY 1087 | JR .skip3 1088 | .skip2: 1089 | ADD HL, BC 1090 | EXX 1091 | .skip3: 1092 | DJNZ .loop2 1093 | 1094 | ; Restore IY, result MSB in HL, result LSB on stack 1095 | .end: 1096 | EX (SP), IY 1097 | JP next 1098 | 1099 | 1100 | ; ( ud u -- urem uquo) 1101 | ; CODE UM/MOD 1102 | HEADER um_slash_mod, "UM/MOD", 0 1103 | um_slash_mod: 1104 | EX DE, HL 1105 | POP BC 1106 | EX (SP), IY 1107 | ; BCIY = numerator 1108 | ; HL = remainder 1109 | ; DE = denominator 1110 | LD HL, 0 1111 | LD A, 32 1112 | .loop: 1113 | ADD IY, IY 1114 | RL C 1115 | RL B 1116 | ADC HL, HL 1117 | JR NC, .skip3 1118 | OR A 1119 | SBC HL, DE 1120 | INC IY 1121 | JR .skip2 1122 | .skip3: 1123 | SBC HL, DE 1124 | JR C, .skip 1125 | INC IY 1126 | JP .skip2 1127 | .skip: 1128 | ADD HL, DE 1129 | .skip2: 1130 | DEC A 1131 | JP NZ, .loop 1132 | ; IY = quotient 1133 | ; HL = remainder 1134 | EX (SP), IY 1135 | EX DE, HL 1136 | POP HL 1137 | PUSH DE 1138 | JP next 1139 | 1140 | 1141 | ; ( num den -- rem quo) 1142 | ; CODE U/MOD 1143 | HEADER u_slash_mod, "U/MOD", 0 1144 | u_slash_mod: 1145 | EX DE, HL 1146 | POP BC 1147 | LD A, 16 1148 | LD HL, 0 1149 | JP .loop_entry 1150 | .loop_and_add: 1151 | ADD HL, DE 1152 | .loop: 1153 | DEC A 1154 | JP Z, .end 1155 | .loop_entry: 1156 | SLA C 1157 | RL B 1158 | ADC HL, HL 1159 | SBC HL, DE 1160 | JR C, .loop_and_add 1161 | INC C 1162 | JP .loop 1163 | .end: 1164 | PUSH HL 1165 | LD L, C 1166 | LD H, B 1167 | JP next 1168 | 1169 | 1170 | ; : > SWAP < ; 1171 | HEADER greater_than, ">", 0 1172 | greater_than: 1173 | CALL colon_code 1174 | DX swap 1175 | DX less_than 1176 | DX exit 1177 | 1178 | 1179 | ; -1 CONSTANT TRUE 1180 | HEADER true, "TRUE", 0 1181 | true: 1182 | CALL constant_code 1183 | DW -1 1184 | 1185 | 1186 | ; 1 CELLS CONSTANT CELL 1187 | HEADER cell, "CELL", 0 1188 | cell: 1189 | CALL constant_code 1190 | DW 2 1191 | 1192 | 1193 | ; Current data space pointer 1194 | HEADER h_, "H", 0 1195 | h_: 1196 | CALL create_code 1197 | DW h_init 1198 | 1199 | 1200 | ; : HERE ( -- addr ) \ Get current address of dictionary end 1201 | HEADER here, "HERE", 0 1202 | here: 1203 | CALL colon_code 1204 | ; H @ ; 1205 | DX h_ 1206 | DX fetch 1207 | DX exit 1208 | 1209 | 1210 | ; Points to most recently defined symbol 1211 | HEADER sym_last, "SYM-LAST", 0 1212 | sym_last: 1213 | CALL create_code 1214 | DW sym_last_init 1215 | 1216 | 1217 | ; non-zero while compiling 1218 | HEADER state, "STATE", 0 1219 | state: 1220 | CALL create_code 1221 | DW 0 1222 | 1223 | 1224 | HEADER frames, "FRAMES", 0 1225 | frames: 1226 | CALL create_code 1227 | DW 0 1228 | DW 0 1229 | 1230 | 1231 | HEADER t_attr, "T-ATTR", 0 1232 | t_attr: 1233 | CALL create_code 1234 | DB t_attr_init 1235 | 1236 | 1237 | HEADER t_col, "T-COL", 0 1238 | t_col: 1239 | CALL create_code 1240 | DB 0 1241 | 1242 | 1243 | HEADER t_row, "T-ROW", 0 1244 | t_row: 1245 | CALL create_code 1246 | DB 0 1247 | 1248 | 1249 | HEADER disp_file, "DISP-FILE", 0 1250 | disp_file: 1251 | CALL constant_code 1252 | DW disp_file_val 1253 | 1254 | 1255 | HEADER disp_size, "DISP-SIZE", 0 1256 | disp_size: 1257 | CALL constant_code 1258 | DW disp_size_val 1259 | 1260 | 1261 | HEADER attr_file, "ATTR-FILE", 0 1262 | attr_file: 1263 | CALL constant_code 1264 | DW attr_file_val 1265 | 1266 | 1267 | HEADER attr_size, "ATTR-SIZE", 0 1268 | attr_size: 1269 | CALL constant_code 1270 | DW attr_size_val 1271 | 1272 | 1273 | HEADER tick_word, "'WORD", 0 1274 | tick_word: 1275 | CALL constant_code 1276 | DW tick_word_val 1277 | 1278 | 1279 | HEADER pad, "PAD", 0 1280 | pad: 1281 | CALL constant_code 1282 | DW pad_val 1283 | 1284 | 1285 | ; Current input buffer 1286 | HEADER tick_in, "'IN", 0 1287 | tick_in: 1288 | CALL create_code 1289 | DW 0 1290 | 1291 | 1292 | ; Current input buffer size 1293 | HEADER in_size, "IN#", 0 1294 | in_size: 1295 | CALL create_code 1296 | DW 0 1297 | 1298 | 1299 | ; \ Get address and length of current input buff 1300 | ; ( -- addr u ) 1301 | ; : SOURCE 1302 | HEADER source, "SOURCE", 0 1303 | source: 1304 | CALL colon_code 1305 | ; 'IN @ IN# @ ; 1306 | DX tick_in 1307 | DX fetch 1308 | DX in_size 1309 | DX fetch 1310 | DX exit 1311 | 1312 | 1313 | HEADER line_in, "-IN", 0 1314 | line_in: 1315 | CALL constant_code 1316 | DW line_in_val 1317 | 1318 | 1319 | HEADER line_in_size, "-IN#", 0 1320 | line_in_size: 1321 | CALL constant_code 1322 | DW line_in_size_val 1323 | 1324 | 1325 | HEADER tick_int, "'INT", 0 1326 | tick_int: 1327 | CALL create_code 1328 | DW int 1329 | 1330 | 1331 | ; Default interrupt handler 1332 | ; : INT 1333 | HEADER int, "INT", 0 1334 | int: 1335 | CALL colon_code 1336 | ; 1. FRAMES D+! \ increment FRAMES 1337 | DX two_literal_raw 1338 | DW 0 1339 | DW 1 1340 | DX frames 1341 | DX d_plus_store 1342 | ; \ update keyboard state 1343 | ; KSCAN ; 1344 | DX kscan 1345 | DX exit 1346 | 1347 | 1348 | ; \ Get name string from symbol header address 1349 | ; : >SYM ( sym-addr -- c-addr n+ ) 1350 | HEADER to_sym, ">SYM", 0 1351 | to_sym: 1352 | CALL colon_code 1353 | ; CELL+ DUP C@ $7F AND SWAP CHAR+ SWAP ; 1354 | DX cell_plus 1355 | DX dup 1356 | DX c_fetch 1357 | DX raw_char 1358 | DB 0x7F 1359 | DX and 1360 | DX swap 1361 | DX one_plus 1362 | DX swap 1363 | DX exit 1364 | 1365 | 1366 | ; ( str len -- ) 1367 | ; : TYPE 1368 | HEADER type, "TYPE", 0 1369 | type: 1370 | CALL colon_code 1371 | ; OVER + 1372 | DX over 1373 | DX plus 1374 | ; ( str end ) 1375 | ; SWAP ?DO I C@ EMIT LOOP ; 1376 | DX swap 1377 | DX question_do_raw 1378 | DB .loop-$-1 1379 | .do: 1380 | DX r_fetch 1381 | DX c_fetch 1382 | DX emit 1383 | DX loop_raw 1384 | DB .do-$+256 1385 | .loop: 1386 | DX exit 1387 | 1388 | 1389 | ; \ Type all word names in dictionary to the output device 1390 | ; : WORDS 1391 | HEADER words, "WORDS", 0 1392 | words: 1393 | CALL colon_code 1394 | ; SYM-LAST @ 1395 | DX sym_last 1396 | DX fetch 1397 | ; BEGIN 1398 | .begin: 1399 | ; \ Print name 1400 | ; DUP >SYM TYPE SPACE 1401 | DX dup 1402 | DX to_sym 1403 | DX type 1404 | DX space 1405 | ; \ Goto next symbol 1406 | ; @ 1407 | DX fetch 1408 | ; ?DUP 0= UNTIL 1409 | DX question_dup 1410 | DX zero_equals 1411 | DX until_raw 1412 | DB .begin-$+256 1413 | ; CR ; 1414 | DX cr 1415 | DX exit 1416 | 1417 | 1418 | ; : KEY ( -- char ) \ Wait for next input char, using EKEY 1419 | HEADER key, "KEY", 0 1420 | key: 1421 | CALL colon_code 1422 | ; \ Wait for a character key event 1423 | ; BEGIN 1424 | .begin: 1425 | ; ( ) 1426 | ; EKEY EKEY>CHAR 0= WHILE DROP 1427 | DX ekey 1428 | DX ekey_to_char 1429 | DX zero_equals 1430 | DX if_raw 1431 | DB .repeat-$-1 1432 | DX drop 1433 | ; REPEAT 1434 | DX again_raw 1435 | DB .begin-$+256 1436 | .repeat: 1437 | ; CLICK ; 1438 | DX click 1439 | DX exit 1440 | 1441 | 1442 | ; : MAIN 1443 | HEADER main, "MAIN", 0 1444 | main: 1445 | CALL colon_code 1446 | ; \ Clear screen 1447 | ; PAGE 1448 | DX page 1449 | ; \ Greeting 1450 | ; ." HI" 1451 | DX dot_quote_raw 1452 | DB .s1e-.s1 1453 | .s1: 1454 | DM "HI" 1455 | .s1e: 1456 | ; \ Run interpreter 1457 | ; ABORT ; -? ALLOT 1458 | DX abort 1459 | 1460 | 1461 | ; : WITHIN ( n start end -- flags ) \ Is n within [start, end), or (end, 1462 | ; \ start] if end is less. 1463 | HEADER within, "WITHIN", 0 1464 | within: 1465 | CALL colon_code 1466 | ; ( n start end ) 1467 | ; OVER - 1468 | DX over 1469 | DX minus 1470 | ; ( n start range-length ) 1471 | ; -ROT - SWAP 1472 | DX minus_rot 1473 | DX minus 1474 | DX swap 1475 | ; ( offset range-length ) 1476 | ; U< ; 1477 | DX u_less_than 1478 | DX exit 1479 | 1480 | 1481 | ; : , ( x -- ) \ Append cell to end of dictionary 1482 | HEADER comma, ",", 0 1483 | comma: 1484 | CALL colon_code 1485 | ; HERE CELL ALLOT ! ; 1486 | DX here 1487 | DX cell 1488 | DX allot 1489 | DX store 1490 | DX exit 1491 | 1492 | 1493 | ; \ Compile colon code to put x on the stack 1494 | ; : LITERAL ( x -- ) 1495 | HEADER literal, "LITERAL", 1 1496 | literal: 1497 | CALL colon_code 1498 | ; DUP 0 256 WITHIN IF 1499 | DX dup 1500 | DX zero_literal 1501 | DX literal_raw 1502 | DW 256 1503 | DX within 1504 | DX if_raw 1505 | DB .else-$-1 1506 | ; POSTPONE (CHAR) C, 1507 | DX postpone_raw 1508 | DW raw_char 1509 | DX c_comma 1510 | ; ELSE 1511 | DX else_skip 1512 | DB .then-$-1 1513 | .else: 1514 | ; POSTPONE (LITERAL) , 1515 | DX postpone_raw 1516 | DW literal_raw 1517 | DX comma 1518 | ; THEN ; 1519 | .then: 1520 | DX exit 1521 | 1522 | 1523 | ; \ Compile colon code to put dx on the stack 1524 | ; ( dx --) 1525 | ; : 2LITERAL 1526 | HEADER two_literal, "2LITERAL", 1 1527 | two_literal: 1528 | CALL colon_code 1529 | ; 2DUP D0= IF 1530 | DX two_dup 1531 | DX d_zero_equals 1532 | DX if_raw 1533 | DB .else-$-1 1534 | ; 2DROP POSTPONE 0 POSTPONE 0 1535 | DX two_drop 1536 | DX postpone_raw 1537 | DW zero_literal 1538 | DX postpone_raw 1539 | DW zero_literal 1540 | ; ELSE 1541 | DX else_skip 1542 | DB .then-$-1 1543 | .else: 1544 | ; POSTPONE (2LITERAL) 1545 | DX postpone_raw 1546 | DW two_literal_raw 1547 | ; , , 1548 | DX comma 1549 | DX comma 1550 | ; THEN ; 1551 | .then: 1552 | DX exit 1553 | 1554 | 1555 | ; : SCROLL 1556 | HEADER scroll, "SCROLL", 0 1557 | scroll: 1558 | CALL colon_code 1559 | ; T-ROW C@ 8 - 0 MAX T-ROW C! 1560 | DX t_row 1561 | DX c_fetch 1562 | DX raw_char 1563 | DB 8 1564 | DX minus 1565 | DX zero_literal 1566 | DX max 1567 | DX t_row 1568 | DX c_store 1569 | ; [ DISP-FILE 2048 + ] LITERAL DISP-FILE 4096 CMOVE 1570 | DX literal_raw 1571 | DW disp_file_val + 2048 1572 | DX disp_file 1573 | DX literal_raw 1574 | DW 4096 1575 | DX cmove 1576 | ; [ ATTR-FILE 256 + ] LITERAL ATTR-FILE 512 CMOVE 1577 | DX literal_raw 1578 | DW attr_file_val + 256 1579 | DX attr_file 1580 | DX literal_raw 1581 | DW 512 1582 | DX cmove 1583 | ; [ DISP-FILE 4096 + ] LITERAL 2048 ERASE 1584 | DX literal_raw 1585 | DW disp_file_val + 4096 1586 | DX literal_raw 1587 | DW 2048 1588 | DX erase 1589 | ; [ ATTR-FILE 512 + ] LITERAL 256 T-ATTR C@ FILL 1590 | DX literal_raw 1591 | DW attr_file_val + 512 1592 | DX literal_raw 1593 | DW 256 1594 | DX t_attr 1595 | DX c_fetch 1596 | DX fill 1597 | ; ; 1598 | DX exit 1599 | 1600 | ; : CR 1601 | HEADER cr, "CR", 0 1602 | cr: 1603 | CALL colon_code 1604 | ; T-ROW C@ 22 > IF SCROLL THEN 1 T-ROW C+! 1605 | DX t_row 1606 | DX c_fetch 1607 | DX raw_char 1608 | DB 22 1609 | DX greater_than 1610 | DX if_raw 1611 | DB .cr__if_skip-$-1 1612 | DX scroll 1613 | .cr__if_skip: 1614 | DX one_literal 1615 | DX t_row 1616 | DX c_plus_store 1617 | ; 0 T-COL C! 1618 | DX zero_literal 1619 | DX t_col 1620 | DX c_store 1621 | ; ; 1622 | DX exit 1623 | 1624 | ; : BS ( -- ) \ Write a backspace to terminal 1625 | HEADER bs, "BS", 0 1626 | bs: 1627 | CALL colon_code 1628 | ; T-COL C@ ?DUP IF 1629 | DX t_col 1630 | DX c_fetch 1631 | DX question_dup 1632 | DX if_raw 1633 | DB .then-$-1 1634 | ; ( col ) 1635 | ; 1- DUP T-COL C! SPACE T-COL C! 1636 | DX one_minus 1637 | DX dup 1638 | DX t_col 1639 | DX c_store 1640 | DX space 1641 | DX t_col 1642 | DX c_store 1643 | ; THEN ; 1644 | .then: 1645 | DX exit 1646 | 1647 | HEADER emit, "EMIT", 0 1648 | emit: 1649 | LD C, L 1650 | LD A, C 1651 | SUB 0x20 1652 | CP 0x7F - 0x20 1653 | JR NC, .non_print 1654 | CP 0x60 - 0x20 1655 | JR Z, .backtick 1656 | ADD A, A 1657 | LD L, A 1658 | LD H, 0 1659 | ADD HL, HL 1660 | ADD HL, HL 1661 | LD BC, font 1662 | ADD HL, BC 1663 | ; DE = glyph address 1664 | EX DE, HL 1665 | .print_glyph: 1666 | LD A, (t_col+3) 1667 | CP 32 1668 | JR NC, .next_line 1669 | LD C, A 1670 | LD B, 0 1671 | .next_line_done: 1672 | LD A, (t_row+3) 1673 | LD H, A 1674 | AND 0x7 1675 | RRCA 1676 | RRCA 1677 | RRCA 1678 | LD L, A 1679 | LD A, H 1680 | AND 0x18 1681 | OR 0x40 1682 | LD H, A 1683 | ADD HL, BC 1684 | LD B, 8 1685 | .draw_loop: 1686 | LD A, (DE) 1687 | LD (HL), A 1688 | INC DE 1689 | INC H 1690 | DJNZ .draw_loop 1691 | LD HL, t_col+3 1692 | INC (HL) 1693 | JP drop 1694 | 1695 | .next_line: 1696 | PUSH DE 1697 | LD DE, cr 1698 | CALL asm_call 1699 | POP DE 1700 | LD BC, 0 1701 | JR .next_line_done 1702 | 1703 | .non_print: 1704 | CP 0x7F - 0x20 1705 | JR Z, .gbp 1706 | 1707 | CP 0x0A - 0x20 1708 | LD DE, cr 1709 | CALL Z, asm_call 1710 | 1711 | CP 0x08 - 0x20 1712 | LD DE, bs 1713 | CALL Z, asm_call 1714 | 1715 | JP drop 1716 | 1717 | .gbp: 1718 | LD DE, font + (0x60-0x20)*8 1719 | JR .print_glyph 1720 | .backtick: 1721 | LD DE, .backtick_font 1722 | JR .print_glyph 1723 | 1724 | .backtick_font: 1725 | DB %00000000 1726 | DB %00010000 1727 | DB %00001000 1728 | DB %00000000 1729 | DB %00000000 1730 | DB %00000000 1731 | DB %00000000 1732 | DB %00000000 1733 | 1734 | ; Offset of current digit in 'WORD (pictured number buffer) 1735 | HEADER to_number_sign, ">#", 0 1736 | to_number_sign: 1737 | CALL create_code 1738 | DB 0 1739 | 1740 | ; \ Initialise pictured number buffer for processing 1741 | ; : <# ( -- ) 1742 | HEADER less_number_sign, "<#", 0 1743 | less_number_sign: 1744 | CALL colon_code 1745 | ; 128 ># C! ; 1746 | DX raw_char 1747 | DB 128 1748 | DX to_number_sign 1749 | DX c_store 1750 | DX exit 1751 | 1752 | ; \ Prefix pictured numeric string with given character 1753 | ; : HOLD ( c -- ) 1754 | HEADER hold, "HOLD", 0 1755 | hold: 1756 | CALL colon_code 1757 | ; \ Decrement ># 1758 | ; -1 ># C+! 1759 | DX true 1760 | DX to_number_sign 1761 | DX c_plus_store 1762 | ; \ Store character at (># + 'WORD) 1763 | ; 'WORD ># C@ + C! ; 1764 | DX tick_word 1765 | DX to_number_sign 1766 | DX c_fetch 1767 | DX plus 1768 | DX c_store 1769 | DX exit 1770 | 1771 | ; \ Add a '-' character to the pictured numeric string if n less than 0 1772 | ; : SIGN ( n -- ) 1773 | HEADER sign, "SIGN", 0 1774 | sign: 1775 | CALL colon_code 1776 | ; 0< IF [CHAR] - HOLD THEN ; 1777 | DX zero_less 1778 | DX if_raw 1779 | DB .then-$-1 1780 | DX raw_char 1781 | DB '-' 1782 | DX hold 1783 | .then: 1784 | DX exit 1785 | 1786 | 1787 | ; \ Convert a digit to its character representation 1788 | ; : DIGIT ( n -- c ) 1789 | HEADER digit, "DIGIT", 0 1790 | digit: 1791 | CALL colon_code 1792 | ; DUP 9 > IF [ CHAR A CHAR 0 - 10 - ] LITERAL + THEN 1793 | DX dup 1794 | DX raw_char 1795 | DB 9 1796 | DX greater_than 1797 | DX if_raw 1798 | DB .then-$-1 1799 | DX raw_char 1800 | DB 'A' - '0' - 10 1801 | DX plus 1802 | .then: 1803 | ; [CHAR] 0 + ; 1804 | DX raw_char 1805 | DB '0' 1806 | DX plus 1807 | DX exit 1808 | 1809 | ; \ Divide ud1 by BASE, quotient goes in ud2, remainder converted to 1810 | ; \ digit and prefixed to pictured numeric output string. 1811 | ; : # ( ud1 -- ud2 ) 1812 | HEADER number_sign, "#", 0 1813 | number_sign: 1814 | CALL colon_code 1815 | ; BASE @ DUB/MOD DIGIT HOLD ; 1816 | DX base 1817 | DX fetch 1818 | DX dub_slash_mod 1819 | DX digit 1820 | DX hold 1821 | DX exit 1822 | 1823 | ; \ Drop double cell, get pictured numeric string 1824 | ; : #> ( xd -- c-addr u ) 1825 | HEADER number_sign_greater, "#>", 0 1826 | number_sign_greater: 1827 | CALL colon_code 1828 | ; 2DROP ># C@ 'WORD + 128 ># C@ - ; 1829 | DX two_drop 1830 | DX to_number_sign 1831 | DX c_fetch 1832 | DX tick_word 1833 | DX plus 1834 | DX raw_char 1835 | DB 128 1836 | DX to_number_sign 1837 | DX c_fetch 1838 | DX minus 1839 | DX exit 1840 | 1841 | ; \ Do # until quotient is zero 1842 | ; : #S ( ud1 -- ud2 ) 1843 | HEADER number_sign_s, "#S", 0 1844 | number_sign_s: 1845 | CALL colon_code 1846 | ; BEGIN # 2DUP D0= UNTIL 1847 | .begin: 1848 | DX number_sign 1849 | DX two_dup 1850 | DX d_zero_equals 1851 | DX until_raw 1852 | DB .begin-$+256 1853 | DX exit 1854 | 1855 | 1856 | ; \ Print an unsigned double number in the current BASE 1857 | ; : DU. ( ud -- ) 1858 | HEADER du_dot, "DU.", 0 1859 | du_dot: 1860 | CALL colon_code 1861 | ; <# #S #> TYPE SPACE ; 1862 | DX less_number_sign 1863 | DX number_sign_s 1864 | DX number_sign_greater 1865 | DX type 1866 | DX space 1867 | DX exit 1868 | 1869 | 1870 | ; \ Print a double number in the current BASE, field width n 1871 | ; ( d n --) 1872 | ; : D.R 1873 | HEADER d_dot_r, "DR.", 0 1874 | d_dot_r: 1875 | CALL colon_code 1876 | ; >R 1877 | DX to_r 1878 | ; ( d) ( R:n) 1879 | ; TUCK 1880 | DX tuck 1881 | ; ( high d) 1882 | ; <# 1883 | DX less_number_sign 1884 | ; DUP 0< IF 0. 2SWAP D- THEN 1885 | DX dup 1886 | DX zero_less 1887 | DX if_raw 1888 | DB .then-$-1 1889 | DX zero_literal 1890 | DX zero_literal 1891 | DX two_swap 1892 | DX d_minus 1893 | .then: 1894 | ; #S 1895 | DX number_sign_s 1896 | ; ROT SIGN 1897 | DX rot 1898 | DX sign 1899 | ; ( d) 1900 | ; #> R> 1901 | DX number_sign_greater 1902 | DX r_from 1903 | ; ( addr u n) ( R:) 1904 | ; \ Print padding spaces 1905 | ; 2DUP < IF OVER - SPACES ELSE DROP THEN 1906 | DX two_dup 1907 | DX less_than 1908 | DX if_raw 1909 | DB .else_spaces-$-1 1910 | DX over 1911 | DX minus 1912 | DX spaces 1913 | DX else_skip 1914 | DB .then_spaces-$-1 1915 | .else_spaces: 1916 | DX drop 1917 | .then_spaces: 1918 | ; ( addr u) 1919 | ; \ Print number 1920 | ; TYPE ; 1921 | DX type 1922 | DX exit 1923 | 1924 | 1925 | ; \ Print a double number in the current BASE 1926 | ; : D. ( d -- ) 0 D.R SPACE ; 1927 | HEADER d_dot, "D.", 0 1928 | d_dot: 1929 | CALL colon_code 1930 | DX zero_literal 1931 | DX d_dot_r 1932 | DX space 1933 | DX exit 1934 | 1935 | 1936 | ; \ Print an unsigned number in the current BASE 1937 | ; : U. ( u -- ) 1938 | HEADER u_dot, "U.", 0 1939 | u_dot: 1940 | CALL colon_code 1941 | ; BASE @ 16 = IF U$. EXIT THEN 1942 | DX base 1943 | DX fetch 1944 | DX raw_char 1945 | DB 16 1946 | DX equals 1947 | DX if_raw 1948 | DB .then1-$-1 1949 | DX u_dollar_dot 1950 | DX exit 1951 | .then1: 1952 | ; 0 DU. ; 1953 | DX zero_literal 1954 | DX du_dot 1955 | DX exit 1956 | 1957 | 1958 | ; \ Convert single to double number 1959 | ; : S>D ( n -- d ) 1960 | HEADER s_to_d, "S>D", 0 1961 | s_to_d: 1962 | CALL colon_code 1963 | ; DUP 0< IF -1 ELSE 0 THEN ; 1964 | DX dup 1965 | DX zero_less 1966 | DX if_raw 1967 | DB .else-$-1 1968 | DX true 1969 | DX else_skip 1970 | DB .then-$-1 1971 | .else: 1972 | DX zero_literal 1973 | .then: 1974 | DX exit 1975 | 1976 | 1977 | ; \ Print number in current BASE, followed by space 1978 | ; : . ( n -- ) 1979 | HEADER dot, ".", 0 1980 | dot: 1981 | CALL colon_code 1982 | ; S>D D. ; 1983 | DX s_to_d 1984 | DX d_dot 1985 | DX exit 1986 | 1987 | 1988 | ; \ Print number in current BASE, with given min. field size 1989 | ; : .R ( n m -- ) SWAP S>D ROT D.R ; 1990 | HEADER dot_r, ".R", 0 1991 | dot_r: 1992 | CALL colon_code 1993 | DX swap 1994 | DX s_to_d 1995 | DX rot 1996 | DX d_dot_r 1997 | DX exit 1998 | 1999 | 2000 | ; \ Set border to attr 2001 | ; ( attr ) : BRDR! 2002 | HEADER brdr_store, "BRDR!", 0 2003 | brdr_store: 2004 | CALL colon_code 2005 | ; 7 AND ULA P@ 0xF8 AND OR ULA P! ; 2006 | DX raw_char 2007 | DB 7 2008 | DX and 2009 | DX ula 2010 | DX p_fetch 2011 | DX raw_char 2012 | DB 0xF8 2013 | DX and 2014 | DX or 2015 | DX ula 2016 | DX p_store 2017 | DX exit 2018 | 2019 | 2020 | ; \ Clear screen, reset terminal to top-left 2021 | ; : PAGE 2022 | HEADER page, "PAGE", 0 2023 | page: 2024 | CALL colon_code 2025 | ; \ Match border to T-ATTR 2026 | ; T-ATTR C@ 3 RSHIFT BRDR! 2027 | DX t_attr 2028 | DX c_fetch 2029 | DX raw_char 2030 | DB 3 2031 | DX rshift 2032 | DX brdr_store 2033 | ; \ Reset terminal col/row 2034 | ; 0 0 AT-XY 2035 | DX zero_literal 2036 | DX zero_literal 2037 | DX at_xy 2038 | ; \ Erase bitmap 2039 | ; DISP-FILE DISP-SIZE ERASE 2040 | DX disp_file 2041 | DX disp_size 2042 | DX erase 2043 | ; \ Set attr region to current T-ATTR 2044 | ; ATTR-FILE ATTR-SIZE T-ATTR C@ FILL 2045 | DX attr_file 2046 | DX attr_size 2047 | DX t_attr 2048 | DX c_fetch 2049 | DX fill 2050 | ; ; 2051 | DX exit 2052 | 2053 | 2054 | HEADER u_dollar_dot, "U$.", 0 2055 | u_dollar_dot: 2056 | LD C, L 2057 | LD B, H 2058 | ; D is non-zero if any digits have been output yet 2059 | LD D, 0 2060 | LD A, B 2061 | RRCA 2062 | RRCA 2063 | RRCA 2064 | RRCA 2065 | CALL .emit_nibble 2066 | LD A, B 2067 | CALL .emit_nibble 2068 | LD A, C 2069 | RRCA 2070 | RRCA 2071 | RRCA 2072 | RRCA 2073 | CALL .emit_nibble 2074 | LD A, C 2075 | INC D 2076 | CALL .emit_nibble 2077 | ; Trailing space 2078 | LD DE, emit 2079 | LD HL, ' ' 2080 | PUSH HL 2081 | CALL asm_call 2082 | JP drop 2083 | ; Emit the low nibble of A (if non-zero or D non-zero) 2084 | .emit_nibble: 2085 | AND 0xF 2086 | JR NZ, .not_zero 2087 | ; If D is 0 as well, skip digit 2088 | OR D 2089 | RET Z 2090 | XOR A 2091 | .not_zero: 2092 | INC D 2093 | CP 0xA 2094 | JR C, .digit 2095 | ADD A, 'A'-'0'-0xA 2096 | .digit: 2097 | ADD A, '0' 2098 | LD L, A 2099 | LD H, 0 2100 | PUSH BC 2101 | PUSH DE 2102 | PUSH HL 2103 | LD DE, emit 2104 | CALL asm_call 2105 | POP DE 2106 | POP BC 2107 | RET 2108 | 2109 | 2110 | ; \ Empty data stack and perform QUIT 2111 | ; ( --) 2112 | ; : ABORT S0 SP! DROP QUIT ; -2 ALLOT 2113 | HEADER abort, "ABORT", 0 2114 | abort: 2115 | CALL colon_code 2116 | DX s_zero 2117 | DX sp_store 2118 | DX drop 2119 | DX quit 2120 | 2121 | 2122 | ; ( flags --) 2123 | ; : (ABORT") 2124 | HEADER abort_quote_raw, '(ABORT")', 0 2125 | abort_quote_raw: 2126 | CALL colon_code 2127 | ; R> COUNT ROT 2128 | DX r_from 2129 | DX count 2130 | DX rot 2131 | ; ( addr u cond) 2132 | ; IF TYPE ABORT THEN 2133 | DX if_raw 2134 | DB .then-$-1 2135 | DX type 2136 | DX abort 2137 | .then: 2138 | ; ( addr u) 2139 | ; + >R 2140 | DX plus 2141 | DX to_r 2142 | ; ; 2143 | DX exit 2144 | 2145 | 2146 | ; : ALLOT ( n -- ) \ Add n to dictionary end pointer 2147 | HEADER allot, "ALLOT", 0 2148 | allot: 2149 | CALL colon_code 2150 | ; H +! ; 2151 | DX h_ 2152 | DX plus_store 2153 | DX exit 2154 | 2155 | 2156 | HEADER base, "BASE", 0 2157 | base: 2158 | CALL create_code 2159 | DW 10 2160 | 2161 | 2162 | HEADER bl, "BL", 0 2163 | bl: 2164 | CALL constant_code 2165 | DW ' ' 2166 | 2167 | 2168 | ; : C, ( c -- ) \ Append byte to end of dictionary 2169 | HEADER c_comma, "C,", 0 2170 | c_comma: 2171 | CALL colon_code 2172 | ; HERE 1 ALLOT C! ; 2173 | DX here 2174 | DX one_literal 2175 | DX allot 2176 | DX c_store 2177 | DX exit 2178 | 2179 | 2180 | ; : COUNT ( addr -- addr2 u ) \ Get string in counted string 2181 | HEADER count, "COUNT", 0 2182 | count: 2183 | CALL colon_code 2184 | ; DUP 1+ SWAP C@ ; 2185 | DX dup 2186 | DX one_plus 2187 | DX swap 2188 | DX c_fetch 2189 | DX exit 2190 | 2191 | 2192 | ; \ Set BASE to 10 2193 | ; : DECIMAL ( -- ) 2194 | HEADER decimal, "DECIMAL", 0 2195 | decimal: 2196 | CALL colon_code 2197 | ; 10 BASE ! ; 2198 | DX raw_char 2199 | DB 10 2200 | DX base 2201 | DX store 2202 | DX exit 2203 | 2204 | 2205 | HEADER depth, "DEPTH", 0 2206 | depth: 2207 | CALL colon_code 2208 | DX s_zero 2209 | DX tick_s 2210 | DX minus 2211 | DX two_slash 2212 | DX one_minus 2213 | DX exit 2214 | 2215 | 2216 | ; \ Set BASE to 16 2217 | ; : HEX ( -- ) 2218 | HEADER hex, "HEX", 0 2219 | hex: 2220 | CALL colon_code 2221 | ; 16 BASE ! ; 2222 | DX raw_char 2223 | DB 16 2224 | DX base 2225 | DX store 2226 | DX exit 2227 | 2228 | 2229 | ; : MAX 2DUP < IF SWAP THEN DROP ; 2230 | HEADER max, "MAX", 0 2231 | max: 2232 | CALL colon_code 2233 | DX two_dup 2234 | DX less_than 2235 | DX if_raw 2236 | DB .skip-$-1 2237 | DX swap 2238 | .skip: 2239 | DX drop 2240 | DX exit 2241 | 2242 | 2243 | HEADER move, "MOVE", 0 2244 | move: 2245 | CALL colon_code 2246 | ; : MOVE -ROT 2DUP < IF ROT CMOVE> ELSE ROT CMOVE THEN ; 2247 | DX minus_rot 2248 | DX two_dup 2249 | DX less_than 2250 | DX if_raw 2251 | DB .move__else-$-1 2252 | DX rot 2253 | DX cmove_up 2254 | DX else_skip 2255 | DB .move__else_skip-$-1 2256 | .move__else: 2257 | DX rot 2258 | DX cmove 2259 | .move__else_skip: 2260 | DX exit 2261 | 2262 | 2263 | ; : NEGATE 0 SWAP - ; 2264 | HEADER negate, "NEGATE", 0 2265 | negate: 2266 | CALL colon_code 2267 | DX zero_literal 2268 | DX swap 2269 | DX minus 2270 | DX exit 2271 | 2272 | 2273 | ; : DNEGATE 0. 2SWAP D- ; 2274 | HEADER dnegate, "DNEGATE", 0 2275 | dnegate: 2276 | CALL colon_code 2277 | DX zero_literal 2278 | DX zero_literal 2279 | DX two_swap 2280 | DX d_minus 2281 | DX exit 2282 | 2283 | 2284 | HEADER s_quote_raw, '(S")', 0 2285 | s_quote_raw: 2286 | CALL colon_code 2287 | ; R> COUNT 2DUP + >R ; 2288 | DX r_from 2289 | DX count 2290 | DX two_dup 2291 | DX plus 2292 | DX to_r 2293 | DX exit 2294 | 2295 | 2296 | HEADER dot_quote_raw, '(.")', 0 2297 | dot_quote_raw: 2298 | CALL colon_code 2299 | ; R> COUNT 2DUP + >R TYPE ; 2300 | DX r_from 2301 | DX count 2302 | DX two_dup 2303 | DX plus 2304 | DX to_r 2305 | DX type 2306 | DX exit 2307 | 2308 | 2309 | ; \ Read a line of input into buffer, return length of line read 2310 | ; : ACCEPT ( buf size -- n ) 2311 | HEADER accept, "ACCEPT", 0 2312 | accept: 2313 | CALL colon_code 2314 | ; SWAP >R 0 2315 | DX swap 2316 | DX to_r 2317 | DX zero_literal 2318 | ; ( size idx ) ( R: buf ) 2319 | ; BEGIN 2DUP > WHILE 2320 | .begin: 2321 | DX two_dup 2322 | DX greater_than 2323 | DX if_raw 2324 | DB .repeat-$-1 2325 | ; ( size idx ) ( R: buf ) 2326 | ; KEY DUP CASE 2327 | DX key 2328 | DX dup 2329 | ; ( size idx key key ) ( R: buf ) 2330 | ; \ Delete: remove character 2331 | ; 8 OF EMIT 1- 0 MAX ENDOF 2332 | DX raw_char 2333 | DB 8 2334 | DX of_raw 2335 | DB .endof1-$-1 2336 | DX emit 2337 | DX one_minus 2338 | DX zero_literal 2339 | DX max 2340 | DX else_skip 2341 | DB .endcase-$-1 2342 | .endof1: 2343 | ; \ Enter: finish input 2344 | ; 10 OF DROP NIP R> DROP EXIT ENDOF 2345 | DX raw_char 2346 | DB 10 2347 | DX of_raw 2348 | DB .endof2-$-1 2349 | DX drop 2350 | DX nip 2351 | DX r_from 2352 | DX drop 2353 | 2354 | DX exit 2355 | DX else_skip 2356 | DB .endcase-$-1 2357 | .endof2: 2358 | ; \ default: output character 2359 | ; EMIT OVER R@ + C! 1+ 2360 | DX emit 2361 | DX over 2362 | DX r_fetch 2363 | DX plus 2364 | DX c_store 2365 | DX one_plus 2366 | ; 0 ENDCASE 2367 | DX zero_literal 2368 | DX drop 2369 | .endcase: 2370 | ; REPEAT 2371 | DX again_raw 2372 | DB .begin-$+256 2373 | .repeat: 2374 | ; ( size idx ) ( R: buf ) 2375 | ; R> DROP NIP ; 2376 | DX r_from 2377 | DX drop 2378 | DX nip 2379 | DX exit 2380 | 2381 | 2382 | ; \ Read a line of input into -IN 2383 | ; : -READ ( -- addr u ) 2384 | HEADER line_read, "-READ", 0 2385 | line_read: 2386 | CALL colon_code 2387 | ; -IN DUP -IN# ACCEPT ; 2388 | DX line_in 2389 | DX dup 2390 | DX line_in_size 2391 | DX accept 2392 | DX exit 2393 | 2394 | 2395 | ; ( addr u -- addr u 0 | xt 1 | xt -1 ) 2396 | ; CODE SFIND 2397 | HEADER sfind, "SFIND", 0 2398 | sfind: 2399 | POP DE 2400 | DEC DE 2401 | PUSH DE 2402 | ; B = size of name 2403 | LD B, L 2404 | ; Load first symbol 2405 | LD HL, (sym_last+3) 2406 | ; Start loop 2407 | JR .loop_cond 2408 | .loop: 2409 | ; Compare sizes 2410 | INC HL 2411 | INC HL 2412 | LD A, (HL) 2413 | AND 0x7F 2414 | CP B 2415 | JP NZ, .not_equal 2416 | ; Loop over characters to compare strings if same size 2417 | POP DE 2418 | PUSH DE 2419 | PUSH HL 2420 | PUSH BC 2421 | .loop2: 2422 | INC HL 2423 | LD C, (HL) 2424 | INC DE 2425 | LD A, (DE) 2426 | CP C 2427 | JP NZ, .not_equal2 2428 | DJNZ .loop2 2429 | ; If fall through loop then strings match 2430 | POP BC 2431 | POP HL 2432 | POP DE 2433 | LD A, (HL) 2434 | AND 0x80 2435 | LD DE, 1 2436 | JR NZ, .immediate 2437 | LD DE, -1 2438 | .immediate: 2439 | LD C, B 2440 | LD B, 0 2441 | ADD HL, BC 2442 | INC HL 2443 | PUSH HL 2444 | EX DE, HL 2445 | JP next 2446 | .not_equal2: 2447 | POP BC 2448 | POP HL 2449 | .not_equal: 2450 | DEC HL 2451 | DEC HL 2452 | ; Next symbol 2453 | LD E, (HL) 2454 | INC HL 2455 | LD D, (HL) 2456 | EX DE, HL 2457 | .loop_cond: 2458 | ; Loop while not 0 2459 | LD A, H 2460 | OR L 2461 | JP NZ, .loop 2462 | ; If loop falls through then no match is found 2463 | POP DE 2464 | INC DE 2465 | PUSH DE 2466 | LD E, B 2467 | LD D, 0 2468 | PUSH DE 2469 | JP next 2470 | 2471 | 2472 | ; ( c-addr -- c-addr 0 | xt 1 | xt -1) 2473 | ; : FIND 2474 | HEADER find, "FIND", 0 2475 | find: 2476 | CALL colon_code 2477 | ; COUNT SFIND 2478 | DX count 2479 | DX sfind 2480 | ; ( addr u 0 | xt 1 | xt -1) 2481 | ; ?DUP 0= IF 2482 | DX question_dup 2483 | DX zero_equals 2484 | DX if_raw 2485 | DB .then-$-1 2486 | ; ( addr u) 2487 | ; DROP 1- 0 2488 | DX drop 2489 | DX one_minus 2490 | DX zero_literal 2491 | ; THEN ; 2492 | .then: 2493 | DX exit 2494 | 2495 | 2496 | ; \ See next parse character or 0 if parse area empty 2497 | ; : PPEEK ( -- c | 0 ) 2498 | HEADER ppeek, "PPEEK", 0 2499 | ppeek: 2500 | CALL colon_code 2501 | ; >IN @ 2502 | DX to_in 2503 | DX fetch 2504 | ; ( >IN-val) 2505 | ; DUP IN# @ < IF 2506 | DX dup 2507 | DX in_size 2508 | DX fetch 2509 | DX less_than 2510 | DX if_raw 2511 | DB .else-$-1 2512 | ; 'IN @ + C@ 2513 | DX tick_in 2514 | DX fetch 2515 | DX plus 2516 | DX c_fetch 2517 | ; ( c) 2518 | ; ELSE 2519 | DX else_skip 2520 | DB .then-$-1 2521 | .else: 2522 | ; DROP 0 2523 | DX drop 2524 | DX zero_literal 2525 | ; ( 0) 2526 | ; THEN ; 2527 | .then: 2528 | DX exit 2529 | 2530 | 2531 | ; \ Parse character or 0 if parse area empty 2532 | ; : PCHAR ( "c" -- c | 0 ) 2533 | HEADER pchar, "PCHAR", 0 2534 | pchar: 2535 | CALL colon_code 2536 | ; PPEEK DUP IF 1 >IN +! THEN ; 2537 | DX ppeek 2538 | DX dup 2539 | DX if_raw 2540 | DB .then-$-1 2541 | DX one_literal 2542 | DX to_in 2543 | DX plus_store 2544 | .then: 2545 | DX exit 2546 | 2547 | 2548 | ; \ Parse a string from parse area, and return address/length of it in 2549 | ; \ parse area. 2550 | ; ( c "..." -- addr u) 2551 | ; : PARSE 2552 | HEADER parse, "PARSE", 0 2553 | parse: 2554 | CALL colon_code 2555 | ; 'IN @ >IN @ + 2556 | DX tick_in 2557 | DX fetch 2558 | DX to_in 2559 | DX fetch 2560 | DX plus 2561 | ; ( c addr) 2562 | ; 0 ROT 2563 | DX zero_literal 2564 | DX rot 2565 | ; ( addr u c) 2566 | ; BEGIN 2567 | .begin: 2568 | ; \ Stop when empty 2569 | ; PCHAR ?DUP WHILE 2570 | DX pchar 2571 | DX question_dup 2572 | DX if_raw 2573 | DB .repeat-$-1 2574 | ; ( addr u c p) 2575 | ; \ Stop when delimiter 2576 | ; OVER <> WHILE 2577 | DX over 2578 | DX not_equals 2579 | DX if_raw 2580 | DB .repeat-$-1 2581 | ; ( addr u c) 2582 | ; \ Increment length 2583 | ; SWAP 1+ SWAP 2584 | DX swap 2585 | DX one_plus 2586 | DX swap 2587 | ; REPEAT THEN 2588 | DX again_raw 2589 | DB .begin-$+256 2590 | .repeat: 2591 | ; DROP ; 2592 | DX drop 2593 | DX exit 2594 | 2595 | ; \ Parse and skip a string of delimiters 2596 | ; ( c "" --) 2597 | ; : PSKIP 2598 | HEADER pskip, "PSKIP", 0 2599 | pskip: 2600 | CALL colon_code 2601 | ; BEGIN 2602 | .begin: 2603 | ; PPEEK ?DUP WHILE 2604 | DX ppeek 2605 | DX question_dup 2606 | DX if_raw 2607 | DB .then-$-1 2608 | ; OVER = WHILE 2609 | DX over 2610 | DX equals 2611 | DX if_raw 2612 | DB .then-$-1 2613 | ; 1 >IN +! 2614 | DX one_literal 2615 | DX to_in 2616 | DX plus_store 2617 | ; REPEAT THEN 2618 | DX again_raw 2619 | DB .begin-$+256 2620 | .then: 2621 | ; DROP ; 2622 | DX drop 2623 | DX exit 2624 | 2625 | 2626 | ; \ Parse a string from parse area, skipping preceding delimiters, and 2627 | ; \ return address/length of it in parse area. 2628 | ; ( c "..." -- addr u) 2629 | ; : PARSE-WORD 2630 | HEADER parse_word, "PARSE-WORD", 0 2631 | parse_word: 2632 | CALL colon_code 2633 | ; \ Skip preceding delimiters 2634 | ; DUP PSKIP 2635 | DX dup 2636 | DX pskip 2637 | ; \ Parse rest 2638 | ; PARSE ; 2639 | DX parse 2640 | DX exit 2641 | 2642 | 2643 | ; \ Parse a name from parse area, and return address/length of it in 2644 | ; \ parse area. 2645 | ; ( "..." -- addr u) 2646 | ; : PARSE-NAME BL PARSE-WORD ; 2647 | HEADER parse_name, "PARSE-NAME", 0 2648 | parse_name: 2649 | CALL colon_code 2650 | DX bl 2651 | DX parse_word 2652 | DX exit 2653 | 2654 | 2655 | ; \ Parse counted string www, terminated by c 2656 | ; : CPARSE ( c "www" -- addr ) 2657 | HEADER cparse, "CPARSE", 0 2658 | cparse: 2659 | CALL colon_code 2660 | ; PARSE 2661 | DX parse 2662 | ; ( addr u) 2663 | ; DUP 256 >= ABORT" long name" 2664 | DX dup 2665 | DX literal_raw 2666 | DW 256 2667 | DX greater_than_or_equal 2668 | DX abort_quote_raw 2669 | DB .e1-.s1 2670 | .s1: 2671 | DM "long name" 2672 | .e1: 2673 | ; TUCK 2674 | DX tuck 2675 | ; ( u addr u) 2676 | ; 'WORD 1+ SWAP 2677 | DX tick_word 2678 | DX one_plus 2679 | DX swap 2680 | ; ( u addr addr2 u) 2681 | ; CMOVE 2682 | DX cmove 2683 | ; ( u) 2684 | ; 'WORD C! 2685 | DX tick_word 2686 | DX c_store 2687 | ; ( ) 2688 | ; 'WORD ; 2689 | DX tick_word 2690 | DX exit 2691 | 2692 | 2693 | ; \ Parse counted string www, delimited by c 2694 | ; ( c "www" -- addr ) 2695 | ; : WORD 2696 | HEADER word, "WORD", 0 2697 | word: 2698 | CALL colon_code 2699 | ; \ Ignore initial delimiters 2700 | ; DUP PSKIP 2701 | DX dup 2702 | DX pskip 2703 | ; \ Parse 2704 | ; CPARSE ; 2705 | DX cparse 2706 | DX exit 2707 | 2708 | 2709 | ; \ Check if a character is a valid double number punctuator 2710 | ; ( c -- ?) 2711 | ; : NUM-PUNC? 2712 | HEADER num_punc_question, "NUM-PUNC?", 0 2713 | num_punc_question: 2714 | CALL colon_code 2715 | ; CASE 2716 | ; [CHAR] , OF TRUE ENDOF 2717 | DX raw_char 2718 | DB ',' 2719 | DX of_raw 2720 | DB .endof1-$-1 2721 | DX true 2722 | DX else_skip 2723 | DB .endcase-$-1 2724 | .endof1: 2725 | ; [CHAR] . OF TRUE ENDOF 2726 | DX raw_char 2727 | DB '.' 2728 | DX of_raw 2729 | DB .endof2-$-1 2730 | DX true 2731 | DX else_skip 2732 | DB .endcase-$-1 2733 | .endof2: 2734 | ; [CHAR] + OF TRUE ENDOF 2735 | DX raw_char 2736 | DB '+' 2737 | DX of_raw 2738 | DB .endof3-$-1 2739 | DX true 2740 | DX else_skip 2741 | DB .endcase-$-1 2742 | .endof3: 2743 | ; [CHAR] - OF TRUE ENDOF 2744 | DX raw_char 2745 | DB '-' 2746 | DX of_raw 2747 | DB .endof4-$-1 2748 | DX true 2749 | DX else_skip 2750 | DB .endcase-$-1 2751 | .endof4: 2752 | ; [CHAR] / OF TRUE ENDOF 2753 | DX raw_char 2754 | DB '/' 2755 | DX of_raw 2756 | DB .endof5-$-1 2757 | DX true 2758 | DX else_skip 2759 | DB .endcase-$-1 2760 | .endof5: 2761 | ; [CHAR] : OF TRUE ENDOF 2762 | DX raw_char 2763 | DB ':' 2764 | DX of_raw 2765 | DB .endof6-$-1 2766 | DX true 2767 | DX else_skip 2768 | DB .endcase-$-1 2769 | .endof6: 2770 | ; FALSE SWAP 2771 | DX false 2772 | DX swap 2773 | ; ENDCASE ; 2774 | DX drop 2775 | .endcase: 2776 | DX exit 2777 | 2778 | 2779 | ; : DEFER 2780 | HEADER defer, "DEFER", 0 2781 | defer: 2782 | CALL colon_code 2783 | ; CREATE 0 , DOES> @ EXECUTE ; 2784 | DX create: DX zero_literal: DX comma: DX does_raw: CALL does_code 2785 | DX fetch: DX execute: DX exit 2786 | 2787 | 2788 | ; : IS' ( xt) 2789 | HEADER is_tick, "IS'", 0 2790 | is_tick: 2791 | CALL colon_code 2792 | ; ' >BODY ! ; 2793 | DX tick: DX to_body: DX store: DX exit 2794 | 2795 | 2796 | ; : (IS) ( xt) 2797 | HEADER is_raw, "(IS)", 0 2798 | is_raw: 2799 | CALL colon_code 2800 | ; R> TUCK @ >BODY ! CELL+ >R ; 2801 | DX r_from: DX tuck: DX fetch: DX to_body: DX store: DX cell_plus 2802 | DX to_r: DX exit 2803 | 2804 | 2805 | ; : IS 2806 | HEADER is, "IS", 1 2807 | is: 2808 | CALL colon_code 2809 | ; STATE @ IF ' POSTPONE (IS) , ELSE IS' THEN ; IMMEDIATE 2810 | DX state: DX fetch: DX if_raw: DB .else-$-1: DX tick: DX postpone_raw 2811 | DW is_raw: DX comma: DX else_skip: DB .then-$-1 2812 | .else: 2813 | DX is_tick 2814 | .then: 2815 | DX exit 2816 | 2817 | 2818 | ; ( ud addr u -- ud2 addr2 u2) 2819 | ; : >NUMBER 2820 | HEADER to_number, ">NUMBER", 0 2821 | to_number: 2822 | CALL colon_code 2823 | ; \ Loop while chars remaining 2824 | ; DUP IF BEGIN 2825 | DX dup 2826 | DX if_raw 2827 | DB .then_skip-$-1 2828 | .begin: 2829 | ; \ Get char 2830 | ; OVER C@ 2831 | DX over 2832 | DX c_fetch 2833 | ; ( ud addr u c) 2834 | ; \ Handle 0-9 / a-z apart 2835 | ; DUP [CHAR] 0 [ CHAR 9 1+ ] LITERAL WITHIN IF 2836 | DX dup 2837 | DX raw_char 2838 | DB '0' 2839 | DX raw_char 2840 | DB '9'+1 2841 | DX within 2842 | DX if_raw 2843 | DB .else-$-1 2844 | ; \ Convert char to number 2845 | ; [CHAR] 0 - 2846 | DX raw_char 2847 | DB '0' 2848 | DX minus 2849 | ; ( ud addr u n) 2850 | ; ELSE 2851 | DX else_skip 2852 | DB .then_apart-$-1 2853 | .else: 2854 | ; \ Convert char to number 2855 | ; [ CHAR A 10 - ] - 2856 | DX raw_char 2857 | DB 'A'-10 2858 | DX minus 2859 | ; ( ud addr u n) 2860 | ; THEN 2861 | .then_apart: 2862 | ; \ Must be within current base 2863 | ; DUP BASE @ 0 WITHIN IF DROP EXIT THEN 2864 | DX dup 2865 | DX base 2866 | DX fetch 2867 | DX zero_literal 2868 | DX within 2869 | DX if_raw 2870 | DB .then_base-$-1 2871 | DX drop 2872 | DX exit 2873 | .then_base: 2874 | ; 0 2ROT 2875 | DX zero_literal 2876 | DX two_rot 2877 | ; ( addr u dn ud) 2878 | ; \ Multiply current number by base 2879 | ; BASE @ 1 M*/ 2880 | DX base 2881 | DX fetch 2882 | DX one_literal 2883 | DX m_star_slash 2884 | ; \ Add digit to current number 2885 | ; D+ 2SWAP 2886 | DX d_plus 2887 | DX two_swap 2888 | ; ( ud addr u) 2889 | ; \ Next char 2890 | ; SWAP 1+ SWAP 1- 2891 | DX swap 2892 | DX one_plus 2893 | DX swap 2894 | DX one_minus 2895 | ; DUP 0= UNTIL THEN ; 2896 | DX dup 2897 | DX zero_equals 2898 | DX until_raw 2899 | DB .begin-$+256 2900 | .then_skip: 2901 | DX exit 2902 | 2903 | 2904 | ; \ Type a string with question mark and abort 2905 | ; ( addr u --) 2906 | ; : WHAT? TYPE TRUE ABORT" ?" ; -? ALLOT 2907 | HEADER what_question, "WHAT?", 0 2908 | what_question: 2909 | CALL colon_code 2910 | DX type 2911 | DX true 2912 | DX abort_quote_raw 2913 | DB .s2-.s1 2914 | .s1: 2915 | DM "?" 2916 | .s2: 2917 | 2918 | 2919 | ; \ Type a counted string with question mark and abort 2920 | ; ( c-addr --) 2921 | ; : CWHAT? COUNT WHAT? ; -? ALLOT 2922 | HEADER cwhat_question, "CWHAT?", 0 2923 | cwhat_question: 2924 | CALL colon_code 2925 | DX count 2926 | DX what_question 2927 | 2928 | 2929 | ; \ Parse single or double number from counted string 2930 | ; ( c-addr -- n|d is-double?) 2931 | ; : NUMBER 2932 | HEADER number, "NUMBER", 0 2933 | number: 2934 | CALL colon_code 2935 | ; DUP COUNT 2936 | DX dup 2937 | DX count 2938 | ; ( c-addr addr u) 2939 | ; \ Fail on empty string 2940 | ; ?DUP 0= IF DROP CWHAT? THEN 2941 | DX question_dup 2942 | DX zero_equals 2943 | DX if_raw 2944 | DB .then_empty-$-1 2945 | DX drop 2946 | DX cwhat_question 2947 | .then_empty: 2948 | ; \ Ignore first char addr/u if '-' 2949 | ; OVER C@ [CHAR] - = IF 2950 | DX over 2951 | DX c_fetch 2952 | DX raw_char 2953 | DB '-' 2954 | DX equals 2955 | DX if_raw 2956 | DB .then_ignore_minus-$-1 2957 | ; SWAP 1+ SWAP 1- 2958 | DX swap 2959 | DX one_plus 2960 | DX swap 2961 | DX one_minus 2962 | ; THEN 2963 | .then_ignore_minus: 2964 | ; \ Fail on empty string 2965 | ; ?DUP 0= IF DROP CWHAT? THEN 2966 | DX question_dup 2967 | DX zero_equals 2968 | DX if_raw 2969 | DB .then_empty2-$-1 2970 | DX drop 2971 | DX cwhat_question 2972 | .then_empty2: 2973 | ; 0. 2SWAP 2974 | DX zero_literal 2975 | DX zero_literal 2976 | DX two_swap 2977 | ; ( c-addr d-num addr u) 2978 | ; \ Attempt conversion 2979 | ; >NUMBER ?DUP IF 2980 | DX to_number 2981 | DX question_dup 2982 | DX if_raw 2983 | DB .else_single-$-1 2984 | ; ( c-addr d-num addr u) 2985 | ; \ Characters remain: double or bad char 2986 | ; BEGIN 2987 | .begin: 2988 | ; \ Check for bad char 2989 | ; OVER C@ NUM-PUNC? 0= IF 2990 | DX over 2991 | DX c_fetch 2992 | DX num_punc_question 2993 | DX zero_equals 2994 | DX if_raw 2995 | DB .then_bad-$-1 2996 | ; 2DROP 2DROP CWHAT? 2997 | DX two_drop 2998 | DX two_drop 2999 | DX cwhat_question 3000 | ; THEN 3001 | .then_bad: 3002 | ; \ Advance char 3003 | ; SWAP 1+ SWAP 1- 3004 | DX swap 3005 | DX one_plus 3006 | DX swap 3007 | DX one_minus 3008 | ; \ Check remaining 3009 | ; ?DUP WHILE 3010 | DX question_dup 3011 | DX if_raw 3012 | DB .repeat-$-1 3013 | ; \ Convert more and check remaining 3014 | ; >NUMBER ?DUP WHILE 3015 | DX to_number 3016 | DX question_dup 3017 | DX if_raw 3018 | DB .repeat-$-1 3019 | ; REPEAT THEN 3020 | DX again_raw 3021 | DB .begin-$+256 3022 | .repeat: 3023 | ; ( c-addr d-num addr) 3024 | ; DROP ROT 3025 | DX drop 3026 | DX rot 3027 | ; ( d-num c-addr) 3028 | ; \ If first char '-' negate 3029 | ; 1+ C@ [CHAR] - = IF DNEGATE THEN 3030 | DX one_plus 3031 | DX c_fetch 3032 | DX raw_char 3033 | DB '-' 3034 | DX equals 3035 | DX if_raw 3036 | DB .then_negate-$-1 3037 | DX dnegate 3038 | .then_negate: 3039 | ; ( d-num) 3040 | ; TRUE 3041 | ; ( d-num true) 3042 | DX true 3043 | ; ELSE 3044 | DX else_skip 3045 | DB .then_single-$-1 3046 | .else_single: 3047 | ; ( c-addr d-num addr) 3048 | ; \ No chars remain: single 3049 | ; 2DROP SWAP 3050 | DX two_drop 3051 | DX swap 3052 | ; ( num c-addr) 3053 | ; \ Check for '-' 3054 | ; 1+ C@ [CHAR] - = IF NEGATE THEN 3055 | DX one_plus 3056 | DX c_fetch 3057 | DX raw_char 3058 | DB '-' 3059 | DX equals 3060 | DX if_raw 3061 | DB .then_negate2-$-1 3062 | DX negate 3063 | .then_negate2: 3064 | ; ( num) 3065 | ; FALSE 3066 | ; ( d-num false) 3067 | DX false 3068 | ; THEN ; 3069 | .then_single: 3070 | DX exit 3071 | 3072 | 3073 | if tokenised 3074 | ; \ Start of tokens vector 3075 | ; ??? TOKS CONSTANT 3076 | HEADER toks, "TOKS", 0 3077 | toks: 3078 | CALL constant_code 3079 | DW tokens 3080 | endif 3081 | 3082 | 3083 | ; ( xt -- ) 3084 | ; : COMPILE, 3085 | HEADER compile_comma, "COMPILE,", 0 3086 | compile_comma: 3087 | CALL colon_code 3088 | IF tokenised 3089 | ; \ Search for xt in tokens vector 3090 | ; [ TOKS 128 CELLS + ] LITERAL TOKS DO 3091 | DX literal_raw: DW tokens + 256: DX toks: DX do_raw: DB .loop-$-1 3092 | .do: 3093 | ; \ If in tokens vector then compile the index 3094 | ; DUP I @ = IF 3095 | DX dup: DX r_fetch: DX fetch: DX equals: DX if_raw: DB .then-$-1 3096 | ; I TOKS - 2/ C, 3097 | DX r_fetch: DX toks: DX minus: DX two_slash: DX c_comma 3098 | ; DROP UNLOOP EXIT 3099 | DX drop: DX unloop: DX exit 3100 | ; THEN 3101 | .then: 3102 | ; CELL +LOOP 3103 | DX cell: DX plus_loop_raw: DB .do-$+256 3104 | .loop: 3105 | ; \ Otherwise compile xt as big-endian 3106 | ; DUP 8 RSHIFT C, C, ; 3107 | DX dup: DX raw_char: DB 8: DX rshift: DX c_comma: DX c_comma: DX exit 3108 | ELSE 3109 | ; , ; 3110 | DX comma: DX exit 3111 | ENDIF 3112 | 3113 | 3114 | ; : lower ( C -- c ) 3115 | HEADER lower, "LOWER", 0 3116 | lower: 3117 | CALL colon_code 3118 | ; dup [CHAR] A [ CHAR Z 1+ ] LITERAL within IF 3119 | DX dup 3120 | DX raw_char 3121 | DB 'A' 3122 | DX raw_char 3123 | DB 'Z' + 1 3124 | DX within 3125 | DX if_raw 3126 | DB .then-$-1 3127 | ; [ CHAR A CHAR a - ] LITERAL + 3128 | DX raw_char 3129 | DB 'a' - 'A' 3130 | DX plus 3131 | ; THEN ; 3132 | .then: 3133 | DX exit 3134 | 3135 | 3136 | ; \ Convert lowercase letters to uppercase (or do nothing) 3137 | ; : upper ( c -- C ) 3138 | HEADER upper, "UPPER", 0 3139 | upper: 3140 | CALL colon_code 3141 | ; DUP [CHAR] a [ CHAR z 1+ ] LITERAL within IF 3142 | DX dup 3143 | DX raw_char 3144 | DB 'a' 3145 | DX raw_char 3146 | DB 'z' + 1 3147 | DX within 3148 | DX if_raw 3149 | DB .then-$-1 3150 | ; [ 'A' 'a' - ] LITERAL + 3151 | DX literal_raw 3152 | DW 'A' - 'a' 3153 | DX plus 3154 | ; THEN ; 3155 | .then: 3156 | DX exit 3157 | 3158 | 3159 | ; : ERASE 0 FILL ; 3160 | HEADER erase, "ERASE", 0 3161 | erase: 3162 | CALL colon_code 3163 | DX zero_literal 3164 | DX fill 3165 | DX exit 3166 | 3167 | 3168 | HEADER space, "SPACE", 0 3169 | space: 3170 | CALL colon_code 3171 | DX bl 3172 | DX emit 3173 | DX exit 3174 | 3175 | 3176 | ; : SPACES ( n -- ) \ Print n spaces 3177 | HEADER spaces, "SPACES", 0 3178 | spaces: 3179 | CALL colon_code 3180 | ; 0 MAX 3181 | DX zero_literal 3182 | DX max 3183 | ; 0 ?DO SPACE LOOP ; 3184 | DX zero_literal 3185 | DX question_do_raw 3186 | DB .loop-$-1 3187 | .do: 3188 | DX space 3189 | DX loop_raw 3190 | DB .do-$+256 3191 | .loop: 3192 | DX exit 3193 | 3194 | 3195 | HEADER s_zero, "S0", 0 3196 | s_zero: 3197 | CALL constant_code 3198 | DW param_stack_top-2 3199 | 3200 | 3201 | HEADER r_zero, "R0", 0 3202 | r_zero: 3203 | CALL constant_code 3204 | DW return_stack_top 3205 | 3206 | 3207 | HEADER to_in, ">IN", 0 3208 | to_in: 3209 | CALL create_code 3210 | DW 0 3211 | 3212 | 3213 | HEADER ula, "ULA", 0 3214 | ula: 3215 | CALL constant_code 3216 | DW ula_val 3217 | 3218 | 3219 | ; ( d addr ) : D+! \ double in addr incremented by d 3220 | HEADER d_plus_store, "D+!", 0 3221 | d_plus_store: 3222 | CALL colon_code 3223 | ; TUCK2 2@ D+ ROT 2! ; 3224 | DX tuck2 3225 | DX two_fetch 3226 | DX d_plus 3227 | DX rot 3228 | DX two_store 3229 | DX exit 3230 | 3231 | 3232 | ; : (2LITERAL) R> DUP [ 2 CELLS ] LITERAL + >R 2@ ; 3233 | HEADER two_literal_raw, "(2LITERAL)", 0 3234 | two_literal_raw: 3235 | CALL colon_code 3236 | DX r_from 3237 | DX dup 3238 | DX raw_char 3239 | DB 4 3240 | DX plus 3241 | DX to_r 3242 | DX two_fetch 3243 | DX exit 3244 | 3245 | 3246 | ; AT-XY ( x y -- ) \ Set next terminal x,y position 3247 | HEADER at_xy, "AT-XY", 0 3248 | at_xy: 3249 | CALL colon_code 3250 | ; ( y ) 0 23 CLAMP T-ROW C! 3251 | DX zero_literal 3252 | DX raw_char 3253 | DB 23 3254 | DX clamp 3255 | DX t_row 3256 | DX c_store 3257 | ; ( x ) 0 31 CLAMP T-COL C! 3258 | DX zero_literal 3259 | DX raw_char 3260 | DB 31 3261 | DX clamp 3262 | DX t_col 3263 | DX c_store 3264 | ; ; 3265 | DX exit 3266 | 3267 | 3268 | HEADER keyq_len, "KEYQ-LEN", 0 3269 | keyq_len: 3270 | CALL constant_code 3271 | DW keyq_len_val 3272 | 3273 | 3274 | ; keyq items have two parts: 3275 | ; byte 1 = scancode which is 8*(4-bit)+(8-hrow_bit) 3276 | ; (this gives an index into Key Table (a) in ROM disassembly) 3277 | ; byte 2 = flags: 1=up, 2=shift, 4=sym 3278 | HEADER keyq, "KEYQ", 0 3279 | keyq: 3280 | CALL create_code 3281 | DS keyq_len_val * 2 3282 | 3283 | 3284 | HEADER keyq_s, "KEYQ-S", 0 3285 | keyq_s: 3286 | CALL create_code 3287 | DB 0 3288 | 3289 | 3290 | HEADER keyq_e, "KEYQ-E", 0 3291 | keyq_e: 3292 | CALL create_code 3293 | DB 0 3294 | 3295 | 3296 | ; : EKEY? ( -- flags ) \ Is a key event available? 3297 | HEADER ekey_question, "EKEY?", 0 3298 | ekey_question: 3299 | CALL colon_code 3300 | ; KEYQ-E C@ KEYQ-S C@ <> ; 3301 | DX keyq_e 3302 | DX c_fetch 3303 | DX keyq_s 3304 | DX c_fetch 3305 | DX not_equals 3306 | DX exit 3307 | 3308 | 3309 | ; 0<> ( n -- flags ) \ true if n is not equal to 0 3310 | HEADER zero_not_equals, "0<>", 0 3311 | zero_not_equals: 3312 | CALL colon_code 3313 | ; 0= INVERT ; 3314 | DX zero_equals 3315 | DX invert 3316 | DX exit 3317 | 3318 | 3319 | ; <> ( n1 n2 -- flags ) \ true if n1 is not equal to n2 3320 | HEADER not_equals, "<>", 0 3321 | not_equals: 3322 | CALL colon_code 3323 | ; = INVERT ; 3324 | DX equals 3325 | DX invert 3326 | DX exit 3327 | 3328 | 3329 | ; CLAMP ( n1 n2 n3 -- n ) \ Force n1 to range [n2, n3] 3330 | HEADER clamp, "CLAMP", 0 3331 | clamp: 3332 | CALL colon_code 3333 | ; ROT MIN MAX ; 3334 | DX rot 3335 | DX min 3336 | DX max 3337 | DX exit 3338 | 3339 | 3340 | ; : MIN ( n1 n2 -- n ) \ Leave the smaller of n1 and n2 3341 | HEADER min, "MIN", 0 3342 | min: 3343 | CALL colon_code 3344 | ; 2DUP > IF SWAP THEN DROP ; 3345 | DX two_dup 3346 | DX greater_than 3347 | DX if_raw 3348 | DB .skip-$-1 3349 | DX swap 3350 | .skip: 3351 | DX drop 3352 | DX exit 3353 | 3354 | 3355 | ; \ Store CAPS LOCK state 3356 | ; CREATE CAPS 1 C, 3357 | HEADER caps, "CAPS", 0 3358 | caps: 3359 | CALL create_code 3360 | DB 255 3361 | 3362 | 3363 | ; EKEY ( -- x ) \ Push keyboard event when ready 3364 | HEADER ekey, "EKEY", 0 3365 | ekey: 3366 | CALL colon_code 3367 | ; BEGIN EKEY? HALT UNTIL \ Block for event 3368 | .begin: 3369 | DX ekey_question 3370 | DX halt_ 3371 | DX until_raw 3372 | DB .begin-$+256 3373 | ; KEYQ KEYQ-S C@ CELLS + @ \ Receive event 3374 | DX keyq 3375 | DX keyq_s 3376 | DX c_fetch 3377 | DX two_star 3378 | DX plus 3379 | DX fetch 3380 | ; KEYQ-S C@ 1+ 7 AND KEYQ-S C! \ Increment KEYQ-S (mod 8) 3381 | DX keyq_s 3382 | DX c_fetch 3383 | DX one_plus 3384 | DX raw_char 3385 | DB 7 3386 | DX and 3387 | DX keyq_s 3388 | DX c_store 3389 | ; \ If CAPS LOCK then toggle CAPS 3390 | ; DUP $11C = IF 3391 | DX dup 3392 | DX literal_raw 3393 | DW 0x11C 3394 | DX equals 3395 | DX if_raw 3396 | DB .then-$-1 3397 | ; CAPS C@ 0= CAPS C! 3398 | DX caps 3399 | DX c_fetch 3400 | DX zero_equals 3401 | DX caps 3402 | DX c_store 3403 | ; THEN 3404 | .then: 3405 | ; ; 3406 | DX exit 3407 | 3408 | 3409 | ; \ Address of the character key map in ROM 3410 | ; $205 ROM-KMAP CONSTANT 3411 | HEADER rom_kmap, "ROM-KMAP", 0 3412 | rom_kmap: 3413 | CALL constant_code 3414 | DW 0x205 3415 | 3416 | 3417 | rom_smap1_val: EQU 0x26A 3418 | ; \ Address of one alphabet key map used with symbol shift 3419 | ; $26A ROM-SMAP1 CONSTANT 3420 | HEADER rom_smap1, "ROM-SMAP1", 0 3421 | rom_smap1: 3422 | CALL constant_code 3423 | DW rom_smap1_val 3424 | 3425 | 3426 | rom_smap2_val: EQU 0x246 3427 | ; \ Address of lower priority alphabet key map used with symbol shift 3428 | ; $246 ROM-SMAP2 CONSTANT 3429 | HEADER rom_smap2, "ROM-SMAP2", 0 3430 | rom_smap2: 3431 | CALL constant_code 3432 | DW rom_smap2_val 3433 | 3434 | 3435 | ; \ Mapping of number keys to symbol shift characters 3436 | ; CREATE NSYM-MAP 3437 | HEADER nsym_map, "NSYM-MAP", 0 3438 | nsym_map: 3439 | CALL create_code 3440 | ; '_' C, 3441 | DB '_' 3442 | ; '!' C, 3443 | DB '!' 3444 | ; '@' C, 3445 | DB '@' 3446 | ; '#' C, 3447 | DB '#' 3448 | ; '$' C, 3449 | DB '$' 3450 | ; '%' C, 3451 | DB '%' 3452 | ; '&' C, 3453 | DB '&' 3454 | ; ''' C, 3455 | DB "'" 3456 | ; '(' C, 3457 | DB '(' 3458 | ; ')' C, 3459 | DB ')' 3460 | 3461 | 3462 | ; CREATE KMAP 3463 | HEADER kmap, "KMAP", 0 3464 | kmap: 3465 | CALL create_code 3466 | ; \ Unshifted map 3467 | ; 'b' C, 'h' C, 'y' C, '6' C, '5' C, 't' C, 'g' C, 'v' C, 3468 | DB 'b', 'h', 'y', '6', '5', 't', 'g', 'v' 3469 | ; 'n' C, 'j' C, 'u' C, '7' C, '4' C, 'r' C, 'f' C, 'c' C, 3470 | DB 'n', 'j', 'u', '7', '4', 'r', 'f', 'c' 3471 | ; 'm' C, 'k' C, 'i' C, '8' C, '3' C, 'e' C, 'd' C, 'x' C, 3472 | DB 'm', 'k', 'i', '8', '3', 'e', 'd', 'x' 3473 | ; 0 C, 'l' C, 'o' C, '9' C, '2' C, 'w' C, 's' C, 'z' C, 3474 | DB 0, 'l', 'o', '9', '2', 'w', 's', 'z' 3475 | ; ' ' C, $0A C, 'p' C, '0' C, '1' C, 'q' C, 'a' C, 0 C, 3476 | DB ' ', 0x0A, 'p', '0', '1', 'q', 'a', 0 3477 | 3478 | ; \ Caps shifted map 3479 | ; 'B' C, 'H' C, 'Y' C, 0 C, 0 C, 'T' C, 'G' C, 'V' C, 3480 | DB 'B', 'H', 'Y', 0, 0, 'T', 'G', 'V' 3481 | ; 'N' C, 'J' C, 'U' C, 0 C, 0 C, 'R' C, 'F' C, 'C' C, 3482 | DB 'N', 'J', 'U', 0, 0, 'R', 'F', 'C' 3483 | ; 'M' C, 'K' C, 'I' C, 0 C, 0 C, 'E' C, 'D' C, 'X' C, 3484 | DB 'M', 'K', 'I', 0, 0, 'E', 'D', 'X' 3485 | ; 0 C, 'L' C, 'O' C, 0 C, 0 C, 'W' C, 'S' C, 'Z' C, 3486 | DB 0, 'L', 'O', 0, 0, 'W', 'S', 'Z' 3487 | ; $1B C, $0A C, 'P' C, $08 C, 0 C, 'Q' C, 'A' C, 0 C, 3488 | DB 0x1B, 0x0A, 'P', 0x08, 0, 'Q', 'A', 0 3489 | 3490 | ; \ Symbol shifted map 3491 | ; '*' C, '^' C, '[' C, '&' C, '%' C, '>' C, '}' C, '/' C, 3492 | DB '*', '^', '[', '&', '%', '>', '}', '/' 3493 | ; ',' C, '-' C, ']' C, ''' C, '$' C, '<' C, '{' C, '?' C, 3494 | DB ',', '-', ']', "'", '$', '<', '{', '?' 3495 | ; '.' C, '+' C, '`' C, '(' C, '#' C, 0 C, '\' C, $7F C, 3496 | DB '.', '+', '`', '(', '#', 0, 0x5C, 0x7F 3497 | ; 0 C, '=' C, ';' C, ')' C, '@' C, 0 C, '|' C, ':' C, 3498 | DB 0, '=', ';', ')', '@', 0, '|', ':' 3499 | ; 0 C, $0A C, '"' C, '_' C, '!' C, 0 C, '~' C, 0 C, 3500 | DB 0, 0x0A, '"', '_', '!', 0, '~', 0 3501 | 3502 | 3503 | ; EKEY>CHAR ( x -- x false | char true ) 3504 | HEADER ekey_to_char, "EKEY>CHAR", 0 3505 | ekey_to_char: 3506 | CALL colon_code 3507 | ; \ Get offset byte 3508 | ; DUP $FF AND 3509 | DX dup 3510 | DX raw_char 3511 | DB 0xFF 3512 | DX and 3513 | ; \ If shift active... 3514 | ; 2DUP <> IF 3515 | DX two_dup 3516 | DX not_equals 3517 | DX if_raw 3518 | DB .then1-$-1 3519 | ; \ If symbol shift, add 80, otherwise 40 3520 | ; OVER $200 AND 80 40 CHOOSE + 3521 | DX over 3522 | DX literal_raw 3523 | DW 0x200 3524 | DX and 3525 | DX raw_char 3526 | DB 80 3527 | DX raw_char 3528 | DB 40 3529 | DX choose 3530 | DX plus 3531 | ; THEN 3532 | .then1: 3533 | ; CHARS KMAP + C@ ?DUP IF 3534 | DX kmap 3535 | DX plus 3536 | DX c_fetch 3537 | DX question_dup 3538 | DX if_raw 3539 | DB .else1-$-1 3540 | ; NIP 3541 | DX nip 3542 | ; \ Invert case if CAPS 3543 | ; CAPS C@ IF 3544 | DX caps 3545 | DX c_fetch 3546 | DX if_raw 3547 | DB .then_caps-$-1 3548 | ; DUP [CHAR] A [ CHAR Z 1+ ] LITERAL WITHIN IF 3549 | DX dup 3550 | DX raw_char 3551 | DB 'A' 3552 | DX raw_char 3553 | DB 'Z' + 1 3554 | DX within 3555 | DX if_raw 3556 | DB .else_invert_case-$-1 3557 | ; [ CHAR a CHAR A - ] LITERAL + 3558 | DX raw_char 3559 | DB 'a' - 'A' 3560 | DX plus 3561 | ; ELSE DUP [CHAR] a [ CHAR z 1+ ] LITERAL WITHIN IF 3562 | DX else_skip 3563 | DB .then_invert_case-$-1 3564 | .else_invert_case: 3565 | DX dup 3566 | DX raw_char 3567 | DB 'a' 3568 | DX raw_char 3569 | DB 'z' + 1 3570 | DX within 3571 | DX if_raw 3572 | DB .then_invert_case-$-1 3573 | ; [ CHAR A CHAR a - ] LITERAL + 3574 | DX literal_raw 3575 | DW 'A' - 'a' 3576 | DX plus 3577 | ; THEN THEN 3578 | .then_invert_case: 3579 | ; THEN 3580 | .then_caps: 3581 | ; TRUE 3582 | DX true 3583 | ; ELSE 3584 | DX else_skip 3585 | DB .then2-$-1 3586 | .else1: 3587 | ; FALSE 3588 | DX zero_literal 3589 | ; THEN 3590 | .then2: 3591 | ; ; 3592 | DX exit 3593 | 3594 | 3595 | HEADER less_than_or_equal, "<=", 0 3596 | less_than_or_equal: 3597 | CALL colon_code 3598 | DX greater_than 3599 | DX zero_equals 3600 | DX exit 3601 | 3602 | 3603 | HEADER greater_than_or_equal, ">=", 0 3604 | greater_than_or_equal: 3605 | CALL colon_code 3606 | DX less_than 3607 | DX zero_equals 3608 | DX exit 3609 | 3610 | 3611 | ; CREATE KSHIFT-STATE 0 C, 3612 | HEADER kshift_state, "KSHIFT-STATE", 0 3613 | kshift_state: 3614 | CALL create_code 3615 | DB 0 3616 | 3617 | 3618 | ; \ Stores scanned key bits from the last scan 3619 | ; CREATE KSTATE 8 CHARS ALLOT 3620 | ; KSTATE 8 CHARS ERASE 3621 | HEADER kstate, "KSTATE", 0 3622 | kstate: 3623 | CALL create_code 3624 | DS 8 3625 | 3626 | 3627 | ; \ Stores last key press 3628 | ; CREATE KLAST 0 C, 3629 | HEADER klast, "KLAST", 0 3630 | klast: 3631 | CALL create_code 3632 | DB 0 3633 | 3634 | 3635 | ; \ Update keyboard state 3636 | ; CODE KSCAN ( -- ) 3637 | HEADER kscan, "KSCAN", 0 3638 | kscan: 3639 | PUSH IY 3640 | PUSH HL 3641 | ; If no keys are down, skip 3642 | LD BC, 0x00FE 3643 | IN A, (C) 3644 | CPL 3645 | OR A 3646 | JR NZ, .keys_down 3647 | ; Clear kstate 3648 | LD L, A 3649 | LD H, A 3650 | LD (kstate+3), HL 3651 | LD (kstate+3+2), HL 3652 | LD (kstate+3+4), HL 3653 | LD (kstate+3+6), HL 3654 | POP HL 3655 | JP pop_pc_next 3656 | 3657 | .keys_down 3658 | ; Update shift state 3659 | LD B, 0x7F 3660 | IN A, (C) 3661 | OR 0xFD 3662 | LD E, A 3663 | LD B, C 3664 | IN A, (C) 3665 | OR 0xFE 3666 | AND E 3667 | CPL 3668 | LD (kshift_state+3), A 3669 | ; Loop over rows 3670 | ; BC is 0xFEFE and will rotate to 7FFE 3671 | ; E is counter 3672 | LD E, 7 3673 | ; IY is KSTATE pointer 3674 | LD IY, kstate+3 3675 | .loop: 3676 | ; If row is empty, clear state and skip 3677 | IN A, (C) 3678 | CPL 3679 | JR NZ, .row_down 3680 | LD (IY+0), A 3681 | .next_loop: 3682 | INC IY 3683 | RLC B 3684 | DEC E 3685 | JP P, .loop 3686 | POP HL 3687 | JP pop_pc_next 3688 | .row_down: 3689 | ; BC is port, E is counter, A is input, IY is kstate+E 3690 | ; D is old state 3691 | LD D, (IY+0) 3692 | ; H becomes input store, will rotate to get all needed bits 3693 | LD H, A 3694 | ; If same as old state, skip 3695 | CP D 3696 | JR Z, .next_loop 3697 | ; Store inverted old state in D 3698 | LD A, D 3699 | CPL 3700 | LD D, A 3701 | ; L is counter for bit loop 3702 | LD L, 4 3703 | .bit_loop: 3704 | ; If new state is down and old state is up... 3705 | LD A, H 3706 | AND D 3707 | AND 1 3708 | JR Z, .bit_skip 3709 | ; ... generate an EKEY 3710 | PUSH BC 3711 | PUSH DE 3712 | PUSH HL 3713 | ; L = bit, E = row 3714 | ; Is there space in the queue? 3715 | ; C is keyq offset to store at 3716 | LD A, (keyq_s+3) 3717 | LD B, A 3718 | LD A, (keyq_e+3) 3719 | LD C, A 3720 | INC A 3721 | AND 7 3722 | CP B 3723 | JR Z, .inner_skip 3724 | ; Save next keyq_e value 3725 | LD (keyq_e+3), A 3726 | ; Make HL new EKEY value 3727 | LD A, L 3728 | ADD A, A 3729 | ADD A, A 3730 | ADD A, A 3731 | ADD A, E 3732 | LD L, A 3733 | LD A, (kshift_state+3) 3734 | LD H, A 3735 | ; Store in queue 3736 | EX DE, HL 3737 | LD HL, keyq+3 3738 | LD B, 0 3739 | ADD HL, BC 3740 | ADD HL, BC 3741 | LD (HL), E 3742 | INC HL 3743 | LD (HL), D 3744 | .inner_skip: 3745 | POP HL 3746 | POP DE 3747 | POP BC 3748 | .bit_skip: 3749 | RRC H 3750 | RRC D 3751 | DEC L 3752 | JP P, .bit_loop 3753 | ; All bits considered, save input state 3754 | LD A, H 3755 | RRCA 3756 | RRCA 3757 | RRCA 3758 | LD (IY+0), A 3759 | JR .next_loop 3760 | 3761 | 3762 | ; : BIT ( x n -- x&(1<R 2SWAP 2R> 2SWAP ; 3816 | DX two_to_r 3817 | DX two_swap 3818 | DX two_r_from 3819 | DX two_swap 3820 | DX exit 3821 | 3822 | 3823 | ; : 2-ROT ( d1 d2 d3 -- d3 d1 d2 ) 3824 | HEADER two_minus_rot, "2-ROT", 0 3825 | two_minus_rot: 3826 | CALL colon_code 3827 | ; 2SWAP 2>R 2SWAP 2R> ; 3828 | DX two_swap 3829 | DX two_to_r 3830 | DX two_swap 3831 | DX two_r_from 3832 | DX exit 3833 | 3834 | 3835 | ; : D< 3836 | HEADER d_less_than, "D<", 0 3837 | d_less_than: 3838 | CALL colon_code 3839 | ; 2SWAP $8000 + 2SWAP $8000 + DU< ; 3840 | DX two_swap 3841 | DX literal_raw 3842 | DW 0x8000 3843 | DX plus 3844 | DX two_swap 3845 | DX literal_raw 3846 | DW 0x8000 3847 | DX plus 3848 | DX du_less_than 3849 | DX exit 3850 | 3851 | 3852 | ; : D0= OR 0= ; 3853 | HEADER d_zero_equals, "D0=", 0 3854 | d_zero_equals: 3855 | CALL colon_code 3856 | DX or 3857 | DX zero_equals 3858 | DX exit 3859 | 3860 | 3861 | ; : TONE ( len period -- ) \ Make an accurate tone, masking interrupts 3862 | HEADER tone, "TONE", 0 3863 | tone: 3864 | CALL colon_code 3865 | ; DI ITONE EI ; 3866 | DX _di 3867 | DX itone 3868 | DX _ei 3869 | DX exit 3870 | 3871 | 3872 | ; : CLICK ( -- ) \ Make a 'click' noise 3873 | HEADER click, "CLICK", 0 3874 | click: 3875 | CALL colon_code 3876 | ; 4 30 ITONE ; 3877 | DX raw_char 3878 | DB 4 3879 | DX raw_char 3880 | DB 30 3881 | DX itone 3882 | DX exit 3883 | 3884 | 3885 | ; \ Print current state of stack 3886 | ; : .S ( -- ) 3887 | HEADER dot_s, ".S", 0 3888 | dot_s: 3889 | CALL colon_code 3890 | ; \ Print size of stack in brackets 3891 | ; ." <" DEPTH 0 .R ." > " 3892 | DX dot_quote_raw 3893 | DB .e1-.s1 3894 | .s1: 3895 | DM "<" 3896 | .e1: 3897 | DX depth 3898 | DX zero_literal 3899 | DX dot_r 3900 | DX dot_quote_raw 3901 | DB .e2-.s2 3902 | .s2: 3903 | DM "> " 3904 | .e2: 3905 | ; 's s0 < IF 3906 | DX tick_s 3907 | DX s_zero 3908 | DX less_than 3909 | DX if_raw 3910 | DB .then-$-1 3911 | ; \ Print contents of stack 3912 | ; 's s0 2 - DO 3913 | DX tick_s 3914 | DX s_zero 3915 | DX raw_char 3916 | DB 2 3917 | DX minus 3918 | DX do_raw 3919 | DB .loop-$-1 3920 | .do: 3921 | ; i @ . 3922 | DX r_fetch 3923 | DX fetch 3924 | DX dot 3925 | ; -2 +LOOP 3926 | DX literal_raw 3927 | DW -2 3928 | DX plus_loop_raw 3929 | DB .do-$+256 3930 | .loop: 3931 | ; THEN ; 3932 | .then: 3933 | DX exit 3934 | 3935 | 3936 | ; \ Print current state of return stack 3937 | ; : .RS ( -- ) 3938 | HEADER dot_rs, ".RS", 0 3939 | dot_rs: 3940 | CALL colon_code 3941 | ; \ Print size of stack in brackets 3942 | ; 'r r0 swap - 2/ 1- 3943 | DX tick_r 3944 | DX r_zero 3945 | DX swap 3946 | DX minus 3947 | DX two_slash 3948 | DX one_minus 3949 | ; ." <" 3950 | DX dot_quote_raw 3951 | DB .s1e-.s1 3952 | .s1: 3953 | DM "<" 3954 | .s1e: 3955 | ; 0 .R 3956 | DX zero_literal 3957 | DX dot_r 3958 | ; ." > " 3959 | DX dot_quote_raw 3960 | DB .s2e-.s2 3961 | .s2: 3962 | DM "> " 3963 | .s2e: 3964 | ; 'r cell+ r0 < INVERT IF EXIT THEN 3965 | DX tick_r 3966 | DX cell_plus 3967 | DX r_zero 3968 | DX less_than 3969 | DX invert 3970 | DX if_raw 3971 | DB .then-$-1 3972 | DX exit 3973 | .then: 3974 | ; \ Print contents of stack 3975 | ; 'r cell+ r0 2 - DO 3976 | DX tick_r 3977 | DX cell_plus 3978 | DX r_zero 3979 | DX raw_char 3980 | DB 2 3981 | DX minus 3982 | DX do_raw 3983 | DB .loop-$-1 3984 | .do: 3985 | ; i @ u. 3986 | DX r_fetch 3987 | DX fetch 3988 | DX u_dot 3989 | ; -2 +LOOP ; 3990 | DX literal_raw 3991 | DW -2 3992 | DX plus_loop_raw 3993 | DB .do-$+256 3994 | .loop: 3995 | DX exit 3996 | 3997 | 3998 | ; \ Print immediate string 3999 | ; ( "..." --) 4000 | ; : .( [CHAR] ) PARSE TYPE ; IMMEDIATE 4001 | HEADER dot_paren, ".(", 1 4002 | dot_paren: 4003 | CALL colon_code 4004 | DX raw_char 4005 | DB ')' 4006 | DX parse 4007 | DX type 4008 | DX exit 4009 | 4010 | 4011 | ; \ Inline comment 4012 | ; ( "..." --) 4013 | ; : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE 4014 | HEADER paren, "(", 1 4015 | paren: 4016 | CALL colon_code 4017 | DX raw_char 4018 | DB ')' 4019 | DX parse 4020 | DX two_drop 4021 | DX exit 4022 | 4023 | 4024 | ; \ Line comment 4025 | ; ( "......" --) 4026 | ; : \ IN# @ >IN ! ; IMMEDIATE 4027 | HEADER backslash, "\\", 1 4028 | backslash: 4029 | CALL colon_code 4030 | DX in_size 4031 | DX fetch 4032 | DX to_in 4033 | DX store 4034 | DX exit 4035 | 4036 | 4037 | ; \ Compile a Z80 CALL instruction 4038 | ; ( addr --) 4039 | ; HEX : CALL CD C, , ; DECIMAL 4040 | HEADER _call, "CALL", 0 4041 | _call: 4042 | CALL colon_code 4043 | DX raw_char 4044 | DB 0xCD 4045 | DX c_comma 4046 | DX comma 4047 | DX exit 4048 | 4049 | 4050 | ; \ Compile string as counted string 4051 | ; ( addr u --) 4052 | ; : CSTR, 4053 | HEADER cstr_comma, "CSTR,", 0 4054 | cstr_comma: 4055 | CALL colon_code 4056 | ; \ Store length 4057 | ; DUP C, 4058 | DX dup 4059 | DX c_comma 4060 | ; \ Store string 4061 | ; OVER + SWAP ?DO I C@ C, LOOP ; 4062 | DX over 4063 | DX plus 4064 | DX swap 4065 | DX question_do_raw 4066 | DB .loop-$-1 4067 | .do: 4068 | DX r_fetch 4069 | DX c_fetch 4070 | DX c_comma 4071 | DX loop_raw 4072 | DB .do-$+256 4073 | .loop: 4074 | DX exit 4075 | 4076 | 4077 | ; \ Create new symbol from parsed name 4078 | ; ( " name" --) 4079 | HEADER sym_comma, "SYM,", 0 4080 | sym_comma: 4081 | CALL colon_code 4082 | ; \ Write back-link 4083 | ; SYM-LAST @ , 4084 | DX sym_last 4085 | DX fetch 4086 | DX comma 4087 | ; \ Parse the name 4088 | ; PARSE-NAME 4089 | DX parse_name 4090 | ; ( str-addr str-u) 4091 | ; \ Must be non-empty 4092 | ; DUP 0= ABORT" missing name" 4093 | DX dup 4094 | DX zero_equals 4095 | DX abort_quote_raw 4096 | DB .e1-.s1 4097 | .s1: 4098 | DM "missing name" 4099 | .e1: 4100 | ; \ Must be smaller than 64 chars 4101 | ; DUP 64 >= ABORT" long name" 4102 | DX dup 4103 | DX raw_char 4104 | DB 64 4105 | DX greater_than_or_equal 4106 | DX abort_quote_raw 4107 | DB .e2-.s2 4108 | .s2: 4109 | DM "long name" 4110 | .e2: 4111 | ; \ Compile counted string 4112 | ; CSTR, ; 4113 | DX cstr_comma 4114 | DX exit 4115 | 4116 | 4117 | ; \ Create new definition, and make it findable 4118 | ; \ At runtime: ( -- data-addr) 4119 | ; ( " name" --) 4120 | ; HEX : CREATE 4121 | HEADER create, "CREATE", 0 4122 | create: 4123 | CALL colon_code 4124 | ; \ Retain address of new symbol 4125 | ; HERE 4126 | DX here 4127 | ; ( addr " name") 4128 | ; \ Create new symbol with parsed name 4129 | ; SYM, 4130 | DX sym_comma 4131 | ; ( addr) 4132 | ; \ Write 'CALL create-code' instruction 4133 | ; ??? CALL 4134 | DX literal_raw 4135 | DW create_code 4136 | DX _call 4137 | ; \ Make symbol findable 4138 | ; SYM-LAST ! ; DECIMAL 4139 | DX sym_last 4140 | DX store 4141 | DX exit 4142 | 4143 | 4144 | ; : VARIABLE CREATE CELL ALLOT ; 4145 | HEADER variable, "VARIABLE", 0 4146 | variable: 4147 | CALL colon_code 4148 | DX create 4149 | DX cell 4150 | DX allot 4151 | DX exit 4152 | 4153 | 4154 | ; \ Switch to compilation mode 4155 | ; ( --) 4156 | ; : ] TRUE STATE ! ; 4157 | HEADER right_bracket, "]", 0 4158 | right_bracket: 4159 | CALL colon_code 4160 | DX true 4161 | DX state 4162 | DX store 4163 | DX exit 4164 | 4165 | 4166 | ; \ Switch to interpreter mode immediately 4167 | ; ( --) 4168 | ; : [ FALSE STATE ! ; IMMEDIATE 4169 | HEADER left_bracket, "[", 1 4170 | left_bracket: 4171 | CALL colon_code 4172 | DX false 4173 | DX state 4174 | DX store 4175 | DX exit 4176 | 4177 | 4178 | ; \ Use to remember stack depth before/after colon def 4179 | ; VARIABLE :DEPTH 4180 | HEADER colon_depth, ":DEPTH", 0 4181 | colon_depth: 4182 | CALL create_code 4183 | DW 0 4184 | 4185 | 4186 | ; \ Use to remember start of current colon def 4187 | ; VARIABLE :START 4188 | HEADER colon_start, ":START", 0 4189 | colon_start: 4190 | CALL create_code 4191 | DW 0 4192 | 4193 | 4194 | ; \ Start compiling a colon definition with given name 4195 | ; ( " name" -- colon-sys) 4196 | ; : : 4197 | HEADER colon, ":", 0 4198 | colon: 4199 | CALL colon_code 4200 | ; \ Retain address of symbol 4201 | ; HERE 4202 | DX here 4203 | ; \ Remember stack depth 4204 | ; DEPTH :DEPTH ! 4205 | DX depth 4206 | DX colon_depth 4207 | DX store 4208 | ; ( colon-sys " name") 4209 | ; \ Write symbol header 4210 | ; SYM, 4211 | DX sym_comma 4212 | ; ( colon-sys) 4213 | ; \ Remember code address 4214 | ; HERE :START ! 4215 | DX here 4216 | DX colon_start 4217 | DX store 4218 | ; \ Write CALL colon-code 4219 | ; ??? CALL 4220 | DX literal_raw 4221 | DW colon_code 4222 | DX _call 4223 | ; \ Start compiling 4224 | ; ] ; 4225 | DX right_bracket 4226 | DX exit 4227 | 4228 | 4229 | ; \ End : or DOES> definition 4230 | ; ( --) 4231 | ; : ; 4232 | HEADER semicolon, ";", 1 4233 | semicolon: 4234 | CALL colon_code 4235 | ; \ Current code exits if not already 4236 | ; POSTPONE EXIT 4237 | DX postpone_raw 4238 | DW exit 4239 | ; \ Check stack depth 4240 | ; DEPTH :DEPTH @ <> ABORT" unbalanced" 4241 | DX depth 4242 | DX colon_depth 4243 | DX fetch 4244 | DX not_equals 4245 | DX abort_quote_raw 4246 | DB .e1-.s1 4247 | .s1: 4248 | DM "unbalanced" 4249 | .e1: 4250 | ; \ Make definition findable 4251 | ; SYM-LAST ! 4252 | DX sym_last 4253 | DX store 4254 | ; \ Return to interpreter mode 4255 | ; POSTPONE [ ; IMMEDIATE 4256 | DX left_bracket 4257 | DX exit 4258 | 4259 | 4260 | ; ( -- orig) 4261 | ; : IF 4262 | HEADER _if, "IF", 1 4263 | _if: 4264 | CALL colon_code 4265 | ; POSTPONE (IF) 4266 | DX postpone_raw 4267 | DW if_raw 4268 | ; HERE 4269 | DX here 4270 | ; ( orig) 4271 | ; 1 ALLOT ; IMMEDIATE 4272 | DX one_literal 4273 | DX allot 4274 | DX exit 4275 | 4276 | 4277 | ; ( orig --) 4278 | ; : THEN DUP 1+ HERE SWAP - SWAP C! ; IMMEDIATE 4279 | HEADER then, "THEN", 1 4280 | then: 4281 | CALL colon_code 4282 | ; DUP 1+ 4283 | ; ( orig orig+1) 4284 | DX dup 4285 | DX one_plus 4286 | ; HERE SWAP - 4287 | DX here 4288 | DX swap 4289 | DX minus 4290 | ; ( orig jump-len) 4291 | ; SWAP C! ; IMMEDAITE 4292 | DX swap 4293 | DX c_store 4294 | DX exit 4295 | 4296 | 4297 | ; : ELSE 4298 | HEADER _else, "ELSE", 1 4299 | _else: 4300 | CALL colon_code 4301 | ; POSTPONE (ELSE) 4302 | DX postpone_raw 4303 | DW else_skip 4304 | ; HERE 4305 | DX here 4306 | ; ( orig) 4307 | ; 1 ALLOT 4308 | DX one_literal 4309 | DX allot 4310 | ; SWAP POSTPONE THEN 4311 | DX swap 4312 | DX then 4313 | ; ; IMMEDIATE 4314 | DX exit 4315 | 4316 | 4317 | ; ( -- dest) 4318 | ; : BEGIN HERE ; IMMEDIATE 4319 | HEADER begin, "BEGIN", 1 4320 | begin: 4321 | JP here 4322 | 4323 | 4324 | ; ( dest --) 4325 | ; : AGAIN POSTPONE (AGAIN) HERE - C, ; IMMEDIATE 4326 | HEADER again, "AGAIN", 1 4327 | again: 4328 | CALL colon_code 4329 | DX postpone_raw 4330 | DW again_raw 4331 | DX here 4332 | DX minus 4333 | DX c_comma 4334 | DX exit 4335 | 4336 | 4337 | ; ( dest --) 4338 | ; : UNTIL POSTPONE (UNTIL) HERE - C, ; IMMEDIATE 4339 | HEADER until, "UNTIL", 1 4340 | until: 4341 | CALL colon_code 4342 | DX postpone_raw 4343 | DW until_raw 4344 | DX here 4345 | DX minus 4346 | DX c_comma 4347 | DX exit 4348 | 4349 | 4350 | ; ( dest -- orig dest) 4351 | ; : WHILE POSTPONE IF SWAP ; IMMEDIATE 4352 | HEADER while, "WHILE", 1 4353 | while: 4354 | CALL colon_code 4355 | DX _if 4356 | DX swap 4357 | DX exit 4358 | 4359 | 4360 | ; ( orig dest --) 4361 | ; : REPEAT POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE 4362 | HEADER repeat, "REPEAT", 1 4363 | repeat: 4364 | CALL colon_code 4365 | DX again 4366 | DX then 4367 | DX exit 4368 | 4369 | 4370 | ; ( -- dest) 4371 | ; : DO POSTPONE (DO) 1 ALLOT HERE ; IMMEDIATE 4372 | HEADER do, "DO", 1 4373 | do: 4374 | CALL colon_code 4375 | DX postpone_raw 4376 | DW do_raw 4377 | DX one_literal 4378 | DX allot 4379 | DX here 4380 | DX exit 4381 | 4382 | 4383 | ; ( -- dest) 4384 | ; : ?DO POSTPONE (?DO) 1 ALLOT HERE ; IMMEDIATE 4385 | HEADER question_do, "?DO", 1 4386 | question_do: 4387 | CALL colon_code 4388 | DX postpone_raw 4389 | DW question_do_raw 4390 | DX one_literal 4391 | DX allot 4392 | DX here 4393 | DX exit 4394 | 4395 | 4396 | ; ( do-sys --) 4397 | ; : LOOP 4398 | HEADER loop, "LOOP", 1 4399 | loop: 4400 | CALL colon_code 4401 | ; POSTPONE (LOOP) 4402 | DX postpone_raw 4403 | DW loop_raw 4404 | ; DUP HERE - C, 4405 | DX dup 4406 | DX here 4407 | DX minus 4408 | DX c_comma 4409 | ; DUP 1- SWAP HERE SWAP - SWAP C! 4410 | DX dup 4411 | DX one_minus 4412 | DX swap 4413 | DX here 4414 | DX swap 4415 | DX minus 4416 | DX swap 4417 | DX c_store 4418 | ; ; IMMEDIATE 4419 | DX exit 4420 | 4421 | 4422 | ; ( do-sys --) 4423 | ; : +LOOP 4424 | HEADER plus_loop, "+LOOP", 1 4425 | plus_loop: 4426 | CALL colon_code 4427 | ; POSTPONE (+LOOP) 4428 | DX postpone_raw 4429 | DW plus_loop_raw 4430 | ; HERE - C, 4431 | DX here 4432 | DX minus 4433 | DX c_comma 4434 | ; ; IMMEDIATE 4435 | DX exit 4436 | 4437 | 4438 | ; : I POSTPONE R@ ; IMMEDIATE 4439 | HEADER _i, "I", 1 4440 | _i: 4441 | CALL colon_code 4442 | DX postpone_raw 4443 | DW r_fetch 4444 | DX exit 4445 | 4446 | 4447 | ; \ Interpret input buffer until empty 4448 | ; : INTERPRET ( ? -- ? ) 4449 | HEADER interpret, "INTERPRET", 0 4450 | interpret: 4451 | CALL colon_code 4452 | ; BEGIN BL WORD DUP C@ WHILE 4453 | .begin: 4454 | DX bl 4455 | DX word 4456 | DX dup 4457 | DX c_fetch 4458 | DX if_raw 4459 | DB .repeat-$-1 4460 | ; FIND 4461 | DX find 4462 | ; ?DUP 0= IF 4463 | DX question_dup 4464 | DX zero_equals 4465 | DX if_raw 4466 | DB .else-$-1 4467 | ; NUMBER STATE @ IF 4468 | DX number 4469 | DX state 4470 | DX fetch 4471 | DX if_raw 4472 | DB .else2-$-1 4473 | ; IF 4474 | DX if_raw 4475 | DB .else4-$-1 4476 | ; POSTPONE 2LITERAL 4477 | DX two_literal 4478 | ; ELSE 4479 | DX else_skip 4480 | DB .then4-$-1 4481 | .else4: 4482 | ; POSTPONE LITERAL 4483 | DX literal 4484 | ; THEN 4485 | .then4: 4486 | ; ELSE 4487 | DX else_skip 4488 | DB .then2-$-1 4489 | .else2: 4490 | ; DROP 4491 | DX drop 4492 | ; THEN 4493 | .then2: 4494 | ; ELSE 4495 | DX else_skip 4496 | DB .then-$-1 4497 | .else: 4498 | ; 0< STATE @ AND IF COMPILE, ELSE EXECUTE THEN 4499 | DX zero_less 4500 | DX state 4501 | DX fetch 4502 | DX and 4503 | DX if_raw 4504 | DB .else3-$-1 4505 | DX compile_comma 4506 | DX else_skip 4507 | DB .then3-$-1 4508 | .else3: 4509 | DX execute 4510 | .then3: 4511 | ; THEN 4512 | .then: 4513 | ; REPEAT DROP ; 4514 | DX again_raw 4515 | DB .begin-$+256 4516 | .repeat: 4517 | DX drop 4518 | DX exit 4519 | 4520 | 4521 | ; : QUIT ( -- ) \ Reset return stack then start interpretation 4522 | HEADER quit, "QUIT", 0 4523 | quit: 4524 | CALL colon_code 4525 | ; R0 RP! CR 4526 | DX r_zero 4527 | DX rp_store 4528 | DX cr 4529 | ; POSTPONE [ 4530 | DX left_bracket 4531 | ; BEGIN 4532 | .begin: 4533 | ; -READ 0 >IN ! IN# ! 'IN ! SPACE INTERPRET ." ok" CR 4534 | DX line_read 4535 | DX zero_literal 4536 | DX to_in 4537 | DX store 4538 | DX in_size 4539 | DX store 4540 | DX tick_in 4541 | DX store 4542 | DX space 4543 | DX interpret 4544 | DX dot_quote_raw 4545 | DB .s1e-.s1 4546 | .s1: 4547 | DM "ok" 4548 | .s1e: 4549 | DX cr 4550 | ; AGAIN ; -? ALLOT 4551 | DX again_raw 4552 | DB .begin-$+256 4553 | 4554 | 4555 | ; : EVALUATE ( ??? addr u -- ??? ) 4556 | HEADER evaluate, "EVALUATE", 0 4557 | evaluate: 4558 | CALL colon_code 4559 | ; \ Update input state to new addr, u, and save old state 4560 | ; 0 >IN DUP @ >R ! 4561 | DX zero_literal 4562 | DX to_in 4563 | DX dup 4564 | DX fetch 4565 | DX to_r 4566 | DX store 4567 | ; IN# DUP @ >R ! 4568 | DX in_size 4569 | DX dup 4570 | DX fetch 4571 | DX to_r 4572 | DX store 4573 | ; 'IN DUP @ >R ! 4574 | DX tick_in 4575 | DX dup 4576 | DX fetch 4577 | DX to_r 4578 | DX store 4579 | ; \ Interpret code 4580 | ; INTERPRET 4581 | DX interpret 4582 | ; \ Restore input state 4583 | ; R> 'IN ! R> IN# ! R> >IN ! ; 4584 | DX r_from 4585 | DX tick_in 4586 | DX store 4587 | DX r_from 4588 | DX in_size 4589 | DX store 4590 | DX r_from 4591 | DX to_in 4592 | DX store 4593 | DX exit 4594 | 4595 | 4596 | ; ( "..."--) 4597 | ; : ." 4598 | HEADER dot_quote, ".\"", 1 4599 | dot_quote: 4600 | CALL colon_code 4601 | ; POSTPONE (.") 4602 | DX postpone_raw 4603 | DW dot_quote_raw 4604 | ; [CHAR] " PARSE 4605 | DX raw_char 4606 | DB '"' 4607 | DX parse 4608 | ; ( addr u) 4609 | ; CSTR, ; 4610 | DX cstr_comma 4611 | DX exit 4612 | 4613 | 4614 | ; ( "..."--) 4615 | ; : S" 4616 | HEADER s_quote, "S\"", 1 4617 | s_quote: 4618 | CALL colon_code 4619 | ; POSTPONE (S") 4620 | DX postpone_raw 4621 | DW s_quote_raw 4622 | ; [CHAR] " PARSE 4623 | DX raw_char 4624 | DB '"' 4625 | DX parse 4626 | ; ( addr u) 4627 | ; CSTR, ; 4628 | DX cstr_comma 4629 | DX exit 4630 | 4631 | 4632 | ; ( "name" -- xt) 4633 | ; : ' 4634 | HEADER tick, "'", 0 4635 | tick: 4636 | CALL colon_code 4637 | ; PARSE-NAME 4638 | DX parse_name 4639 | ; ( addr u) 4640 | ; SFIND 4641 | DX sfind 4642 | ; ( addr u 0 | xt 1 | xt -1) 4643 | ; ?DUP 0= IF 4644 | DX question_dup 4645 | DX zero_equals 4646 | DX if_raw 4647 | DB .then-$-1 4648 | ; ( addr u) 4649 | ; WHAT? 4650 | DX what_question 4651 | ; THEN 4652 | .then: 4653 | ; ( xt 1 | xt -1) 4654 | ; DROP ; 4655 | DX drop 4656 | DX exit 4657 | 4658 | 4659 | ; ( "name" --) 4660 | ; ( -- xt) \ runtime 4661 | ; : ['] ' POSTPONE LITERAL ; IMMEDIATE 4662 | HEADER bracket_tick, "[']", 1 4663 | bracket_tick: 4664 | CALL colon_code 4665 | DX tick 4666 | DX literal 4667 | DX exit 4668 | 4669 | 4670 | ; ( d -- d) 4671 | ; : DABS 4672 | HEADER dabs, "DABS", 0 4673 | dabs: 4674 | CALL colon_code 4675 | ; DUP 0< IF 4676 | DX dup 4677 | DX zero_less 4678 | DX if_raw 4679 | DB .then-$-1 4680 | ; 0. 2SWAP D- 4681 | DX zero_literal 4682 | DX zero_literal 4683 | DX two_swap 4684 | DX d_minus 4685 | ; THEN ; 4686 | .then: 4687 | DX exit 4688 | 4689 | 4690 | ; ( d n -- rem quo) 4691 | ; : SM/REM 4692 | HEADER sm_slash_rem, "SM/REM", 0 4693 | sm_slash_rem: 4694 | CALL colon_code 4695 | ; \ retain signs 4696 | ; 2DUP 2>R 4697 | DX two_dup 4698 | DX two_to_r 4699 | ; ( R: d-high n) 4700 | ; \ absolute values 4701 | ; -ROT DABS ROT ABS 4702 | DX minus_rot 4703 | DX dabs 4704 | DX rot 4705 | DX _abs 4706 | ; \ perform unsigned div 4707 | ; UM/MOD SWAP 4708 | DX um_slash_mod 4709 | DX swap 4710 | ; ( uquo urem) 4711 | ; \ remainder has sign of d 4712 | ; I' 0< IF NEGATE THEN 4713 | DX i_tick 4714 | DX zero_less 4715 | DX if_raw 4716 | DB .then1-$-1 4717 | DX negate 4718 | .then1: 4719 | ; SWAP 4720 | DX swap 4721 | ; ( urem uquo) 4722 | ; \ quo sign is sign1*sign2 4723 | ; 2R> XOR 0< IF NEGATE THEN ; 4724 | DX two_r_from 4725 | DX xor 4726 | DX zero_less 4727 | DX if_raw 4728 | DB .then2-$-1 4729 | DX negate 4730 | .then2: 4731 | DX exit 4732 | 4733 | 4734 | ; ( x m d -- r q) 4735 | ; : */MOD -ROT M* ROT SM/REM ; 4736 | HEADER star_slash_mod, "*/MOD", 0 4737 | star_slash_mod: 4738 | CALL colon_code 4739 | DX minus_rot 4740 | DX m_star 4741 | DX rot 4742 | DX sm_slash_rem 4743 | DX exit 4744 | 4745 | 4746 | ; ( x m d -- q) 4747 | ; : */ */MOD NIP ; 4748 | HEADER star_slash, "*/", 0 4749 | star_slash: 4750 | CALL colon_code 4751 | DX star_slash_mod 4752 | DX nip 4753 | DX exit 4754 | 4755 | 4756 | ; ( n1 n2 -- d) 4757 | ; HEX : M* 4758 | HEADER m_star, "M*", 0 4759 | m_star: 4760 | CALL colon_code 4761 | ; 2DUP 4762 | DX two_dup 4763 | ; ( n1 n2 n1 n2) 4764 | ; XOR 0< -ROT 4765 | DX xor 4766 | DX zero_less 4767 | DX minus_rot 4768 | ; ( sign n1 n2) 4769 | ; SWAP ABS SWAP ABS 4770 | DX swap 4771 | DX _abs 4772 | DX swap 4773 | DX _abs 4774 | ; ( sign an1 an2) 4775 | ; UM* 4776 | DX um_star 4777 | ; ( sign ad) 4778 | ; ROT IF DNEGATE THEN 4779 | DX rot 4780 | DX if_raw 4781 | DB .then-$-1 4782 | DX dnegate 4783 | .then: 4784 | ; ; 4785 | DX exit 4786 | 4787 | 4788 | ; ( d n1 n2 -- d) 4789 | ; : M*/ 4790 | HEADER m_star_slash, "M*/", 0 4791 | m_star_slash: 4792 | CALL colon_code 4793 | ; ( dl dh n1 n2) 4794 | ; -ROT 2DUP 4795 | DX minus_rot 4796 | DX two_dup 4797 | ; ( dl n2 dh n1 dh n1) 4798 | ; XOR 0< 4799 | DX xor 4800 | DX zero_less 4801 | ; ( dl n2 dh n1 sign) 4802 | ; >R 4803 | DX to_r 4804 | ; ( dl n2 dh n1) ( R:sign) 4805 | ; ABS ROT 4806 | DX _abs 4807 | DX rot 4808 | ; ( dl dh an1 n2) 4809 | ; 2SWAP DABS 2SWAP 4810 | DX two_swap 4811 | DX dabs 4812 | DX two_swap 4813 | ; ( ad an1 n2) 4814 | ; UM*/ 4815 | DX um_star_slash 4816 | ; ( ad2) 4817 | ; R> IF DNEGATE THEN 4818 | DX r_from 4819 | DX if_raw 4820 | DB .then-$-1 4821 | DX dnegate 4822 | .then: 4823 | ; ; 4824 | DX exit 4825 | 4826 | 4827 | ; ( num den -- rem quo) 4828 | ; : /MOD 4829 | HEADER slash_mod, "/MOD", 0 4830 | slash_mod: 4831 | CALL colon_code 4832 | ; 2DUP 2>R 4833 | DX two_dup 4834 | DX two_to_r 4835 | ; ( n d) ( R: n d) 4836 | ; SWAP ABS SWAP ABS 4837 | DX swap 4838 | DX _abs 4839 | DX swap 4840 | DX _abs 4841 | ; ( un ud) 4842 | ; U/MOD 4843 | DX u_slash_mod 4844 | ; ( ur uq) 4845 | ; SWAP I' 0< IF NEGATE THEN 4846 | DX swap 4847 | DX i_tick 4848 | DX zero_less 4849 | DX if_raw 4850 | DB .then-$-1 4851 | DX negate 4852 | .then: 4853 | ; ( uq r) 4854 | ; SWAP 2R> XOR 0< IF NEGATE THEN ; 4855 | DX swap 4856 | DX two_r_from 4857 | DX xor 4858 | DX zero_less 4859 | DX if_raw 4860 | DB .then2-$-1 4861 | DX negate 4862 | .then2: 4863 | DX exit 4864 | 4865 | 4866 | ; ( num den -- quo) 4867 | ; : / 4868 | HEADER slash, "/", 0 4869 | slash: 4870 | CALL colon_code 4871 | ; /MOD NIP ; 4872 | DX slash_mod 4873 | DX nip 4874 | DX exit 4875 | 4876 | 4877 | ; ( num den -- rem) 4878 | ; : MOD 4879 | HEADER _mod, "MOD", 0 4880 | _mod: 4881 | CALL colon_code 4882 | ; /MOD DROP ; 4883 | DX slash_mod 4884 | DX drop 4885 | DX exit 4886 | 4887 | 4888 | ; ( xt -- data-addr) 4889 | ; : >BODY 4890 | HEADER to_body, ">BODY", 0 4891 | to_body: 4892 | CALL colon_code 4893 | ; 3 + ; 4894 | DX raw_char 4895 | DB 3 4896 | DX plus 4897 | DX exit 4898 | 4899 | 4900 | ; ( "message" --) 4901 | ; ( cond --) \ runtime 4902 | ; : ABORT" 4903 | HEADER abort_quote, "ABORT\"", 1 4904 | abort_quote: 4905 | CALL colon_code 4906 | ; POSTPONE (ABORT") 4907 | DX postpone_raw 4908 | DW abort_quote_raw 4909 | ; [CHAR] " PARSE CSTR, ; 4910 | DX raw_char 4911 | DB '"' 4912 | DX parse 4913 | DX cstr_comma 4914 | DX exit 4915 | 4916 | 4917 | ; ( "name " -- c) 4918 | ; : CHAR 4919 | HEADER char, "CHAR", 0 4920 | char: 4921 | CALL colon_code 4922 | ; PARSE-NAME 4923 | DX parse_name 4924 | ; ( addr u) 4925 | ; DUP 0= ABORT" expect char" 4926 | DX dup 4927 | DX zero_equals 4928 | DX abort_quote_raw 4929 | DB .e1-.s1 4930 | .s1: 4931 | DM "expect char" 4932 | .e1: 4933 | ; DROP C@ ; 4934 | DX drop 4935 | DX c_fetch 4936 | DX exit 4937 | 4938 | 4939 | ; ( "name " --) 4940 | ; ( -- c) \ runtime 4941 | ; : [CHAR] 4942 | HEADER bracket_char, "[CHAR]", 1 4943 | bracket_char: 4944 | CALL colon_code 4945 | ; CHAR 4946 | DX char 4947 | ; ( c) 4948 | ; POSTPONE (CHAR) 4949 | DX postpone_raw 4950 | DW raw_char 4951 | ; C, ; 4952 | DX c_comma 4953 | DX exit 4954 | 4955 | 4956 | ; \ Make last defined symbol call/jump to xt instead 4957 | ; ( xt --) 4958 | ; : INSTEAD 4959 | HEADER instead, "INSTEAD", 0 4960 | instead: 4961 | CALL colon_code 4962 | ; SYM-LAST @ >SYM + 1+ ! ; 4963 | DX sym_last 4964 | DX fetch 4965 | DX to_sym 4966 | DX plus 4967 | DX one_plus 4968 | DX store 4969 | DX exit 4970 | 4971 | 4972 | ; ( x "name " --) 4973 | ; : CONSTANT 4974 | HEADER constant, "CONSTANT", 0 4975 | constant: 4976 | CALL colon_code 4977 | ; CREATE , 4978 | DX create 4979 | DX comma 4980 | ; ??? INSTEAD ; 4981 | DX literal_raw 4982 | DW constant_code 4983 | DX instead 4984 | DX exit 4985 | 4986 | 4987 | ; : (DOES) 4988 | HEADER does_raw, "(DOES)", 0 4989 | does_raw: 4990 | CALL colon_code 4991 | ; R> INSTEAD ; 4992 | DX r_from 4993 | DX instead 4994 | DX exit 4995 | 4996 | 4997 | ; : DOES> 4998 | HEADER does, "DOES>", 1 4999 | does: 5000 | CALL colon_code 5001 | ; POSTPONE (DOES) 5002 | DX postpone_raw 5003 | DW does_raw 5004 | ; ??? CALL ; 5005 | DX literal_raw 5006 | DW does_code 5007 | DX _call 5008 | DX exit 5009 | 5010 | 5011 | ; : FM/MOD 5012 | HEADER fm_slash_mod, "FM/MOD", 0 5013 | fm_slash_mod: 5014 | CALL colon_code 5015 | ; SM/REM 5016 | DX sm_slash_rem 5017 | ; ( rem quo) 5018 | ; OVER IF DUP 0< IF 5019 | DX over 5020 | DX if_raw 5021 | DB .then-$-1 5022 | DX dup 5023 | DX zero_less 5024 | DX if_raw 5025 | DB .then-$-1 5026 | ; SWAP 5027 | DX swap 5028 | ; ( quo rem) 5029 | ; DUP 0< IF 5030 | DX dup 5031 | DX zero_less 5032 | DX if_raw 5033 | DB .else2-$-1 5034 | ; 1- NEGATE 5035 | DX one_minus 5036 | DX negate 5037 | ; ELSE 5038 | DX else_skip 5039 | DB .then2-$-1 5040 | .else2: 5041 | ; NEGATE 1- 5042 | DX negate 5043 | DX one_minus 5044 | ; THEN 5045 | .then2: 5046 | ; SWAP 1- 5047 | DX swap 5048 | DX one_minus 5049 | ; ( rem quo) 5050 | ; THEN THEN ; 5051 | .then: 5052 | DX exit 5053 | 5054 | 5055 | ; HEX : IMMEDIATE 5056 | HEADER immediate, "IMMEDIATE", 0 5057 | immediate: 5058 | CALL colon_code 5059 | ; SYM-LAST @ CELL+ 5060 | DX sym_last 5061 | DX fetch 5062 | DX cell_plus 5063 | ; ( addr) 5064 | ; DUP C@ 80 OR SWAP C! 5065 | DX dup 5066 | DX c_fetch 5067 | DX raw_char 5068 | DB 0x80 5069 | DX or 5070 | DX swap 5071 | DX c_store 5072 | ; ( ) 5073 | ; ; DECIMAL 5074 | DX exit 5075 | 5076 | 5077 | ; \ Compile literal xt 5078 | ; : (PP) 5079 | HEADER postpone_raw, "(PP)", 0 5080 | postpone_raw: 5081 | CALL colon_code 5082 | ; R> 5083 | DX r_from 5084 | ; ( addr) 5085 | ; DUP @ 5086 | DX dup 5087 | DX fetch 5088 | ; ( addr xt) 5089 | ; COMPILE, 5090 | DX compile_comma 5091 | ; ( addr) 5092 | ; CELL+ >R ; 5093 | DX cell_plus 5094 | DX to_r 5095 | DX exit 5096 | 5097 | 5098 | ; \ Compile compilation semantics of name 5099 | ; ( " name" --) 5100 | ; : POSTPONE 5101 | HEADER postpone, "POSTPONE", 1 5102 | postpone: 5103 | CALL colon_code 5104 | ; PARSE-NAME SFIND 5105 | DX parse_name 5106 | DX sfind 5107 | ; ( addr u 0 | xt 1 | xt -1) 5108 | ; ?DUP 0= IF WHAT? THEN 5109 | DX question_dup 5110 | DX zero_equals 5111 | DX if_raw 5112 | DB .then-$-1 5113 | DX what_question 5114 | .then: 5115 | ; ( imm-xt 1 | xt -1) 5116 | ; 0< IF 5117 | DX zero_less 5118 | DX if_raw 5119 | DB .else2-$-1 5120 | ; ( xt) 5121 | ; POSTPONE (PP) 5122 | DX postpone_raw 5123 | DW postpone_raw 5124 | ; , 5125 | DX comma 5126 | ; ( ) 5127 | ; ELSE 5128 | DX else_skip 5129 | DB .then2-$-1 5130 | .else2: 5131 | ; ( imm-xt) 5132 | ; COMPILE, 5133 | DX compile_comma 5134 | ; ( ) 5135 | ; THEN ; IMMEDIATE 5136 | .then2: 5137 | DX exit 5138 | 5139 | 5140 | ; : RECURSE 5141 | HEADER recurse, "RECURSE", 1 5142 | recurse: 5143 | CALL colon_code 5144 | ; :START @ COMPILE, 5145 | DX colon_start 5146 | DX fetch 5147 | DX compile_comma 5148 | ; ; IMMEDIATE 5149 | DX exit 5150 | 5151 | 5152 | ; \ Remove u2 characters from string 5153 | ; ( addr1 u1 u2 -- addr2 u3) 5154 | ; : /STRING 5155 | HEADER slash_string, "/STRING", 0 5156 | slash_string: 5157 | CALL colon_code 5158 | ; TUCK 5159 | DX tuck 5160 | ; ( addr1 u2 u1 u2) 5161 | ; - 5162 | DX minus 5163 | ; ( addr1 u2 u3) 5164 | ; SWAP ROT 5165 | DX swap 5166 | DX rot 5167 | ; ( u3 u2 addr1) 5168 | ; + 5169 | DX plus 5170 | ; ( u3 addr2) 5171 | ; SWAP ; 5172 | DX swap 5173 | DX exit 5174 | 5175 | 5176 | repeat_wait_init: EQU 45 ; 0.9s 5177 | repeat_repeat_init: EQU 5 ; 0.1s 5178 | 5179 | 5180 | key_up: EQU 0x11 ; ASCII DC1 5181 | key_left: EQU 0x12 ; ASCII DC2 5182 | key_down: EQU 0x13 ; ASCII DC3 5183 | key_right: EQU 0x14 ; ASCII DC4 5184 | key_caps_lock: EQU 0x1C ; ASCII File separator 5185 | 5186 | h_init: 5187 | 5188 | sym_last_init: EQU this_header 5189 | --------------------------------------------------------------------------------