0001 0000 ;--------------------------------------------------------------------------- 0002 0000 ; 0003 0000 ; _____ __ __ ___ ___ _____ _ _ _____ _ _ 0004 0000 ; |__ | | | . |_ | |_ _|___ _| |_| |_ _ | __|___ ___| |_| |_ 0005 0000 ; | __|- -| . |_| |_ | | | . | . | . | | | | __| . | _| _| | 0006 0000 ; |_____|__|__|___|_____| |_| |___|___|___|_ | |__| |___|_| |_| |_|_| 0007 0000 ; |___| 0008 0000 ; Version 1.0 0009 0000 ; 0010 0000 ; 0011 0000 ; A Direct-Threaded Forth for the ZX81 microcomputer * 0012 0000 ; 16 bit cell, 8 bit char, 8 bit (byte) adrs unit 0013 0000 ; Z80 BC = Forth TOS (top Param Stack item) 0014 0000 ; HL = W working register 0015 0000 ; DE = IP Interpreter Pointer 0016 0000 ; SP = PSP Param Stack Pointer 0017 0000 ; (RSP) = RSP Return Stack Pointer 0018 0000 ; A, alternate register set = temporaries 0019 0000 ; 0020 0000 ; * This Forth was developed from the ZX81 Forth published by Micro Sistemas 0021 0000 ; magazine and use a lot of ideas and code from Bradford Rodriguez's CamelForth. 0022 0000 ; 0023 0000 ; 0024 0000 ; Memory map: 0025 0000 ; 0026 0000 ; 4091h Dfile (start with a HALT code) 0027 0000 ; 43ABh Forth system variables 0028 0000 ; 43C5h Key table 0029 0000 ; 4413h Chars definition table 0030 0000 ; 446Bh ASCII to ZX conversion table 0031 0000 ; 44EBh Forth kernel 0032 0000 ; ? h (DP) Forth dictionary (user RAM) 0033 0000 ; ? h (DP+44h) PAD buffer 0034 0000 ; RAMTOP-100h End of parameter stack (S0), grows down 0035 0000 ; and start of Terminal Input Buffer (TIB) 0036 0000 ; RAMTOP Return stack (R0), grows down 0037 0000 ; 0038 0000 ; 0039 0000 ; 0040 0000 ; Header structure: 0041 0000 ; 0042 0000 ; D7 D0 0043 0000 ; +---+-----------+ P - Precedence bit, equals 1 for an IMMEDIATE word. 0044 0000 ; |S|P| length | S - Smudge bit, used to prevent FIND from finding this word. 0045 0000 ; +-+-+-----------+ 0046 0000 ; | | 0047 0000 ; |- name -| 0048 0000 ; | | 0049 0000 ; +---------------+ 0050 0000 ; | | 0051 0000 ; |- link -| Link - points to the previous word's Length byte. 0052 0000 ; | | 0053 0000 ; ~~~~~~~~~~~~~~~~~ 0054 0000 ; | | 0055 0000 ; |- -| 0056 0000 ; | | 0057 0000 ; +---------------+ 0058 0000 ; 0059 0000 0060 0000 0061 0000 ; TASM cross-assembler definitions 0062 0000 0063 0000 #define db .byte 0064 0000 #define dw .word 0065 0000 #define defb .byte 0066 0000 #define defw .word 0067 0000 #define ds .block 0068 0000 #define org .org 0069 0000 #define equ .equ 0070 0000 #define end .end 0071 0000 0072 0000 ; some useful ROM routines 0073 0000 0074 0000 RESET equ $0000 0075 0000 SLOWFAST equ $0207 0076 0000 KSCAN equ $02bb 0077 0000 SETFAST equ $02E7 0078 0000 SAVE equ $02F6 0079 0000 NEXTLINE equ $0676 0080 0000 DECODEKEY equ $07bd 0081 0000 PRINTAT equ $08f5 0082 0000 MAKEROOM equ $099e 0083 0000 CLS equ $0a2a 0084 0000 STACK2BC equ $0bf5 0085 0000 STACK2A equ $0c02 0086 0000 CLASS6 equ $0d92 0087 0000 FINDINT equ $0ea7 0088 0000 FAST equ $0f23 0089 0000 SLOW equ $0f2b 0090 0000 BREAK_1 equ $0f46 0091 0000 DEBOUNCE equ $0f4b 0092 0000 SETMIN equ $14BC 0093 0000 0094 0000 0095 0000 ; SYSVARS which aren't saved 0096 0000 0097 0000 ERR_NR equ $4000 0098 0000 FLAGS equ $4001 0099 0000 ERR_SP equ $4002 0100 0000 RAMTOP equ $4004 0101 0000 MODE equ $4006 0102 0000 PPC equ $4007 0103 0000 0104 4009 org $4009 0105 4009 0106 4009 ; SYSVARS which are. This is the start of the .P 0107 4009 0108 4009 00 VERSN: db 0 0109 400A 00 00 E_PPC: dw 0 0110 400C 91 40 D_FILE: dw dfile 0111 400E 92 40 DF_CC: dw dfile+1 0112 4010 AA 43 VARS: dw vars 0113 4012 00 00 DEST: dw 0 0114 4014 E3 52 E_LINE: dw last 0115 4016 E2 52 CH_ADD: dw last-1 0116 4018 00 00 X_PTR: dw 0 0117 401A E3 52 STKBOT: dw last 0118 401C E3 52 STKEND: dw last 0119 401E 00 BERG: db 0 0120 401F 5D 40 MEM: dw MEMBOT 0121 4021 00 db 0 0122 4022 02 DF_SZ: db 2 0123 4023 01 00 S_TOP: dw 1 0124 4025 FF FF FF LAST_K: db $FF,$FF,$FF 0125 4028 37 MARGIN: db 55 0126 4029 7D 40 NXTLIN: dw line1 0127 402B 00 00 OLDPPC: dw 0 0128 402D 00 FLAGX: db 0 0129 402E 00 00 STRLEN: dw 0 0130 4030 8D 0C T_ADDR: dw $0C8D 0131 4032 00 00 SEED: dw 0 0132 4034 FF FF FRAMES: dw $FFFF 0133 4036 00 00 COORDS: db 0,0 0134 4038 BC PR_CC: db $BC 0135 4039 21 18 S_POSN: db 33,24 0136 403B 40 CDFLAG: db 01000000B 0137 403C 0138 403C PRTBUF: ds 33 0139 405D 0140 405D MEMBOT: ds 30 ; calculator's scratch 0141 407B ds 2 0142 407D 0143 407D ;= First BASIC line, calls ASM ================================== 0144 407D 0145 407D line1: 0146 407D 00 01 db $00,$01 ; line number 0147 407F 0A 00 dw line2-$-2 ; line length 0148 4081 F9 D4 db $f9,$d4 ; RAND USR 0149 4083 1C7E8F1DE400 db $1c,$7e,$8f,$1d,$e4,$00,$00 0149 4089 00 0150 408A 76 db $76 ; N/L 0151 408B 0152 408B 0153 408B ;= Second BASIC line, RUN ================================== 0154 408B 0155 408B line2: 0156 408B 00 02 db 0,2 ; line number 0157 408D 02 00 dw dfile-$-2 ; line length 0158 408F F7 db $f7 ; RUN 0159 4090 76 db $76 ; N/L 0160 4091 0161 4091 ;- Display file -------------------------------------------- 0162 4091 0163 4091 76 dfile: db $76 0164 4092 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0164 4098 00000000000000000000 0165 40A2 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0165 40A8 0000000000000000000076 0166 40B3 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0166 40B9 00000000000000000000 0167 40C3 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0167 40C9 0000000000000000000076 0168 40D4 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0168 40DA 00000000000000000000 0169 40E4 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0169 40EA 0000000000000000000076 0170 40F5 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0170 40FB 00000000000000000000 0171 4105 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0171 410B 0000000000000000000076 0172 4116 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0172 411C 00000000000000000000 0173 4126 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0173 412C 0000000000000000000076 0174 4137 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0174 413D 00000000000000000000 0175 4147 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0175 414D 0000000000000000000076 0176 4158 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0176 415E 00000000000000000000 0177 4168 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0177 416E 0000000000000000000076 0178 4179 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0178 417F 00000000000000000000 0179 4189 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0179 418F 0000000000000000000076 0180 419A 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0180 41A0 00000000000000000000 0181 41AA 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0181 41B0 0000000000000000000076 0182 41BB 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0182 41C1 00000000000000000000 0183 41CB 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0183 41D1 0000000000000000000076 0184 41DC 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0184 41E2 00000000000000000000 0185 41EC 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0185 41F2 0000000000000000000076 0186 41FD 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0186 4203 00000000000000000000 0187 420D 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0187 4213 0000000000000000000076 0188 421E 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0188 4224 00000000000000000000 0189 422E 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0189 4234 0000000000000000000076 0190 423F 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0190 4245 00000000000000000000 0191 424F 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0191 4255 0000000000000000000076 0192 4260 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0192 4266 00000000000000000000 0193 4270 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0193 4276 0000000000000000000076 0194 4281 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0194 4287 00000000000000000000 0195 4291 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0195 4297 0000000000000000000076 0196 42A2 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0196 42A8 00000000000000000000 0197 42B2 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0197 42B8 0000000000000000000076 0198 42C3 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0198 42C9 00000000000000000000 0199 42D3 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0199 42D9 0000000000000000000076 0200 42E4 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0200 42EA 00000000000000000000 0201 42F4 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0201 42FA 0000000000000000000076 0202 4305 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0202 430B 00000000000000000000 0203 4315 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0203 431B 0000000000000000000076 0204 4326 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0204 432C 00000000000000000000 0205 4336 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0205 433C 0000000000000000000076 0206 4347 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0206 434D 00000000000000000000 0207 4357 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0207 435D 0000000000000000000076 0208 4368 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0208 436E 00000000000000000000 0209 4378 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0209 437E 0000000000000000000076 0210 4389 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0210 438F 00000000000000000000 0211 4399 000000000000 db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$76 0211 439F 0000000000000000000076 0212 43AA 0213 43AA ;- BASIC-Variables ---------------------------------------- 0214 43AA 0215 43AA vars: 0216 43AA 80 db $80 0217 43AB 0218 43AB ;- End of program area ---------------------------- 0219 43AB 0220 43AB 0221 43AB ; ---------------------- 0222 43AB ; Forth system variables 0223 43AB 0224 43AB S0: ds 2 ;Base value of the parameter stack 0225 43AD R0: ds 2 ;Base value of the return stack 0226 43AF RSP: ds 2 ;Return Stack Pointer 0227 43B1 TIB: ds 2 ; Terminal Input Buffer 0228 43B3 LBP: ds 2 ; Line Buffer Pointer 0229 43B5 STATE: ds 2 ; Contain the compilation state 0230 43B7 BASE: ds 2 ; Current number base, used for input and output 0231 43B9 ; conversion 0232 43B9 HLD: ds 2 ; Holds the address of the last character during 0233 43BB ; numeric output conversion 0234 43BB CUR_POS: ds 2 ; Position of cursor on the screen 0235 43BD E3 52 DP: dw last ; Dictionary Pointer 0236 43BF C3 43 CONTEXT: dw LAST ; A pointer to the vocabulary within which 0237 43C1 ; dictionary searches will first begin 0238 43C1 C3 43 CURRENT: dw LAST ; A pointer to the vocabulary where new 0239 43C3 ; definitions are created 0240 43C3 D1 52 LAST: dw W_DOTPAREN ; Last word defined in CURRENT vocabulary 0241 43C5 0242 43C5 0243 43C5 ; **************** 0244 43C5 ; ** KEY TABLES ** 0245 43C5 ; **************** 0246 43C5 0247 43C5 ; ------------------------------- 0248 43C5 ; THE 'UNSHIFTED' CHARACTER CODES 0249 43C5 ; ------------------------------- 0250 43C5 0251 43C5 K_UNSHIFT: 0252 43C5 5A db $5a ; Z 0253 43C6 58 db $58 ; X 0254 43C7 43 db $43 ; C 0255 43C8 56 db $56 ; V 0256 43C9 41 db $41 ; A 0257 43CA 53 db $53 ; S 0258 43CB 44 db $44 ; D 0259 43CC 46 db $46 ; F 0260 43CD 47 db $47 ; G 0261 43CE 51 db $51 ; Q 0262 43CF 57 db $57 ; W 0263 43D0 45 db $45 ; E 0264 43D1 52 db $52 ; R 0265 43D2 54 db $54 ; T 0266 43D3 31 db $31 ; 1 0267 43D4 32 db $32 ; 2 0268 43D5 33 db $33 ; 3 0269 43D6 34 db $34 ; 4 0270 43D7 35 db $35 ; 5 0271 43D8 30 db $30 ; 0 0272 43D9 39 db $39 ; 9 0273 43DA 38 db $38 ; 8 0274 43DB 37 db $37 ; 7 0275 43DC 36 db $36 ; 6 0276 43DD 50 db $50 ; P 0277 43DE 4F db $4f ; O 0278 43DF 49 db $49 ; I 0279 43E0 55 db $55 ; U 0280 43E1 59 db $59 ; Y 0281 43E2 0D db $0d ; NEWLINE 0282 43E3 4C db $4c ; L 0283 43E4 4B db $4b ; K 0284 43E5 4A db $4a ; J 0285 43E6 48 db $48 ; H 0286 43E7 20 db $20 ; SPACE 0287 43E8 2E db $2e ; . 0288 43E9 4D db $4d ; M 0289 43EA 4E db $4e ; N 0290 43EB 42 db $42 ; B 0291 43EC 0292 43EC ; ----------------------------- 0293 43EC ; THE 'SHIFTED' CHARACTER CODES 0294 43EC ; ----------------------------- 0295 43EC 0296 43EC 0297 43EC K_SHIFT: 0298 43EC 3A db $3a ; : 0299 43ED 3B db $3b ; ; 0300 43EE 3F db $3f ; ? 0301 43EF 2F db $2f ; / 0302 43F0 00 db $00 ; 0303 43F1 00 db $00 ; 0304 43F2 00 db $00 ; 0305 43F3 00 db $00 ; 0306 43F4 00 db $00 ; 0307 43F5 5B db $5b ; [ 0308 43F6 5D db $5d ; ] 0309 43F7 26 db $26 ; & 0310 43F8 5E db $5e ; ^ 0311 43F9 27 db $27 ; ' 0312 43FA 21 db $21 ; ! 0313 43FB 40 db $40 ; @ 0314 43FC 23 db $23 ; # 0315 43FD 25 db $25 ; % 0316 43FE 02 db $02 ; KEY LEFT 0317 43FF 08 db $08 ; BACKSPACE 0318 4400 74 db $74 ; GRAPHICS 0319 4401 03 db $03 ; KEY RIGHT 0320 4402 01 db $01 ; KEY UP 0321 4403 04 db $04 ; KEY DOWN 0322 4404 22 db $22 ; " 0323 4405 29 db $29 ; ) 0324 4406 28 db $28 ; ( 0325 4407 24 db $24 ; $ 0326 4408 5F db $5f ; _ 0327 4409 00 db $00 ; 0328 440A 3D db $3d ; = 0329 440B 2B db $2b ; + 0330 440C 2D db $2d ; - 0331 440D 5C db $5c ; \ 0332 440E 00 db $00 ; 0333 440F 2C db $2c ; , 0334 4410 3E db $3e ; > 0335 4411 3C db $3c ; < 0336 4412 2A db $2a ; * 0337 4413 0338 4413 0339 4413 0340 4413 0341 4413 ; ------------------ 0342 4413 ; char-set (symbols) 0343 4413 ; ------------------ 0344 4413 0345 4413 chars: 0346 4413 ; $21 - Character: '!' CHR$(33) 0347 4413 0348 4413 00 db %00000000 0349 4414 10 db %00010000 0350 4415 10 db %00010000 0351 4416 10 db %00010000 0352 4417 10 db %00010000 0353 4418 00 db %00000000 0354 4419 10 db %00010000 0355 441A 00 db %00000000 0356 441B 0357 441B ; $23 - Character: '#' CHR$(35) 0358 441B 0359 441B 00 db %00000000 0360 441C 09 db %00001001 0361 441D 12 db %00010010 0362 441E 7F db %01111111 0363 441F 24 db %00100100 0364 4420 FE db %11111110 0365 4421 48 db %01001000 0366 4422 90 db %10010000 0367 4423 0368 4423 ; $25 - Character: '%' CHR$(37) 0369 4423 0370 4423 00 db %00000000 0371 4424 62 db %01100010 0372 4425 64 db %01100100 0373 4426 08 db %00001000 0374 4427 10 db %00010000 0375 4428 26 db %00100110 0376 4429 46 db %01000110 0377 442A 00 db %00000000 0378 442B 0379 442B ; $26 - Character: '&' CHR$(38) 0380 442B 0381 442B 00 db %00000000 0382 442C 10 db %00010000 0383 442D 28 db %00101000 0384 442E 10 db %00010000 0385 442F 2A db %00101010 0386 4430 44 db %01000100 0387 4431 3A db %00111010 0388 4432 00 db %00000000 0389 4433 0390 4433 ; $27 - Character: ''' CHR$(39) 0391 4433 0392 4433 00 db %00000000 0393 4434 10 db %00010000 0394 4435 10 db %00010000 0395 4436 00 db %00000000 0396 4437 00 db %00000000 0397 4438 00 db %00000000 0398 4439 00 db %00000000 0399 443A 00 db %00000000 0400 443B 0401 443B ; $40 - Character: '@' CHR$(64) 0402 443B 0403 443B 00 db %00000000 0404 443C 3C db %00111100 0405 443D 4A db %01001010 0406 443E 56 db %01010110 0407 443F 5E db %01011110 0408 4440 40 db %01000000 0409 4441 3C db %00111100 0410 4442 00 db %00000000 0411 4443 0412 4443 ; $5B - Character: '[' CHR$(91) 0413 4443 0414 4443 00 db %00000000 0415 4444 0E db %00001110 0416 4445 08 db %00001000 0417 4446 08 db %00001000 0418 4447 08 db %00001000 0419 4448 08 db %00001000 0420 4449 0E db %00001110 0421 444A 00 db %00000000 0422 444B 0423 444B ; $5C - Character: '\' CHR$(92) 0424 444B 0425 444B 00 db %00000000 0426 444C 00 db %00000000 0427 444D 40 db %01000000 0428 444E 20 db %00100000 0429 444F 10 db %00010000 0430 4450 08 db %00001000 0431 4451 04 db %00000100 0432 4452 00 db %00000000 0433 4453 0434 4453 ; $5D - Character: ']' CHR$(93) 0435 4453 0436 4453 00 db %00000000 0437 4454 70 db %01110000 0438 4455 10 db %00010000 0439 4456 10 db %00010000 0440 4457 10 db %00010000 0441 4458 10 db %00010000 0442 4459 70 db %01110000 0443 445A 00 db %00000000 0444 445B 0445 445B ; $5E - Character: '^' CHR$(94) 0446 445B 0447 445B 00 db %00000000 0448 445C 10 db %00010000 0449 445D 38 db %00111000 0450 445E 54 db %01010100 0451 445F 10 db %00010000 0452 4460 10 db %00010000 0453 4461 10 db %00010000 0454 4462 00 db %00000000 0455 4463 0456 4463 ; $5F - Character: '_' CHR$(95) 0457 4463 0458 4463 00 db %00000000 0459 4464 00 db %00000000 0460 4465 00 db %00000000 0461 4466 00 db %00000000 0462 4467 00 db %00000000 0463 4468 00 db %00000000 0464 4469 00 db %00000000 0465 446A FF db %11111111 0466 446B 0467 446B ; ---------------------------------------- 0468 446B ; ASCII to ZX character conversion table 0469 446B ; ---------------------------------------- 0470 446B ; 0471 446B asciichar: 0472 446B 00010B020D03 db $00,$01,$0B,$02,$0D,$03,$04,$05,$10,$11,$17,$15,$1A,$16,$1B,$18 ;32-47 0472 4471 0405101117151A161B18 0473 447B 1C1D1E1F2021 db $1C,$1D,$1E,$1F,$20,$21,$22,$23,$24,$25,$0E,$19,$13,$14,$12,$0F ;48-63 0473 4481 222324250E191314120F 0474 448B 06262728292A db $06,$26,$27,$28,$29,$2A,$2B,$2C,$2D,$2E,$2F,$30,$31,$32,$33,$34 ;64-79 0474 4491 2B2C2D2E2F3031323334 0475 449B 35363738393A db $35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F,$07,$08,$09,$0A,$0C ;80-95 0475 44A1 3B3C3D3E3F0708090A0C 0476 44AB 86A6A7A8A9AA db $86,$A6,$A7,$A8,$A9,$AA,$AB,$AC,$AD,$AE,$AF,$B0,$B1,$B2,$B3,$B4 ;96-111 0476 44B1 ABACADAEAFB0B1B2B3B4 0477 44BB B5B6B7B8B9BA db $B5,$B6,$B7,$B8,$B9,$BA,$BB,$BC,$BD,$BE,$BF,$87,$88,$89,$8A,$8C ;112-127 0477 44C1 BBBCBDBEBF8788898A8C 0478 44CB 80818B828D83 db $80,$81,$8B,$82,$8D,$83,$84,$85,$90,$91,$97,$95,$9A,$96,$9B,$98 ;128-143 0478 44D1 8485909197959A969B98 0479 44DB 9C9D9E9FA0A1 db $9C,$9D,$9E,$9F,$A0,$A1,$A2,$A3,$A4,$A5,$8E,$99,$93,$94,$92,$8F ;144-159 0479 44E1 A2A3A4A58E999394928F 0480 44EB 0481 44EB 0482 44EB 0483 44EB ; ------------------------- 0484 44EB ; Wait for a key routines 0485 44EB ; ------------------------- 0486 44EB ; 0487 44EB WAIT_KEY: 0488 44EB CD BB 02 call KSCAN 0489 44EE 44 ld b,h 0490 44EF 4D ld c,l 0491 44F0 51 ld d,c 0492 44F1 14 inc d 0493 44F2 28 F7 jr z,WAIT_KEY ; 0494 44F4 22 25 40 ld (LAST_K),hl ;LAST-KEY 0495 44F7 CD BD 07 call DECODEKEY 0496 44FA 30 EF jr nc,WAIT_KEY ;jump back in case of multiples keys 0497 44FC 11 47 43 ld de,K_UNSHIFT-$7e 0498 44FF 19 add hl,de 0499 4500 C9 ret 0500 4501 0501 4501 0502 4501 ;; Auto Repeat Key 0503 4501 REP_KEY: 0504 4501 2A 7B 40 ld hl,($407b) ;sv Time - Autorepeat timer 0505 4504 7C ld a,h 0506 4505 B5 or l 0507 4506 CD 2D 45 call ST_DLY 0508 4509 20 03 jr nz,W_DLY 0509 450B 21 20 00 ld hl,$0020 0510 450E 22 7B 40 W_DLY: ld ($407b),hl 0511 4511 CD BB 02 R_KEY: call KSCAN 0512 4514 4D ld c,l 0513 4515 0C inc c 0514 4516 28 15 jr z,ST_DLY ; 0515 4518 ED 5B 25 40 ld de,(LAST_K) ;LAST-KEY 0516 451C A7 and a 0517 451D ED 52 sbc hl,de 0518 451F 20 F0 jr nz,R_KEY ; 0519 4521 2A 7B 40 ld hl,($407b) 0520 4524 2B dec hl 0521 4525 22 7B 40 ld ($407b),hl ;sv Time - Autorepeat timer 0522 4528 7C ld a,h 0523 4529 B5 or l 0524 452A 20 E5 jr nz,R_KEY ; 0525 452C C9 ret 0526 452D 0527 452D ST_DLY: 0528 452D 21 00 03 ld hl,$300 0529 4530 22 7B 40 ld ($407b),hl 0530 4533 C9 ret 0531 4534 0532 4534 ; --- 0533 4534 0534 4534 0535 4534 D9 X_KEY: exx 0536 4535 CD 01 45 NOKEY: call REP_KEY 0537 4538 CD EB 44 call WAIT_KEY 0538 453B 7E ld a,(hl) 0539 453C B7 or a 0540 453D 28 F6 jr z,NOKEY 0541 453F 21 06 40 ld hl,MODE 0542 4542 FE 0D cp $0d 0543 4544 28 1C jr z,CHG 0544 4546 FE 20 cp $20 ; control key? 0545 4548 38 1A jr c,NOGR 0546 454A FE 74 cp $74 ; GRAPHICS 0547 454C 20 06 jr nz,NOCHG 0548 454E 7E ld a,(hl) 0549 454F EE 04 xor $04 0550 4551 77 ld (hl),a 0551 4552 18 E1 jr NOKEY 0552 4554 CB 56 NOCHG: bit 2,(hl) 0553 4556 28 0C jr z,NOGR 0554 4558 C6 20 add a,$20 0555 455A FE 60 cp $60 0556 455C 30 06 jr nc,NOGR 0557 455E C6 40 add a,$40 0558 4560 18 02 jr NOGR 0559 4562 0560 4562 CB 96 CHG: res 2,(hl) 0561 4564 D9 NOGR: exx 0562 4565 C9 ret 0563 4566 0564 4566 ; ------------------ 0565 4566 ; Clear the screen 0566 4566 ; ------------------ 0567 4566 ; 0568 4566 X_CLS: 0569 4566 21 92 40 ld hl,dfile+1 0570 4569 22 BB 43 ld (CUR_POS),hl 0571 456C 01 18 04 ld bc,$0418 0572 456F 7E CLS2: ld a,(hl) 0573 4570 FE 76 cp $76 0574 4572 28 02 jr z,CLS1 0575 4574 36 00 ld (hl),$00 0576 4576 23 CLS1: inc hl 0577 4577 0D dec c 0578 4578 20 F5 jr nz,CLS2 0579 457A 10 F3 djnz CLS2 0580 457C C9 ret 0581 457D 0582 457D ; --------------------- 0583 457D ; EMIT execution code 0584 457D ; --------------------- 0585 457D ; 0586 457D D9 X_EMIT: exx 0587 457E 2A BB 43 ld hl,(CUR_POS) 0588 4581 FE 0D cp $0d ; NEWLINE ? 0589 4583 28 22 jr z,EMIT_CR ; Jump if it is NEWLINE 0590 4585 FE 08 cp $08 ; Backspace ? 0591 4587 28 26 jr z,BACKSPACE ; Jump if it is Backspace (shift 0) 0592 4589 0593 4589 EB ex de,hl ; Convert the ASCII to ZX chr$ code 0594 458A D6 20 sub 32 ; 0595 458C 21 6B 44 ld hl,asciichar ; 0596 458F 4F ld c,a ; 0597 4590 06 00 ld b,0 ; 0598 4592 09 add hl,bc ; 0599 4593 7E ld a,(hl) ; 0600 4594 EB ex de,hl ; 0601 4595 0602 4595 E6 BF and $bf ; Clear the bit 6 of the ZX chr$ code 0603 4597 77 ld (hl),a 0604 4598 23 inc hl 0605 4599 7E ld a,(hl) 0606 459A FE 76 cp $76 0607 459C 20 04 jr nz,AT_CUR_POS 0608 459E 23 inc hl 0609 459F CD C6 45 QSCR: call QSCR_UP 0610 45A2 0611 45A2 AT_CUR_POS: 0612 45A2 22 BB 43 ld (CUR_POS),hl 0613 45A5 D9 exx 0614 45A6 C9 ret 0615 45A7 0616 45A7 EMIT_CR: 0617 45A7 7E ld a,(hl) 0618 45A8 23 inc hl 0619 45A9 FE 76 cp $76 0620 45AB 20 FA jr nz,EMIT_CR 0621 45AD 18 F0 jr QSCR 0622 45AF 0623 45AF BACKSPACE: 0624 45AF 2B dec hl 0625 45B0 7E ld a,(hl) 0626 45B1 FE 76 cp $76 0627 45B3 20 01 jr nz,QSTART_DFILE 0628 45B5 2B dec hl 0629 45B6 QSTART_DFILE: 0630 45B6 11 91 40 ld de,dfile 0631 45B9 B7 or a 0632 45BA EB ex de,hl 0633 45BB ED 52 sbc hl,de 0634 45BD EB ex de,hl 0635 45BE 38 02 jr c,CLR_POS ; Jump if inside of screen 0636 45C0 23 inc hl 0637 45C1 23 inc hl 0638 45C2 CLR_POS: 0639 45C2 36 00 ld (hl),$00 ; Clear the screen position 0640 45C4 18 DC jr AT_CUR_POS 0641 45C6 0642 45C6 ; Scroll the screen ? 0643 45C6 QSCR_UP: 0644 45C6 ED 5B 10 40 ld de,(VARS) 0645 45CA B7 or a 0646 45CB EB ex de,hl 0647 45CC ED 52 sbc hl,de 0648 45CE EB ex de,hl 0649 45CF C0 ret nz 0650 45D0 0651 45D0 ;------------------- 0652 45D0 ; SCROLL UP routine 0653 45D0 ;------------------- 0654 45D0 0655 45D0 21 21 00 SCRUP: ld hl,$21 0656 45D3 11 91 40 ld de,dfile 0657 45D6 19 add hl,de 0658 45D7 01 F7 02 ld bc,$2f7 0659 45DA ED B0 ldir 0660 45DC AF xor a 0661 45DD 06 20 ld b,$20 0662 45DF EB ex de,hl 0663 45E0 E5 push hl 0664 45E1 SCRUP1: 0665 45E1 23 inc hl 0666 45E2 77 ld (hl),a 0667 45E3 10 FC djnz SCRUP1 0668 45E5 E1 pop hl 0669 45E6 23 inc hl 0670 45E7 C9 ret 0671 45E8 0672 45E8 ;---------------------- 0673 45E8 ; Print String routine 0674 45E8 ;---------------------- 0675 45E8 ; Print a string addressed by HL and length given by C 0676 45E8 ; 0677 45E8 0678 45E8 PR_STRING: 0679 45E8 7E ld a,(hl) 0680 45E9 CD 7D 45 call X_EMIT 0681 45EC 23 inc hl 0682 45ED 0D dec c 0683 45EE 20 F8 jr nz,PR_STRING 0684 45F0 C9 ret 0685 45F1 0686 45F1 ; ------------------------------------ 0687 45F1 ; Set the default characters paterns 0688 45F1 ; ------------------------------------ 0689 45F1 ; 0690 45F1 C_SETCHR: 0691 45F1 D9 exx 0692 45F2 21 00 1E ld hl,$1e00 0693 45F5 11 00 30 ld de,$3000 0694 45F8 01 08 00 ld bc,8 0695 45FB C5 push bc 0696 45FC ED B0 ldir 0697 45FE 21 13 44 ld hl,chars 0698 4601 01 50 00 ld bc,80 0699 4604 ED B0 ldir 0700 4606 C1 pop bc 0701 4607 C5 push bc 0702 4608 E5 push hl 0703 4609 21 58 1E ld hl,$1e58 0704 460C ED B0 ldir 0705 460E E1 pop hl 0706 460F C1 pop bc 0707 4610 ED B0 ldir 0708 4612 21 68 1E ld hl,$1e68 0709 4615 01 08 04 ld bc,$408 0710 4618 ED B0 ldir 0711 461A D9 exx 0712 461B 3E 30 ld a,$30 0713 461D ED 47 ld i,a 0714 461F C3 6A 46 jp NEXT 0715 4622 0716 4622 0717 4622 0718 4622 ; DOCOLON, entered by CALL ENTER to enter a new 0719 4622 ; high-level thread (colon def'n.) 0720 4622 ; (internal code fragment, not a Forth word) 0721 4622 0722 4622 DOCOLON: 0723 4622 2A AF 43 ld hl,(RSP) ;push old IP on ret stack 0724 4625 2B dec hl 0725 4626 72 ld (hl),d 0726 4627 2B dec hl 0727 4628 73 ld (hl),e 0728 4629 22 AF 43 ld (RSP),hl 0729 462C E1 pop hl ;pfa -> IP 0730 462D 5E ld e,(hl) ;inline NEXTHL 0731 462E 23 inc hl 0732 462F 56 ld d,(hl) 0733 4630 23 inc hl 0734 4631 EB ex de,hl 0735 4632 E9 jp (hl) 0736 4633 0737 4633 ; DODOES, code action of DOES> clause 0738 4633 ; entered by CALL fragment 0739 4633 ; parameter field 0740 4633 ; ... 0741 4633 ; fragment: CALL DODOES 0742 4633 ; high-level thread 0743 4633 ; Enters high-level thread with address of 0744 4633 ; parameter field on top of stack. 0745 4633 ; (internal code fragment, not a Forth word) 0746 4633 0747 4633 C_DODOES: 0748 4633 2A AF 43 ld hl,(RSP) 0749 4636 2B dec hl 0750 4637 72 ld (hl),d 0751 4638 2B dec hl 0752 4639 73 ld (hl),e 0753 463A 22 AF 43 ld (RSP),hl 0754 463D D1 pop de ;adrs of new thread -> IP 0755 463E E1 pop hl ;adrs of parameter field 0756 463F C5 push bc ;push old TOS onto stack 0757 4640 44 ld b,h 0758 4641 4D ld c,l 0759 4642 C3 6A 46 jp NEXT 0760 4645 0761 4645 ; ------------------------- 0762 4645 ; Forth words definitions 0763 4645 ; ------------------------- 0764 4645 0765 4645 ; -------------- 0766 4645 ; BRANCH ( -- ) 0767 4645 ; branch always 0768 4645 0769 4645 W_BRANCH: 0770 4645 064252414E43 db $06,"BRANCH" 0770 464B 48 0771 464C 00 00 dw $0000 0772 464E C_BRANCH: 0773 464E 1A ld a,(de) ;get inline value -> IP 0774 464F 6F ld l,a 0775 4650 13 inc de 0776 4651 1A ld a,(de) 0777 4652 67 ld h,a 0778 4653 5E ld e,(hl) ;inline NEXTHL 0779 4654 23 inc hl 0780 4655 56 ld d,(hl) 0781 4656 23 inc hl 0782 4657 EB ex de,hl 0783 4658 E9 jp (hl) 0784 4659 0785 4659 ; ---------------- 0786 4659 ; 0BRANCH (f -- ) 0787 4659 ; branch if TOS zero 0788 4659 0789 4659 W_0BRANCH: 0790 4659 07304252414E db $07,"0BRANCH" 0790 465F 4348 0791 4661 45 46 dw W_BRANCH 0792 4663 C_0BRANCH: 0793 4663 78 ld a,b 0794 4664 B1 or c ; test old TOS 0795 4665 C1 pop bc ; pop new TOS 0796 4666 28 E6 jr z,C_BRANCH ; if old TOS=0, branch 0797 4668 13 inc de ; else skip inline value 0798 4669 13 inc de 0799 466A 0800 466A ; The heart of FORTH! The NEXT engine 0801 466A EB NEXT: ex de,hl 0802 466B 5E NEXTHL: ld e,(hl) ;entry point used when IP is already in HL 0803 466C 23 inc hl 0804 466D 56 ld d,(hl) 0805 466E 23 inc hl 0806 466F EB ex de,hl 0807 4670 E9 jp (hl) 0808 4671 0809 4671 ; ----------------- 0810 4671 ; (DO) (n1 n2 -- ) 0811 4671 ; The run-time proceedure compiled by DO which moves the loop control 0812 4671 ; parameters to the return stack. 0813 4671 ; 0814 4671 W_XDO: 0815 4671 0428444F29 db $04,"(DO)" 0816 4676 59 46 dw W_0BRANCH 0817 4678 C_XDO: 0818 4678 EB ex de,hl 0819 4679 E3 ex (sp),hl ; IP on stack, limit in HL 0820 467A EB ex de,hl 0821 467B 21 00 80 ld hl,8000h 0822 467E B7 or a 0823 467F ED 52 sbc hl,de ; 8000-limit in HL 0824 4681 EB ex de,hl 0825 4682 2A AF 43 ld hl,(RSP) ; push this fudge factor 0826 4685 2B dec hl 0827 4686 72 ld (hl),d ; onto return stack 0828 4687 2B dec hl ; for later use by 'I' 0829 4688 73 ld (hl),e 0830 4689 EB ex de,hl 0831 468A 09 add hl,bc ; add fudge to start value 0832 468B EB ex de,hl 0833 468C 2B dec hl ; push adjusted start value 0834 468D 72 ld (hl),d ; onto return stack 0835 468E 2B dec hl ; as the loop index. 0836 468F 73 ld (hl),e 0837 4690 22 AF 43 ld (RSP),hl 0838 4693 D1 pop de ; restore the saved IP 0839 4694 C1 pop bc ; pop new TOS 0840 4695 C3 6A 46 jp NEXT 0841 4698 0842 4698 ;--------------- 0843 4698 ; (LOOP) ( -- ) 0844 4698 ; Run-time proceedure compiled by LOOP which increases the index and 0845 4698 ; test for loop completion. 0846 4698 ; 0847 4698 W_XLOOP: 0848 4698 06284C4F4F50 db $06,"(LOOP)" 0848 469E 29 0849 469F 71 46 dw W_XDO 0850 46A1 C_XLOOP: 0851 46A1 D9 exx 0852 46A2 01 01 00 ld bc,1 0853 46A5 LOOPTST: 0854 46A5 2A AF 43 ld hl,(RSP) 0855 46A8 7E ld a,(hl) ; get the loop index 0856 46A9 B7 or a 0857 46AA 89 adc a,c ; increment w/overflow test 0858 46AB 77 ld (hl),a ; save the updated index (low byte) 0859 46AC 23 inc hl 0860 46AD 7E ld a,(hl) 0861 46AE 88 adc a,b 0862 46AF EA B6 46 jp pe,LOOPTERM ; overflow=loop done 0863 46B2 ; continue the loop 0864 46B2 77 ld (hl),a ; save the updated index (hi byte) 0865 46B3 D9 exx 0866 46B4 18 98 jr C_BRANCH ; take the inline branch 0867 46B6 LOOPTERM: ; terminate the loop 0868 46B6 23 inc hl ; discard the loop info 0869 46B7 23 inc hl 0870 46B8 23 inc hl 0871 46B9 22 AF 43 ld (RSP),hl 0872 46BC D9 exx 0873 46BD 13 inc de ; skip the inline branch 0874 46BE 13 inc de 0875 46BF C3 6A 46 jp NEXT 0876 46C2 0877 46C2 ; ---------------- 0878 46C2 ; (+LOOP) (n -- ) 0879 46C2 ; The run-time proceedure compiled by +LOOP, which increments the loop 0880 46C2 ; index by n and tests for loop completion. 0881 46C2 ; 0882 46C2 W_XPLOOP: 0883 46C2 07282B4C4F4F db $07,"(+LOOP)" 0883 46C8 5029 0884 46CA 98 46 dw W_XLOOP 0885 46CC C_XPLOOP: 0886 46CC E1 pop hl ; this will be the new TOS 0887 46CD C5 push bc 0888 46CE 44 ld b,h 0889 46CF 4D ld c,l 0890 46D0 D9 exx 0891 46D1 C1 pop bc ; old TOS = loop increment 0892 46D2 18 D1 jr LOOPTST 0893 46D4 0894 46D4 ; ---------- 0895 46D4 ; I ( -- n) 0896 46D4 ; Used within a DO-LOOP to copy the loop index to the stack. 0897 46D4 ; 0898 46D4 W_I: 0899 46D4 01 49 db $01,"I" 0900 46D6 C2 46 dw W_XPLOOP 0901 46D8 C_I: 0902 46D8 C5 push bc ; push old TOS 0903 46D9 D9 exx 0904 46DA 2A AF 43 ld hl,(RSP) 0905 46DD 5E GCLI: ld e,(hl) ; get current loop index 0906 46DE 23 inc hl 0907 46DF 56 ld d,(hl) 0908 46E0 23 inc hl 0909 46E1 4E ld c,(hl) ; get fudge factor 0910 46E2 23 inc hl 0911 46E3 46 ld b,(hl) 0912 46E4 EB ex de,hl 0913 46E5 B7 or a 0914 46E6 ED 42 sbc hl,bc ; subtract fudge factor, 0915 46E8 E5 push hl 0916 46E9 D9 exx 0917 46EA C1 pop bc ; returning true index 0918 46EB C3 6A 46 jp NEXT 0919 46EE 0920 46EE ; ---------- 0921 46EE ; J ( -- n) 0922 46EE ; Used within a DO-LOOP to copy the loop index for the second innermost 0923 46EE ; DO loop to the stack. 0924 46EE ; 0925 46EE W_J: 0926 46EE 01 4A db $01,"J" 0927 46F0 D4 46 dw W_I 0928 46F2 C_J: 0929 46F2 C5 push bc 0930 46F3 D9 exx 0931 46F4 2A AF 43 ld hl,(RSP) 0932 46F7 01 04 00 ld bc,4 0933 46FA 09 add hl,bc 0934 46FB 18 E0 jr GCLI 0935 46FD 0936 46FD ; ------------- 0937 46FD ; LEAVE ( -- ) 0938 46FD ; Forces termination of a DO loop at the next LOOP or +LOOP by setting the 0939 46FD ; loop counter equal to the limit-1. 0940 46FD ; 0941 46FD W_LEAVE: 0942 46FD 054C45415645 db $05,"LEAVE" 0943 4703 EE 46 dw W_J 0944 4705 C_LEAVE: 0945 4705 D5 push de ;save IP 0946 4706 2A AF 43 ld hl,(RSP) 0947 4709 11 FF 7F ld de,$7fff 0948 470C 73 ld (hl),e 0949 470D 23 inc hl 0950 470E 72 ld (hl),d 0951 470F D1 pop de ;restore IP 0952 4710 C3 6A 46 jp NEXT 0953 4713 0954 4713 0955 4713 ;------------- 0956 4713 ; EXIT ( -- ) 0957 4713 ; exit a colon definition 0958 4713 0959 4713 W_EXIT: 0960 4713 0445584954 db $04,"EXIT" 0961 4718 FD 46 dw W_LEAVE 0962 471A C_EXIT: 0963 471A 2A AF 43 ld hl,(RSP) ;pop old IP from ret stack 0964 471D 5E ld e,(hl) 0965 471E 23 inc hl 0966 471F 56 ld d,(hl) 0967 4720 23 inc hl 0968 4721 22 AF 43 ld (RSP),hl 0969 4724 EB ex de,hl ;inline NEXT 0970 4725 5E ld e,(hl) 0971 4726 23 inc hl 0972 4727 56 ld d,(hl) 0973 4728 23 inc hl 0974 4729 EB ex de,hl 0975 472A E9 jp (hl) 0976 472B 0977 472B ;------------- 0978 472B ; LIT ( -- n) 0979 472B ; fetch inline literal to stack 0980 472B ; 0981 472B W_LIT: 0982 472B 03 4C 49 54 db $03,"LIT" 0983 472F 13 47 dw W_EXIT 0984 4731 C_LIT: 0985 4731 C5 push bc 0986 4732 1A ld a,(de) 0987 4733 13 inc de 0988 4734 4F ld c,a 0989 4735 1A ld a,(de) 0990 4736 13 inc de 0991 4737 47 ld b,a 0992 4738 C3 6A 46 jp NEXT 0993 473B 0994 473B ;-------------------- 0995 473B ; EXECUTE (addr -- ) 0996 473B ; execute Forth word at addr 0997 473B ; 0998 473B W_EXECUTE: 0999 473B 074558454355 db $07,"EXECUTE" 0999 4741 5445 1000 4743 2B 47 dw W_LIT 1001 4745 C_EXECUTE: 1002 4745 60 ld h,b 1003 4746 69 ld l,c 1004 4747 C1 pop bc 1005 4748 E9 jp (hl) 1006 4749 1007 4749 ; ----------------- 1008 4749 ; VARIABLE (n -- ) 1009 4749 ; CREATE , ; 1010 4749 ; define a Forth variable 1011 4749 ; 1012 4749 W_VARIABLE: 1013 4749 085641524941 db $08,"VARIABLE" 1013 474F 424C45 1014 4752 3B 47 dw W_EXECUTE 1015 4754 C_VARIABLE: 1016 4754 CD 22 46 call DOCOLON 1017 4757 41 4F dw C_CREATE 1018 4759 E8 4C dw C_COMMA 1019 475B 1A 47 dw C_EXIT 1020 475D 1021 475D ; DOVAR, code action of VARIABLE, entered by CALL 1022 475D ; DOCREATE, code action of newly created words 1023 475D DOCREATE: 1024 475D DOVAR: ; ( -- addr) 1025 475D E1 pop hl ; parameter field address 1026 475E C5 push bc ; push old TOS 1027 475F 44 ld b,h ; pfa = variable's adrs -> TOS 1028 4760 4D ld c,l 1029 4761 C3 6A 46 jp NEXT 1030 4764 1031 4764 ; ----------------- 1032 4764 ; CONSTANT (n -- ) 1033 4764 ; CREATE , DOES> (machine code fragment) 1034 4764 ; define a Forth constant 1035 4764 ; 1036 4764 W_CONSTANT: 1037 4764 08434F4E5354 db $08,"CONSTANT" 1037 476A 414E54 1038 476D 49 47 dw W_VARIABLE 1039 476F C_CONSTANT: 1040 476F CD 22 46 call DOCOLON 1041 4772 41 4F dw C_CREATE 1042 4774 E8 4C dw C_COMMA 1043 4776 72 4F dw C_XDOES 1044 4778 1045 4778 ; DOCON, code action of CONSTANT, 1046 4778 ; entered by CALL DOCON 1047 4778 E1 DOCON: pop hl ; parameter field address 1048 4779 C5 push bc ; old TOS 1049 477A 4E ld c,(hl) ; fetch contents of parameter 1050 477B 23 inc hl ; field -> TOS 1051 477C 46 ld b,(hl) 1052 477D C3 6A 46 jp NEXT 1053 4780 1054 4780 ; ------------- 1055 4780 ; EMIT (c -- ) 1056 4780 ; output character to console 1057 4780 ; 1058 4780 W_EMIT: 1059 4780 04454D4954 db $04,"EMIT" 1060 4785 64 47 dw W_CONSTANT 1061 4787 C_EMIT: 1062 4787 79 ld a,c 1063 4788 C1 pop bc ;get new TOS 1064 4789 CD 7D 45 EMIT1: call X_EMIT 1065 478C C3 6A 46 jp NEXT 1066 478F 1067 478F ; ------------ 1068 478F ; CLS ( -- ) 1069 478F ; Clear screen 1070 478F ; 1071 478F W_CLS: 1072 478F 03 43 4C 53 db $03,"CLS" 1073 4793 80 47 dw W_EMIT 1074 4795 C_CLS: 1075 4795 C5 push bc 1076 4796 CD 66 45 call X_CLS 1077 4799 C1 pop bc 1078 479A C3 6A 46 jp NEXT 1079 479D 1080 479D ; ------------ 1081 479D ; KEY ( -- c) 1082 479D ; get character from keyboard 1083 479D ; 1084 479D W_KEY: 1085 479D 03 4B 45 59 db $03,"KEY" 1086 47A1 8F 47 dw W_CLS 1087 47A3 C_KEY: 1088 47A3 C5 push bc 1089 47A4 CD 34 45 call X_KEY 1090 47A7 06 00 ld b,$00 1091 47A9 4F ld c,a 1092 47AA C3 6A 46 jp NEXT 1093 47AD 1094 47AD ; --------------- 1095 47AD ; DUP (x -- x x) 1096 47AD ; duplicate top of stack 1097 47AD ; 1098 47AD 1099 47AD W_DUP: 1100 47AD 03 44 55 50 db $03,"DUP" 1101 47B1 9D 47 dw W_KEY 1102 47B3 C_DUP: 1103 47B3 C5 push bc 1104 47B4 C3 6A 46 jp NEXT 1105 47B7 1106 47B7 ; ---------------------------- 1107 47B7 ; ?DUP (x -- 0) if zero 1108 47B7 ; (x -- x x) if nonzero 1109 47B7 ; DUP if nonzero 1110 47B7 ; 1111 47B7 W_QUERYDUP: 1112 47B7 043F445550 db $04,"?DUP" 1113 47BC AD 47 dw W_DUP 1114 47BE C_QUERYDUP: 1115 47BE 78 ld a,b 1116 47BF B1 or c 1117 47C0 20 F1 jr nz,C_DUP 1118 47C2 C3 6A 46 jp NEXT 1119 47C5 1120 47C5 ; ------------- 1121 47C5 ; DROP (x -- ) 1122 47C5 ; drop top of stack 1123 47C5 ; 1124 47C5 W_DROP: 1125 47C5 0444524F50 db $04,"DROP" 1126 47CA B7 47 dw W_QUERYDUP 1127 47CC C_DROP: 1128 47CC C1 pop bc 1129 47CD C3 6A 46 jp NEXT 1130 47D0 1131 47D0 ; ---------------------- 1132 47D0 ; SWAP (x1 x2 -- x2 x1) 1133 47D0 ; swap top two items 1134 47D0 ; 1135 47D0 W_SWAP: 1136 47D0 0453574150 db $04,"SWAP" 1137 47D5 C5 47 dw W_DROP 1138 47D7 C_SWAP: 1139 47D7 E1 pop hl 1140 47D8 C5 push bc 1141 47D9 44 ld b,h 1142 47DA 4D ld c,l 1143 47DB C3 6A 46 jp NEXT 1144 47DE 1145 47DE ; ---------------------------- 1146 47DE ; OVER (x1, x2 -- x1, x2, x1) 1147 47DE ; per stack diagram 1148 47DE ; 1149 47DE W_OVER: 1150 47DE 044F564552 db $04,"OVER" 1151 47E3 D0 47 dw W_SWAP 1152 47E5 C_OVER: 1153 47E5 1154 47E5 E1 pop hl 1155 47E6 E5 push hl 1156 47E7 C5 push bc 1157 47E8 44 ld b,h 1158 47E9 4D ld c,l 1159 47EA C3 6A 46 jp NEXT 1160 47ED 1161 47ED ; --------------------------- 1162 47ED ; ROT (x1 x2 x3 -- x2 x3 x1) 1163 47ED ; per stack diagram 1164 47ED ; 1165 47ED W_ROT: 1166 47ED 03 52 4F 54 db $03,"ROT" 1167 47F1 DE 47 dw W_OVER 1168 47F3 C_ROT: 1169 47F3 E1 pop hl 1170 47F4 E3 ex (sp),hl 1171 47F5 C5 push bc 1172 47F6 44 ld b,h 1173 47F7 4D ld c,l 1174 47F8 C3 6A 46 jp NEXT 1175 47FB 1176 47FB ; ----------------------- 1177 47FB ; >R ( n -- R: -- n ) 1178 47FB ; push to return stack 1179 47FB ; 1180 47FB W_TOR: 1181 47FB 02 3E 52 db $02,">R" 1182 47FE ED 47 dw W_ROT 1183 4800 C_TOR: 1184 4800 2A AF 43 ld hl,(RSP) 1185 4803 2B dec hl 1186 4804 70 ld (hl),b 1187 4805 2B dec hl 1188 4806 71 ld (hl),c ;/ (R1)<--(DE) 1189 4807 22 AF 43 ld (RSP),hl ; (RP)<--(RP)-2 1190 480A C1 pop bc 1191 480B C3 6A 46 jp NEXT 1192 480E 1193 480E ; ----------------------- 1194 480E ; R> ( -- n R: n -- ) 1195 480E ; pop from return stack 1196 480E ; 1197 480E W_RFROM: 1198 480E 02 52 3E db $02,"R>" 1199 4811 FB 47 dw W_TOR 1200 4813 C_RFROM: 1201 4813 C5 push bc 1202 4814 2A AF 43 ld hl,(RSP) 1203 4817 4E ld c,(hl) 1204 4818 23 inc hl 1205 4819 46 ld b,(hl) 1206 481A 23 inc hl 1207 481B 22 AF 43 ld (RSP),hl 1208 481E C3 6A 46 jp NEXT 1209 4821 1210 4821 ; ---------- 1211 4821 ; R@ ( -- n) 1212 4821 ; fetch from rtn stk 1213 4821 ; 1214 4821 W_RFETCH: 1215 4821 02 52 40 db $02,"R@" 1216 4824 0E 48 dw W_RFROM 1217 4826 C_RFETCH: 1218 4826 C5 push bc 1219 4827 2A AF 43 ld hl,(RSP) 1220 482A 4E ld c,(hl) 1221 482B 23 inc hl 1222 482C 46 ld b,(hl) 1223 482D C3 6A 46 jp NEXT 1224 4830 1225 4830 ; --------------- 1226 4830 ; SP@ ( -- addr) 1227 4830 ; get data stack pointer 1228 4830 ; 1229 4830 W_SPFETCH: 1230 4830 03 53 50 40 db $03,"SP@" 1231 4834 21 48 dw W_RFETCH 1232 4836 C_SPFETCH: 1233 4836 C5 push bc 1234 4837 21 00 00 ld hl,0 1235 483A 39 add hl,sp 1236 483B 44 ld b,h 1237 483C 4D ld c,l 1238 483D C3 6A 46 jp NEXT 1239 4840 1240 4840 ; ----------- 1241 4840 ; SP! ( -- ) 1242 4840 ; set data stack pointer to initial value (S0). 1243 4840 ; 1244 4840 W_SPSTORE: 1245 4840 03 53 50 21 db $03,"SP!" 1246 4844 30 48 dw W_SPFETCH 1247 4846 C_SPSTORE: 1248 4846 2A AB 43 ld hl,(S0) 1249 4849 F9 ld sp,hl 1250 484A E1 pop hl ; adjust SP 1251 484B C3 6A 46 jp NEXT 1252 484E 1253 484E ; ----------- 1254 484E ; RP! ( -- ) 1255 484E ; set return stack pointer to initial value (R0). 1256 484E ; 1257 484E W_RPSTORE: 1258 484E 03 52 50 21 db $03,"RP!" 1259 4852 40 48 dw W_SPSTORE 1260 4854 C_RPSTORE: 1261 4854 2A AD 43 ld hl,(R0) 1262 4857 22 AF 43 ld (RSP),hl 1263 485A C3 6A 46 jp NEXT 1264 485D 1265 485D ; --------------- 1266 485D ; ! (n addr -- ) 1267 485D ; store cell in memory 1268 485D ; 1269 485D W_STORE: 1270 485D 01 21 db $01,"!" 1271 485F 4E 48 dw W_RPSTORE 1272 4861 C_STORE: 1273 4861 60 ld h,b 1274 4862 69 ld l,c 1275 4863 C1 pop bc 1276 4864 71 ld (hl),c 1277 4865 23 inc hl 1278 4866 70 ld (hl),b 1279 4867 C1 pop bc ;new TOS 1280 4868 C3 6A 46 jp NEXT 1281 486B 1282 486B ; ----------------- 1283 486B ; C! (c addr -- ) 1284 486B ; store char in memory 1285 486B ; 1286 486B W_CSTORE: 1287 486B 02 43 21 db $02,"C!" 1288 486E 5D 48 dw W_STORE 1289 4870 C_CSTORE: 1290 4870 1291 4870 60 ld h,b ;addr in HL 1292 4871 69 ld l,c 1293 4872 C1 pop bc ;char in BC 1294 4873 71 ld (hl),c 1295 4874 C1 pop bc ;new TOS 1296 4875 C3 6A 46 jp NEXT 1297 4878 1298 4878 ; ------------- 1299 4878 ; @ (addr -- n) 1300 4878 ; fetch cell from memory 1301 4878 ; 1302 4878 W_FETCH: 1303 4878 01 40 db $01,"@" 1304 487A 6B 48 dw W_CSTORE 1305 487C C_FETCH: 1306 487C 60 ld h,b 1307 487D 69 ld l,c 1308 487E 4E ld c,(hl) 1309 487F 23 inc hl 1310 4880 46 ld b,(hl) 1311 4881 C3 6A 46 jp NEXT 1312 4884 1313 4884 ; ---------------- 1314 4884 ; C@ (addr -- b) 1315 4884 ; fetch char from memory 1316 4884 ; 1317 4884 W_CFETCH: 1318 4884 02 43 40 db $02,"C@" 1319 4887 78 48 dw W_FETCH 1320 4889 C_CFETCH: 1321 4889 0A ld a,(bc) 1322 488A 4F ld c,a 1323 488B 06 00 ld b,0 1324 488D C3 6A 46 jp NEXT 1325 4890 1326 4890 ; -------------------------- 1327 4890 ; + (n1/u1 n2/u2 -- n3/u3) 1328 4890 ; add n1+n2 1329 4890 ; 1330 4890 W_PLUS: 1331 4890 01 2B db $01,"+" 1332 4892 84 48 dw W_CFETCH 1333 4894 C_PLUS: 1334 4894 E1 pop hl 1335 4895 09 add hl,bc 1336 4896 44 ld b,h 1337 4897 4D ld c,l 1338 4898 C3 6A 46 jp NEXT 1339 489B 1340 489B ; ----------------- 1341 489B ; - (n1 n2 -- n3) 1342 489B ; subtract n1-n2 1343 489B ; 1344 489B W_MINUS: 1345 489B 01 2D db $01,"-" 1346 489D 90 48 dw W_PLUS 1347 489F C_MINUS: 1348 489F E1 pop hl 1349 48A0 A7 and a 1350 48A1 ED 42 sbc hl,bc 1351 48A3 44 ld b,h 1352 48A4 4D ld c,l 1353 48A5 C3 6A 46 jp NEXT 1354 48A8 1355 48A8 ; ------------------ 1356 48A8 ; AND (n1 n2 -- n3) 1357 48A8 ; logical AND 1358 48A8 ; 1359 48A8 W_AND: 1360 48A8 03 41 4E 44 db $03,"AND" 1361 48AC 9B 48 dw W_MINUS 1362 48AE C_AND: 1363 48AE E1 pop hl 1364 48AF 78 ld a,b 1365 48B0 A4 and h 1366 48B1 47 ld b,a 1367 48B2 79 ld a,c 1368 48B3 A5 and l 1369 48B4 4F ld c,a 1370 48B5 C3 6A 46 jp NEXT 1371 48B8 1372 48B8 ; ----------------- 1373 48B8 ; OR (n1 n2 -- n3) 1374 48B8 ; logical OR 1375 48B8 ; 1376 48B8 W_OR: 1377 48B8 02 4F 52 db $02,"OR" 1378 48BB A8 48 dw W_AND 1379 48BD C_OR: 1380 48BD E1 pop hl 1381 48BE 78 ld a,b 1382 48BF B4 or h 1383 48C0 47 ld b,a 1384 48C1 79 ld a,c 1385 48C2 B5 or l 1386 48C3 4F ld c,a 1387 48C4 C3 6A 46 jp NEXT 1388 48C7 1389 48C7 ; ------------------ 1390 48C7 ; XOR (n1 n2 -- n3) 1391 48C7 ; logical XOR 1392 48C7 ; 1393 48C7 W_XOR: 1394 48C7 03 58 4F 52 db $03,"XOR" 1395 48CB B8 48 dw W_OR 1396 48CD C_XOR: 1397 48CD E1 pop hl 1398 48CE 78 ld a,b 1399 48CF AC xor h 1400 48D0 47 ld b,a 1401 48D1 79 ld a,c 1402 48D2 AD xor l 1403 48D3 4F ld c,a 1404 48D4 C3 6A 46 jp NEXT 1405 48D7 1406 48D7 ; ------------------ 1407 48D7 ; NEGATE (x1 -- x2) 1408 48D7 ; two's complement 1409 48D7 ; 1410 48D7 W_NEGATE: 1411 48D7 064E45474154 db $06,"NEGATE" 1411 48DD 45 1412 48DE C7 48 dw W_XOR 1413 48E0 C_NEGATE: 1414 48E0 78 ld a,b 1415 48E1 2F cpl 1416 48E2 47 ld b,a 1417 48E3 79 ld a,c 1418 48E4 2F cpl 1419 48E5 4F ld c,a 1420 48E6 03 inc bc 1421 48E7 C3 6A 46 jp NEXT 1422 48EA 1423 48EA ; ---------------------- 1424 48EA ; ?NEGATE (n1 n2 -- n3) 1425 48EA ; 0< IF NEGATE THEN ; 1426 48EA ; negate n1 if n2 negative 1427 48EA ; 1428 48EA W_QNEGATE: 1429 48EA 073F4E454741 db $07,"?NEGATE" 1429 48F0 5445 1430 48F2 D7 48 dw W_NEGATE 1431 48F4 C_QNEGATE: 1432 48F4 CB 20 sla b 1433 48F6 C1 pop bc 1434 48F7 38 E7 jr c,C_NEGATE 1435 48F9 C3 6A 46 jp NEXT 1436 48FC 1437 48FC ; -------------- 1438 48FC ; 1+ (n1 -- n2) 1439 48FC ; add 1 to TOS 1440 48FC ; 1441 48FC W_ONEPLUS: 1442 48FC 02 31 2B db $02,"1+" 1443 48FF EA 48 dw W_QNEGATE 1444 4901 C_ONEPLUS: 1445 4901 1446 4901 03 inc bc 1447 4902 C3 6A 46 jp NEXT 1448 4905 1449 4905 ; -------------- 1450 4905 ; 2+ (n1 -- n2) 1451 4905 ; add 2 to TOS 1452 4905 ; 1453 4905 W_TWOPLUS: 1454 4905 02 32 2B db $02,"2+" 1455 4908 FC 48 dw W_ONEPLUS 1456 490A C_TWOPLUS: 1457 490A 1458 490A 03 inc bc 1459 490B 03 inc bc 1460 490C C3 6A 46 jp NEXT 1461 490F 1462 490F ; -------------- 1463 490F ; 1- (n1 -- n2) 1464 490F ; subtract 1 from TOS 1465 490F ; 1466 490F 1467 490F W_ONEMINUS: 1468 490F 02 31 2D db $02,"1-" 1469 4912 05 49 dw W_TWOPLUS 1470 4914 C_ONEMINUS: 1471 4914 1472 4914 0B dec bc 1473 4915 C3 6A 46 jp NEXT 1474 4918 1475 4918 ; -------------- 1476 4918 ; 2- (n1 -- n2) 1477 4918 ; subtract 2 from TOS 1478 4918 ; 1479 4918 W_TWOMINUS: 1480 4918 02 32 2D db $02,"2-" 1481 491B 0F 49 dw W_ONEMINUS 1482 491D C_TWOMINUS: 1483 491D 1484 491D 0B dec bc 1485 491E 0B dec bc 1486 491F C3 6A 46 jp NEXT 1487 4922 1488 4922 ; -------------- 1489 4922 ; 2* (n1 -- n2) 1490 4922 ; arithmetic left shift 1491 4922 ; 1492 4922 W_2STAR: 1493 4922 02 32 2A db $02,"2*" 1494 4925 18 49 dw W_TWOMINUS 1495 4927 C_2STAR: 1496 4927 1497 4927 CB 21 sla c 1498 4929 CB 10 rl b 1499 492B C3 6A 46 jp NEXT 1500 492E 1501 492E ; -------------- 1502 492E ; 2/ (n1 -- n2) 1503 492E ; arithmetic right shift 1504 492E ; 1505 492E W_2SLASH: 1506 492E 02 32 2F db $02,"2/" 1507 4931 22 49 dw W_2STAR 1508 4933 C_2SLASH: 1509 4933 1510 4933 CB 28 sra b 1511 4935 CB 19 rr c 1512 4937 C3 6A 46 jp NEXT 1513 493A 1514 493A ; --------------------- 1515 493A ; +! (n addr -- ) 1516 493A ; add cell to memory 1517 493A ; 1518 493A W_PLUSSTORE: 1519 493A 02 2B 21 db $02,"+!" 1520 493D 2E 49 dw W_2SLASH 1521 493F C_PLUSSTORE: 1522 493F 1523 493F E1 pop hl 1524 4940 0A ld a,(bc) 1525 4941 85 add a,l 1526 4942 02 ld (bc),a 1527 4943 03 inc bc 1528 4944 0A ld a,(bc) 1529 4945 8C adc a,h 1530 4946 02 ld (bc),a 1531 4947 C1 pop bc ;new TOS 1532 4948 C3 6A 46 jp NEXT 1533 494B 1534 494B ; ------------ 1535 494B ; 0= (n -- f) 1536 494B ; return true if TOS=0 1537 494B ; 1538 494B W_0EQUAL: 1539 494B 02 30 3D db $02,"0=" 1540 494E 3A 49 dw W_PLUSSTORE 1541 4950 C_0EQUAL: 1542 4950 78 ld a,b 1543 4951 B1 or c 1544 4952 01 00 00 ld bc,$0000 1545 4955 20 01 jr nz,ZEQU1 1546 4957 0B dec bc 1547 4958 C3 6A 46 ZEQU1: jp NEXT 1548 495B 1549 495B ; ------------ 1550 495B ; 0< (n -- f) 1551 495B ; true if TOS negative 1552 495B ; 1553 495B W_ZLESS: 1554 495B 02 30 3C db $02,"0<" 1555 495E 4B 49 dw W_0EQUAL 1556 4960 C_ZLESS: 1557 4960 CB 20 sla b ; sign bit -> cy flag 1558 4962 9F sbc a,a ; propagate cy through A 1559 4963 47 ld b,a ; put 0000 or FFFF in TOS 1560 4964 4F ld c,a 1561 4965 C3 6A 46 jp NEXT 1562 4968 1563 4968 ; --------------- 1564 4968 ; = (x1 x2 -- f) 1565 4968 ; test x1=x2 1566 4968 ; 1567 4968 W_EQUAL: 1568 4968 01 3D db $01,"=" 1569 496A 5B 49 dw W_ZLESS 1570 496C C_EQUAL: 1571 496C E1 pop hl 1572 496D B7 or a 1573 496E ED 42 sbc hl,bc ; x1-x2 in HL, SZVC valid 1574 4970 28 14 jr z,TOSTRUE 1575 4972 TOSFALSE: 1576 4972 01 00 00 ld bc,0 1577 4975 C3 6A 46 jp NEXT 1578 4978 1579 4978 ; --------------- 1580 4978 ; < (n1 n2 -- f) 1581 4978 ; test n1 n1 +ve, n2 -ve, rslt -ve, so n1>n2 1592 4980 ; if result positive & not OV, n1>=n2 1593 4980 ; pos. & OV => n1 -ve, n2 +ve, rslt +ve, so n1 (n1 n2 -- f) 1607 4991 ; test n1>n2, signed 1608 4991 ; 1609 4991 W_GREATER: 1610 4991 01 3E db $01,">" 1611 4993 78 49 dw W_LESS 1612 4995 C_GREATER: 1613 4995 60 ld h,b 1614 4996 69 ld l,c 1615 4997 C1 pop bc 1616 4998 C3 7D 49 jp LESS1 1617 499B 1618 499B ; --------------------------- 1619 499B ; (.") ( -- c-addr u ) 1620 499B ; R> COUNT 2DUP + >R TYPE; 1621 499B ; run-time code for ." 1622 499B ; 1623 499B W_XDOTQUOTE: 1624 499B 04282E2229 db $04,"(.",$22,")" 1625 49A0 91 49 dw W_GREATER 1626 49A2 C_XDOTQUOTE: 1627 49A2 1A ld a,(de) ;load length 1628 49A3 6F ld l,a 1629 49A4 13 SPNLP: inc de 1630 49A5 1A ld a,(de) 1631 49A6 CD 7D 45 call X_EMIT 1632 49A9 2D dec l 1633 49AA 20 F8 jr nz,SPNLP 1634 49AC 13 inc de 1635 49AD C3 6A 46 jp NEXT 1636 49B0 1637 49B0 ; --------------------------------- 1638 49B0 ; ." ( -- ) 1639 49B0 ; COMPILE (.") [ HEX ] 1640 49B0 ; 22 WORD C@ 1+ ALLOT ; IMMEDIATE 1641 49B0 ; Compile string to print 1642 49B0 ; 1643 49B0 W_DOTQUOTE: 1644 49B0 42 2E 22 db $42,".",$22 1645 49B3 9B 49 dw W_XDOTQUOTE 1646 49B5 C_DOTQUOTE: 1647 49B5 CD 22 46 call DOCOLON 1648 49B8 ED 50 dw C_COMPILE 1649 49BA A2 49 dw C_XDOTQUOTE 1650 49BC 31 47 22 00 dw C_LIT,$22 1651 49C0 0E 4D dw C_WORD 1652 49C2 89 48 dw C_CFETCH 1653 49C4 01 49 dw C_ONEPLUS 1654 49C6 DB 4C dw C_ALLOT 1655 49C8 1A 47 dw C_EXIT 1656 49CA 1657 49CA ; ----------- 1658 49CA ; BL ( -- c) 1659 49CA ; an ASCII space 1660 49CA ; 1661 49CA W_BL: 1662 49CA 02 42 4C db $02,"BL" 1663 49CD B0 49 dw W_DOTQUOTE 1664 49CF C_BL: 1665 49CF C5 push bc 1666 49D0 01 20 00 ld bc,$0020 1667 49D3 C3 6A 46 jp NEXT 1668 49D6 1669 49D6 ; --------------- 1670 49D6 ; TIB ( -- addr) 1671 49D6 ; Terminal Input Buffer 1672 49D6 ; 1673 49D6 W_TIB: 1674 49D6 03 54 49 42 db $03,"TIB" 1675 49DA CA 49 dw W_BL 1676 49DC C_TIB: 1677 49DC C5 push bc 1678 49DD 01 B1 43 ld bc,TIB 1679 49E0 C3 6A 46 jp NEXT 1680 49E3 1681 49E3 ; --------------- 1682 49E3 ; LBP ( -- addr) 1683 49E3 ; holds a pointer into TIB 1684 49E3 ; 1685 49E3 W_LBP: 1686 49E3 03 4C 42 50 db $03,"LBP" 1687 49E7 D6 49 dw W_TIB 1688 49E9 C_LBP: 1689 49E9 C5 push bc 1690 49EA 01 B3 43 ld bc,LBP 1691 49ED C3 6A 46 jp NEXT 1692 49F0 1693 49F0 ; ---------------- 1694 49F0 ; BASE ( -- addr) 1695 49F0 ; holds conversion radix 1696 49F0 ; 1697 49F0 W_BASE: 1698 49F0 0442415345 db $04,"BASE" 1699 49F5 E3 49 dw W_LBP 1700 49F7 C_BASE: 1701 49F7 C5 push bc 1702 49F8 01 B7 43 ld bc,BASE 1703 49FB C3 6A 46 jp NEXT 1704 49FE 1705 49FE ; ----------------- 1706 49FE ; STATE ( -- addr) 1707 49FE ; holds compiler state 1708 49FE ; This holds 0 in interpret mode and -1 in compile mode 1709 49FE ; 1710 49FE W_STATE: 1711 49FE 055354415445 db $05,"STATE" 1712 4A04 F0 49 dw W_BASE 1713 4A06 C_STATE: 1714 4A06 C5 push bc 1715 4A07 01 B5 43 ld bc,STATE 1716 4A0A C3 6A 46 jp NEXT 1717 4A0D 1718 4A0D ; -------------- 1719 4A0D ; DP ( -- addr) 1720 4A0D ; the dictionary pointer, which contains the address of the next 1721 4A0D ; free memory above the dictionary. 1722 4A0D ; 1723 4A0D W_DP: 1724 4A0D 02 44 50 db $02,"DP" 1725 4A10 FE 49 dw W_STATE 1726 4A12 C_DP: 1727 4A12 C5 push bc 1728 4A13 01 BD 43 ld bc,DP 1729 4A16 C3 6A 46 jp NEXT 1730 4A19 1731 4A19 ; ------------------ 1732 4A19 ; LATEST ( -- addr) 1733 4A19 ; CURRENT @ @ ; 1734 4A19 ; last word in current vocabulary 1735 4A19 ; 1736 4A19 W_LATEST: 1737 4A19 064C41544553 db $06,"LATEST" 1737 4A1F 54 1738 4A20 0D 4A dw W_DP 1739 4A22 C_LATEST: 1740 4A22 CD 22 46 call DOCOLON 1741 4A25 48 4A dw C_CURRENT 1742 4A27 7C 48 dw C_FETCH 1743 4A29 7C 48 dw C_FETCH 1744 4A2B 1A 47 dw C_EXIT 1745 4A2D 1746 4A2D ; ------------------- 1747 4A2D ; CONTEXT ( -- addr) 1748 4A2D ; A system variable pointing to the context vocabulary 1749 4A2D ; 1750 4A2D W_CONTEXT: 1751 4A2D 07434F4E5445 db $07,"CONTEXT" 1751 4A33 5854 1752 4A35 19 4A dw W_LATEST 1753 4A37 C_CONTEXT: 1754 4A37 C5 push bc 1755 4A38 01 BF 43 ld bc,CONTEXT 1756 4A3B C3 6A 46 jp NEXT 1757 4A3E 1758 4A3E ; ------------------- 1759 4A3E ; CURRENT ( -- addr) 1760 4A3E ; A system variable pointing to the current vocabulary 1761 4A3E ; 1762 4A3E W_CURRENT: 1763 4A3E 074355525245 db $07,"CURRENT" 1763 4A44 4E54 1764 4A46 2D 4A dw W_CONTEXT 1765 4A48 C_CURRENT: 1766 4A48 C5 push bc 1767 4A49 01 C1 43 ld bc,CURRENT 1768 4A4C C3 6A 46 jp NEXT 1769 4A4F 1770 4A4F ; --------------- 1771 4A4F ; HLD ( -- addr) 1772 4A4F ; HOLD pointer 1773 4A4F ; 1774 4A4F W_HLD: 1775 4A4F 03 48 4C 44 db $03,"HLD" 1776 4A53 3E 4A dw W_CURRENT 1777 4A55 C_HLD: 1778 4A55 C5 push bc 1779 4A56 01 B9 43 ld bc,HLD 1780 4A59 C3 6A 46 jp NEXT 1781 4A5C 1782 4A5C ; --------------- 1783 4A5C ; PAD ( -- addr) 1784 4A5C ; user PAD buffer 1785 4A5C ; HERE 44 + ; 1786 4A5C ; 1787 4A5C W_PAD: 1788 4A5C 03 50 41 44 db $03,"PAD" 1789 4A60 4F 4A dw W_HLD 1790 4A62 C_PAD: 1791 4A62 CD 22 46 call DOCOLON 1792 4A65 CB 4C dw C_HERE 1793 4A67 31 47 44 00 dw C_LIT,$44 1794 4A6B 94 48 dw C_PLUS 1795 4A6D 1A 47 dw C_EXIT 1796 4A6F 1797 4A6F ; -------------- 1798 4A6F ; ABS (n -- +n) 1799 4A6F ; absolute value 1800 4A6F ; DUP ?NEGATE ; 1801 4A6F ; 1802 4A6F W_ABS: 1803 4A6F 03 41 42 53 db $03,"ABS" 1804 4A73 5C 4A dw W_PAD 1805 4A75 C_ABS: 1806 4A75 C5 push bc 1807 4A76 C3 F4 48 jp C_QNEGATE 1808 4A79 1809 4A79 ; ------------------ 1810 4A79 ; UM* (u1 u2 -- ud) 1811 4A79 ; unsigned 16x16->32 multiplication 1812 4A79 ; 1813 4A79 W_UMSTAR: 1814 4A79 03 55 4D 2A db $03,"UM*" 1815 4A7D 6F 4A dw W_ABS 1816 4A7F C_UMSTAR: 1817 4A7F C5 push bc 1818 4A80 D9 exx 1819 4A81 C1 pop bc ; u2 in BC 1820 4A82 D1 pop de ; u1 in DE 1821 4A83 21 00 00 ld hl,0 ; result will be in HLDE 1822 4A86 3E 11 ld a,17 ; loop counter 1823 4A88 B7 or a ; clear cy 1824 4A89 CB 1C umloop: rr h 1825 4A8B CB 1D rr l 1826 4A8D CB 1A rr d 1827 4A8F CB 1B rr e 1828 4A91 30 01 jr nc,noadd 1829 4A93 09 add hl,bc 1830 4A94 3D noadd: dec a 1831 4A95 20 F2 jr nz,umloop 1832 4A97 D5 push de ; lo result 1833 4A98 E5 push hl ; hi result 1834 4A99 D9 exx 1835 4A9A C1 pop bc ; put TOS back in BC 1836 4A9B EB ex de,hl ; inline NEXT 1837 4A9C 5E ld e,(hl) 1838 4A9D 23 inc hl 1839 4A9E 56 ld d,(hl) 1840 4A9F 23 inc hl 1841 4AA0 EB ex de,hl 1842 4AA1 E9 jp (hl) 1843 4AA2 1844 4AA2 ; ---------------- 1845 4AA2 ; * (n1 n2 -- n3) 1846 4AA2 ; signed multiply 1847 4AA2 ; : * UM* DROP ; 1848 4AA2 ; 1849 4AA2 W_STAR: 1850 4AA2 01 2A db $01,"*" 1851 4AA4 79 4A dw W_UMSTAR 1852 4AA6 C_STAR: 1853 4AA6 CD 22 46 call DOCOLON 1854 4AA9 7F 4A dw C_UMSTAR 1855 4AAB CC 47 dw C_DROP 1856 4AAD 1A 47 dw C_EXIT 1857 4AAF 1858 4AAF ; ------------------------ 1859 4AAF ; UM/MOD (ud u1 -- u2 u3) 1860 4AAF ; unsigned 32/16->16 multiplication 1861 4AAF ; 1862 4AAF W_UMSLASHMOD: 1863 4AAF 06554D2F4D4F db $06,"UM/MOD" 1863 4AB5 44 1864 4AB6 A2 4A dw W_STAR 1865 4AB8 C_UMSLASHMOD: 1866 4AB8 C5 push bc 1867 4AB9 D9 exx 1868 4ABA C1 pop bc ; BC = divisor 1869 4ABB E1 pop hl ; HLDE = dividend 1870 4ABC D1 pop de 1871 4ABD 3E 10 ld a,16 ; loop counter 1872 4ABF CB 23 sla e 1873 4AC1 CB 12 rl d ; hi bit DE -> carry 1874 4AC3 ED 6A udloop: adc hl,hl ; rot left w/ carry 1875 4AC5 30 06 jr nc,udiv3 1876 4AC7 ; case 1: 17 bit, cy:HL = 1xxxx 1877 4AC7 B7 or a ; we know we can subtract 1878 4AC8 ED 42 sbc hl,bc 1879 4ACA B7 or a ; clear cy to indicate sub ok 1880 4ACB 18 06 jr udiv4 1881 4ACD ; case 2: 16 bit, cy:HL = 0xxxx 1882 4ACD ED 42 udiv3: sbc hl,bc ; try the subtract 1883 4ACF 30 02 jr nc,udiv4 ; if no cy, subtract ok 1884 4AD1 09 add hl,bc ; else cancel the subtract 1885 4AD2 37 scf ; and set cy to indicate 1886 4AD3 CB 13 udiv4: rl e ; rotate result bit into DE, 1887 4AD5 CB 12 rl d ; and next bit of DE into cy 1888 4AD7 3D dec a 1889 4AD8 20 E9 jr nz,udloop 1890 4ADA ; now have complemented quotient in DE, 1891 4ADA ; and remainder in HL 1892 4ADA 7A ld a,d 1893 4ADB 2F cpl 1894 4ADC 47 ld b,a 1895 4ADD 7B ld a,e 1896 4ADE 2F cpl 1897 4ADF 4F ld c,a 1898 4AE0 E5 push hl ; push remainder 1899 4AE1 C5 push bc 1900 4AE2 D9 exx 1901 4AE3 C1 pop bc ; quotient remains in TOS 1902 4AE4 EB ex de,hl ; inline NEXT 1903 4AE5 5E ld e,(hl) 1904 4AE6 23 inc hl 1905 4AE7 56 ld d,(hl) 1906 4AE8 23 inc hl 1907 4AE9 EB ex de,hl 1908 4AEA E9 jp (hl) 1909 4AEB 1910 4AEB ; ---------------------- 1911 4AEB ; /MOD (n1 n2 -- n3 n4) 1912 4AEB ; signed divide/rem'dr 1913 4AEB ; SWAP >R R@ ABS 0 ROT 1914 4AEB ; DUP R@ XOR >R ABS UM/MOD 1915 4AEB ; R> ?NEGATE SWAP 1916 4AEB ; R> ?NEGATE SWAP ; 1917 4AEB ; 1918 4AEB W_SLASHMOD: 1919 4AEB 042F4D4F44 db $04,"/MOD" 1920 4AF0 AF 4A dw W_UMSLASHMOD 1921 4AF2 C_SLASHMOD: 1922 4AF2 CD 22 46 call DOCOLON 1923 4AF5 D7 47 dw C_SWAP 1924 4AF7 00 48 dw C_TOR 1925 4AF9 26 48 dw C_RFETCH 1926 4AFB 75 4A dw C_ABS 1927 4AFD 31 47 00 00 dw C_LIT,0 1928 4B01 F3 47 dw C_ROT 1929 4B03 B3 47 dw C_DUP 1930 4B05 26 48 dw C_RFETCH 1931 4B07 CD 48 dw C_XOR 1932 4B09 00 48 dw C_TOR 1933 4B0B 75 4A dw C_ABS 1934 4B0D B8 4A dw C_UMSLASHMOD 1935 4B0F 13 48 dw C_RFROM 1936 4B11 F4 48 dw C_QNEGATE 1937 4B13 D7 47 dw C_SWAP 1938 4B15 13 48 dw C_RFROM 1939 4B17 F4 48 dw C_QNEGATE 1940 4B19 D7 47 dw C_SWAP 1941 4B1B 1A 47 dw C_EXIT 1942 4B1D 1943 4B1D ; ------------------ 1944 4B1D ; / (n1 n2 -- quot) 1945 4B1D ; signed divide 1946 4B1D ; /MOD SWAP DROP ; 1947 4B1D ; 1948 4B1D W_SLASH: 1949 4B1D 01 2F db $01,"/" 1950 4B1F EB 4A dw W_SLASHMOD 1951 4B21 C_SLASH: 1952 4B21 CD 22 46 call DOCOLON 1953 4B24 F2 4A dw C_SLASHMOD 1954 4B26 D7 47 dw C_SWAP 1955 4B28 CC 47 dw C_DROP 1956 4B2A 1A 47 dw C_EXIT 1957 4B2C 1958 4B2C ; ---------------------------- 1959 4B2C ; 2DUP (x1 x2 -- x1 x2 x1 x2) 1960 4B2C ; dup top 2 cells 1961 4B2C ; OVER OVER ; 1962 4B2C ; 1963 4B2C W_2DUP: 1964 4B2C 0432445550 db $04,"2DUP" 1965 4B31 1D 4B dw W_SLASH 1966 4B33 C_2DUP: 1967 4B33 E1 pop hl 1968 4B34 E5 push hl 1969 4B35 C5 push bc 1970 4B36 E5 push hl 1971 4B37 C3 6A 46 jp NEXT 1972 4B3A 1973 4B3A ; ------------------ 1974 4B3A ; 2DROP (x1 x2 -- ) 1975 4B3A ; drop top 2 cells 1976 4B3A ; DROP DROP 1977 4B3A ; 1978 4B3A W_2DROP: 1979 4B3A 053244524F50 db $05,"2DROP" 1980 4B40 2C 4B dw W_2DUP 1981 4B42 C_2DROP: 1982 4B42 C1 pop bc 1983 4B43 C1 pop bc 1984 4B44 C3 6A 46 jp NEXT 1985 4B47 1986 4B47 ; ------------------------- 1987 4B47 ; COUNT (addr1 -- addr2 n) 1988 4B47 ; counted->adr/len 1989 4B47 ; DUP 1+ SWAP C@ ; 1990 4B47 ; 1991 4B47 W_COUNT: 1992 4B47 05434F554E54 db $05,"COUNT" 1993 4B4D 3A 4B dw W_2DROP 1994 4B4F C_COUNT: 1995 4B4F 0A ld a,(bc) 1996 4B50 03 inc bc 1997 4B51 C5 push bc 1998 4B52 4F ld c,a 1999 4B53 06 00 ld b,0 2000 4B55 C3 6A 46 jp NEXT 2001 4B58 2002 4B58 ; ------------ 2003 4B58 ; CR ( -- ) 2004 4B58 ; output newline 2005 4B58 ; 2006 4B58 W_CR: 2007 4B58 02 43 52 db $02,"CR" 2008 4B5B 47 4B dw W_COUNT 2009 4B5D C_CR: 2010 4B5D 3E 0D ld a,$0d 2011 4B5F CD 7D 45 call X_EMIT 2012 4B62 C3 6A 46 jp NEXT 2013 4B65 2014 4B65 ; ------------- 2015 4B65 ; SPACE ( -- ) 2016 4B65 ; 20 EMIT ; 2017 4B65 ; output a space 2018 4B65 ; 2019 4B65 W_SPACE: 2020 4B65 055350414345 db $05,"SPACE" 2021 4B6B 58 4B dw W_CR 2022 4B6D C_SPACE: 2023 4B6D 3E 20 ld a,$20 2024 4B6F C3 89 47 jp EMIT1 2025 4B72 2026 4B72 ; ------------------- 2027 4B72 ; INPUT (c-addr -- ) 2028 4B72 ; get line from terminal until the ENTER key is pressed 2029 4B72 ; 2030 4B72 W_INPUT: 2031 4B72 05494E505554 db $05,"INPUT" 2032 4B78 65 4B dw W_SPACE 2033 4B7A C_INPUT: 2034 4B7A 2035 4B7A D5 push de ; save IP 2036 4B7B 60 ld h,b 2037 4B7C 69 ld l,c 2038 4B7D 2039 4B7D 3E 80 INP4: ld a,$80 ; print cursor 2040 4B7F CD 7D 45 call X_EMIT ; 2041 4B82 CD 34 45 INP3: call X_KEY ; wait for a key 2042 4B85 FE 20 cp $20 ; jump if a printable character 2043 4B87 30 22 jr nc,INP1 ; 2044 4B89 FE 08 cp $08 ; Backspace ? 2045 4B8B 28 14 jr z,INP2 ; 2046 4B8D D6 0D sub $0d ; ENTER ? 2047 4B8F 20 F1 jr nz,INP3 ; 2048 4B91 2049 4B91 ;ENTER ($0D) was pressed 2050 4B91 77 ld (hl),a ; terminate the input string with zero 2051 4B92 3E 08 ld a,$08 ; Backspace (clear cursor) 2052 4B94 CD 7D 45 call X_EMIT ; 2053 4B97 3E 20 ld a,$20 ; print a space 2054 4B99 CD 7D 45 call X_EMIT ; 2055 4B9C D1 pop de ; restore IP 2056 4B9D C1 pop bc ; new TOS 2057 4B9E C3 6A 46 jp NEXT 2058 4BA1 2059 4BA1 E5 INP2: push hl ; is in the start of the input buffer? 2060 4BA2 A7 and a ; 2061 4BA3 ED 42 sbc hl,bc ; 2062 4BA5 E1 pop hl ; 2063 4BA6 28 DA jr z,INP3 ; 2064 4BA8 2065 4BA8 2B dec hl ; decrement pointer 2066 4BA9 18 02 jr INP5 ; 2067 4BAB 2068 4BAB 77 INP1: ld (hl),a ; save character in input buffer 2069 4BAC 23 inc hl ; and increment pointer 2070 4BAD 5F INP5: ld e,a 2071 4BAE 3E 08 ld a,$08 ; clear o cursor 2072 4BB0 CD 7D 45 call X_EMIT 2073 4BB3 7B ld a,e ; print character 2074 4BB4 CD 7D 45 call X_EMIT 2075 4BB7 18 C4 jr INP4 2076 4BB9 2077 4BB9 ; --------------------- 2078 4BB9 ; TYPE (c-addr +n -- ) type line to terminal 2079 4BB9 ; ?DUP 2080 4BB9 ; IF OVER + SWAP 2081 4BB9 ; DO I C@ EMIT LOOP 2082 4BB9 ; ELSE DROP 2083 4BB9 ; THEN ; 2084 4BB9 ; 2085 4BB9 W_TYPE: 2086 4BB9 0454595045 db $04,"TYPE" 2087 4BBE 72 4B dw W_INPUT 2088 4BC0 C_TYPE: 2089 4BC0 E1 pop hl 2090 4BC1 78 ld a,b 2091 4BC2 B1 or c 2092 4BC3 28 03 jr z,TYPE1 2093 4BC5 CD E8 45 call PR_STRING 2094 4BC8 C1 TYPE1: pop bc 2095 4BC9 C3 6A 46 jp NEXT 2096 4BCC 2097 4BCC ; -------------------------- 2098 4BCC ; UD/MOD (ud1 u2 -- u3 ud4) 32/16->32 divide 2099 4BCC ; >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ; 2100 4BCC ; An unsigned mixed magnitude math operation which leaves a double 2101 4BCC ; quotient ud4 and remainder u3, from a double dividend ud1 and single 2102 4BCC ; divisor u2. 2103 4BCC ; 2104 4BCC W_UDSLASHMOD: 2105 4BCC 0655442F4D4F db $06,"UD/MOD" 2105 4BD2 44 2106 4BD3 B9 4B dw W_TYPE 2107 4BD5 C_UDSLASHMOD: 2108 4BD5 CD 22 46 call DOCOLON 2109 4BD8 00 48 dw C_TOR 2110 4BDA 31 47 00 00 dw C_LIT,0 2111 4BDE 26 48 dw C_RFETCH 2112 4BE0 B8 4A dw C_UMSLASHMOD 2113 4BE2 F3 47 dw C_ROT 2114 4BE4 F3 47 dw C_ROT 2115 4BE6 13 48 dw C_RFROM 2116 4BE8 B8 4A dw C_UMSLASHMOD 2117 4BEA F3 47 dw C_ROT 2118 4BEC 1A 47 dw C_EXIT 2119 4BEE 2120 4BEE ; ------------- 2121 4BEE ; HOLD (c -- ) 2122 4BEE ; add char to output string 2123 4BEE ; -1 HLD +! HLD @ C! ; 2124 4BEE ; 2125 4BEE W_HOLD: 2126 4BEE 04484F4C44 db $04,"HOLD" 2127 4BF3 CC 4B dw W_UDSLASHMOD 2128 4BF5 C_HOLD: 2129 4BF5 2A B9 43 HOLD1: ld hl,(HLD) 2130 4BF8 2B dec hl 2131 4BF9 22 B9 43 ld (HLD),hl 2132 4BFC 71 ld (hl),c 2133 4BFD C1 pop bc 2134 4BFE C3 6A 46 jp NEXT 2135 4C01 2136 4C01 ; ---------- 2137 4C01 ; <# ( -- ) 2138 4C01 ; begin numeric conversion 2139 4C01 ; PAD HLD ! ; 2140 4C01 ; 2141 4C01 W_LESSHARP: 2142 4C01 02 3C 23 db $02,"<#" 2143 4C04 EE 4B dw W_HOLD 2144 4C06 C_LESSHARP: 2145 4C06 CD 22 46 call DOCOLON 2146 4C09 62 4A dw C_PAD 2147 4C0B 55 4A dw C_HLD 2148 4C0D 61 48 dw C_STORE 2149 4C0F 1A 47 dw C_EXIT 2150 4C11 2151 4C11 ; ------------- 2152 4C11 ; # (d1 -- d2) 2153 4C11 ; convert 1 digit of output 2154 4C11 ; BASE @ M/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ; 2155 4C11 ; 2156 4C11 W_SHARP: 2157 4C11 01 23 db $01,"#" 2158 4C13 01 4C dw W_LESSHARP 2159 4C15 C_SHARP: 2160 4C15 CD 22 46 call DOCOLON 2161 4C18 F7 49 dw C_BASE 2162 4C1A 7C 48 dw C_FETCH 2163 4C1C D5 4B dw C_UDSLASHMOD 2164 4C1E F3 47 dw C_ROT 2165 4C20 26 4C dw C_DIG 2166 4C22 F5 4B dw C_HOLD 2167 4C24 1A 47 dw C_EXIT 2168 4C26 2169 4C26 C_DIG: 2170 4C26 79 ld a,c ; digit in A 2171 4C27 C6 30 add a,$30 ; convert to ASCII 2172 4C29 FE 3A cp $3a ; test for '9' 2173 4C2B 38 02 jr c,DIG1 ; jump if a number 2174 4C2D C6 07 add a,$07 ; else, it is a letter 2175 4C2F 4F DIG1: ld c,a ; 2176 4C30 C3 6A 46 jp NEXT ; 2177 4C33 2178 4C33 ; --------------- 2179 4C33 ; #S (d1 -- d2) 2180 4C33 ; convert remaining digits 2181 4C33 ; BEGIN # 2DUP OR 0= UNTIL ; 2182 4C33 ; 2183 4C33 W_SHARPS: 2184 4C33 02 23 53 db $02,"#S" 2185 4C36 11 4C dw W_SHARP 2186 4C38 C_SHARPS: 2187 4C38 CD 22 46 call DOCOLON 2188 4C3B 15 4C SHRPS1: dw C_SHARP ;BEGIN 2189 4C3D 33 4B dw C_2DUP 2190 4C3F BD 48 dw C_OR 2191 4C41 50 49 dw C_0EQUAL 2192 4C43 63 46 3B 4C dw C_0BRANCH,SHRPS1 ;UNTIL 2193 4C47 1A 47 dw C_EXIT 2194 4C49 2195 4C49 ; ------------------------ 2196 4C49 ; #> (0,0 -- addr, count) 2197 4C49 ; end conversion, get string 2198 4C49 ; 2DROP HLD @ PAD OVER - ; 2199 4C49 ; 2200 4C49 W_SHARPGT: 2201 4C49 02 23 3E db $02,"#>" 2202 4C4C 33 4C dw W_SHARPS 2203 4C4E C_SHARPGT: 2204 4C4E CD 22 46 call DOCOLON 2205 4C51 42 4B dw C_2DROP 2206 4C53 55 4A dw C_HLD 2207 4C55 7C 48 dw C_FETCH 2208 4C57 62 4A dw C_PAD 2209 4C59 E5 47 dw C_OVER 2210 4C5B 9F 48 dw C_MINUS 2211 4C5D 1A 47 dw C_EXIT 2212 4C5F 2213 4C5F ; ------------- 2214 4C5F ; SIGN (n -- ) 2215 4C5F ; add minus sign if n<0 2216 4C5F ; 0< IF ASCII - HOLD THEN ; 2217 4C5F ; 2218 4C5F W_SIGN: 2219 4C5F 045349474E db $04,"SIGN" 2220 4C64 49 4C dw W_SHARPGT 2221 4C66 C_SIGN: 2222 4C66 CB 10 rl b 2223 4C68 0E 2D ld c,'-' 2224 4C6A DA F5 4B jp c,HOLD1 2225 4C6D C1 pop bc 2226 4C6E C3 6A 46 jp NEXT 2227 4C71 2228 4C71 ; ----------- 2229 4C71 ; U. (u -- ) 2230 4C71 ; display u unsigned 2231 4C71 ; <# 0 #S #> TYPE SPACE ; 2232 4C71 ; 2233 4C71 W_UDOT: 2234 4C71 02 55 2E db $02,"U." 2235 4C74 5F 4C dw W_SIGN 2236 4C76 C_UDOT: 2237 4C76 CD 22 46 call DOCOLON 2238 4C79 06 4C dw C_LESSHARP 2239 4C7B 31 47 00 00 dw C_LIT,0 2240 4C7F 38 4C dw C_SHARPS 2241 4C81 4E 4C dw C_SHARPGT 2242 4C83 C0 4B dw C_TYPE 2243 4C85 6D 4B dw C_SPACE 2244 4C87 1A 47 dw C_EXIT 2245 4C89 2246 4C89 ; ---------- 2247 4C89 ; . (n -- ) 2248 4C89 ; display n signed 2249 4C89 ; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ; 2250 4C89 ; 2251 4C89 W_DOT: 2252 4C89 01 2E db $01,"." 2253 4C8B 71 4C dw W_UDOT 2254 4C8D C_DOT: 2255 4C8D CD 22 46 call DOCOLON 2256 4C90 06 4C dw C_LESSHARP 2257 4C92 B3 47 dw C_DUP 2258 4C94 75 4A dw C_ABS 2259 4C96 31 47 00 00 dw C_LIT,0 2260 4C9A 38 4C dw C_SHARPS 2261 4C9C F3 47 dw C_ROT 2262 4C9E 66 4C dw C_SIGN 2263 4CA0 4E 4C dw C_SHARPGT 2264 4CA2 C0 4B dw C_TYPE 2265 4CA4 6D 4B dw C_SPACE 2266 4CA6 1A 47 dw C_EXIT 2267 4CA8 2268 4CA8 ; --------------- 2269 4CA8 ; DECIMAL ( -- ) 2270 4CA8 ; set number base to decimal 2271 4CA8 ; 0A BASE ! ; 2272 4CA8 ; 2273 4CA8 W_DECIMAL: 2274 4CA8 07444543494D db $07,"DECIMAL" 2274 4CAE 414C 2275 4CB0 89 4C dw W_DOT 2276 4CB2 C_DECIMAL: 2277 4CB2 3E 0A ld a,$0a 2278 4CB4 32 B7 43 DEC1: ld (BASE),a ; assumes base<256 (acceptable) 2279 4CB7 C3 6A 46 jp NEXT 2280 4CBA 2281 4CBA ; ----------- 2282 4CBA ; HEX ( -- ) 2283 4CBA ; set number base to hexadecimal 2284 4CBA ; 10 BASE ! ; 2285 4CBA W_HEX: 2286 4CBA 03 48 45 58 db $03,"HEX" 2287 4CBE A8 4C dw W_DECIMAL 2288 4CC0 C_HEX: 2289 4CC0 3E 10 ld a,$10 2290 4CC2 18 F0 jr DEC1 2291 4CC4 2292 4CC4 ; ---------------- 2293 4CC4 ; HERE ( -- addr) 2294 4CC4 ; returns dictionary ptr 2295 4CC4 ; DP @ ; 2296 4CC4 ; 2297 4CC4 W_HERE: 2298 4CC4 0448455245 db $04,"HERE" 2299 4CC9 BA 4C dw W_HEX 2300 4CCB C_HERE: 2301 4CCB C5 push bc 2302 4CCC ED 4B BD 43 ld bc,(DP) 2303 4CD0 C3 6A 46 jp NEXT 2304 4CD3 2305 4CD3 ; -------------- 2306 4CD3 ; ALLOT (n -- ) 2307 4CD3 ; allocate n bytes in dictionary 2308 4CD3 ; DP +! ; 2309 4CD3 ; 2310 4CD3 W_ALLOT: 2311 4CD3 05414C4C4F54 db $05,"ALLOT" 2312 4CD9 C4 4C dw W_HERE 2313 4CDB C_ALLOT: 2314 4CDB CD 22 46 call DOCOLON 2315 4CDE 12 4A dw C_DP 2316 4CE0 3F 49 dw C_PLUSSTORE 2317 4CE2 1A 47 dw C_EXIT 2318 4CE4 2319 4CE4 ; ---------- 2320 4CE4 ; , (n -- ) 2321 4CE4 ; append cell to dictionary 2322 4CE4 ; 2323 4CE4 W_COMMA: 2324 4CE4 01 2C db $01,"," 2325 4CE6 D3 4C dw W_ALLOT 2326 4CE8 C_COMMA: 2327 4CE8 2A BD 43 ld hl,(DP) 2328 4CEB 71 ld (hl),c 2329 4CEC 23 inc hl 2330 4CED 70 ld (hl),b 2331 4CEE 23 inc hl 2332 4CEF 22 BD 43 ld (DP),hl 2333 4CF2 C1 pop bc 2334 4CF3 C3 6A 46 jp NEXT 2335 4CF6 2336 4CF6 ; -------------- 2337 4CF6 ; C, ( c -- ) 2338 4CF6 ; append char to dictionary 2339 4CF6 ; 2340 4CF6 W_CCOMMA: 2341 4CF6 02 43 2C db $02,"C," 2342 4CF9 E4 4C dw W_COMMA 2343 4CFB C_CCOMMA: 2344 4CFB 2345 4CFB 2A BD 43 ld hl,(DP) 2346 4CFE 71 ld (hl),c 2347 4CFF 23 inc hl 2348 4D00 22 BD 43 ld (DP),hl 2349 4D03 C1 pop bc ;new TOS 2350 4D04 C3 6A 46 jp NEXT 2351 4D07 2352 4D07 ; ---------------------- 2353 4D07 ; WORD (char -- c-addr) 2354 4D07 ; word delimited by char 2355 4D07 ; 2356 4D07 W_WORD: 2357 4D07 04574F5244 db $04,"WORD" 2358 4D0C F6 4C dw W_CCOMMA 2359 4D0E C_WORD: 2360 4D0E D5 push de ; save IP 2361 4D0F 2A B3 43 ld hl,(LBP) ; save the input buffer pointer in HL 2362 4D12 7E WRD2: ld a,(hl) ; get a character 2363 4D13 B9 cp c ; compare with delimiter 2364 4D14 20 03 jr nz,WRD1 2365 4D16 23 WRD4: inc hl 2366 4D17 18 F9 jr WRD2 ; ignore delimiters before text 2367 4D19 2368 4D19 FE 20 WRD1: cp $20 ; check for control characters 2369 4D1B 30 09 jr nc,WRD3 2370 4D1D A7 and a ; NULL? 2371 4D1E 20 F6 jr nz,WRD4 ; ignore control chars (CR/LF) 2372 4D20 2A BD 43 ld hl,(DP) ; a null delimiter was found 2373 4D23 77 ld (hl),a 2374 4D24 18 1D jr WRD5 2375 4D26 2376 4D26 E5 WRD3: push hl ; save the start string address 2377 4D27 WRD7: 2378 4D27 04 inc b ; increment counter 2379 4D28 23 inc hl ; increment pointer 2380 4D29 7E ld a,(hl) ; delimiter char? 2381 4D2A B9 cp c ; 2382 4D2B 28 05 jr z,WRD6 ; 2383 4D2D FE 20 cp $20 ; control char? 2384 4D2F 30 F6 jr nc,WRD7 2385 4D31 2B dec hl 2386 4D32 2387 4D32 23 WRD6: inc hl ; 2388 4D33 22 B3 43 ld (LBP),hl ; 2389 4D36 ED 5B BD 43 ld de,(DP) ; DE = dest address of string 2390 4D3A 78 ld a,b ; save string lenght 2391 4D3B 12 ld (de),a ; 2392 4D3C 13 inc de ; copie the string 2393 4D3D E1 pop hl ; 2394 4D3E 48 ld c,b ; 2395 4D3F 06 00 ld b,$00 ; 2396 4D41 ED B0 ldir ; 2397 4D43 D1 WRD5: pop de ; restore IP 2398 4D44 ED 4B BD 43 ld bc,(DP) ; TOS = string address 2399 4D48 C3 6A 46 jp NEXT 2400 4D4B 2401 4D4B ; ---------------------------------------------- 2402 4D4B ; FIND (c-addr -- c-addr 0) if name not found 2403 4D4B ; (c-addr -- cfa 1) if immediate 2404 4D4B ; (c-addr -- cfa -1) if normal 2405 4D4B ; 2406 4D4B ; Searches the word copied at c-addr, starting from context vocabulary 2407 4D4B ; 2408 4D4B 2409 4D4B W_FIND: 2410 4D4B 0446494E44 db $04,"FIND" 2411 4D50 07 4D dw W_WORD 2412 4D52 C_FIND: 2413 4D52 D5 push de ; save IP 2414 4D53 50 ld d,b ; c-addr to DE 2415 4D54 59 ld e,c 2416 4D55 2A BF 43 ld hl,(CONTEXT) ; get the LFA of the last word in context voc. 2417 4D58 7E ld a,(hl) ; 2418 4D59 23 inc hl 2419 4D5A 66 ld h,(hl) 2420 4D5B 6F ld l,a 2421 4D5C 2422 4D5C D5 FIND4: push de ; save c-addr 2423 4D5D E5 push hl ; save dictionary word address 2424 4D5E 0E 00 ld c,$00 2425 4D60 1A ld a,(de) ; get the word lenght 2426 4D61 AE xor (hl) ; compare with length of the word in dictionary 2427 4D62 E6 BF and $bf ; mask immed bit 2428 4D64 20 1E jr nz,FIND1 ; if d'nt match, advance to next word in dictionary 2429 4D66 AE xor (hl) 2430 4D67 E6 3F and $3f 2431 4D69 47 ld b,a ; lenght at B to be a loop counter 2432 4D6A 23 FIND2: inc hl ; compare the two words 2433 4D6B 13 inc de ; 2434 4D6C 1A ld a,(de) ; 2435 4D6D BE cp (hl) ; 2436 4D6E 20 14 jr nz,FIND1 ; if d'nt match, advance to next word in dictionary 2437 4D70 10 F8 djnz FIND2 2438 4D72 2439 4D72 11 03 00 ld de,$0003 ; word match, get the CFA 2440 4D75 19 add hl,de ; 2441 4D76 D1 pop de ; restore dictionary word address 2442 4D77 C1 pop bc ; discard c-addr 2443 4D78 1A ld a,(de) ; get length 2444 4D79 E6 40 and $40 ; mask immed bit 2445 4D7B 01 01 00 ld bc,1 ; TOS = 1 (immediate word) 2446 4D7E 20 18 jr nz,FIND3 ; 2447 4D80 0B dec bc ; TOS = -1 (normal word) 2448 4D81 0B dec bc ; 2449 4D82 18 14 jr FIND3 ; 2450 4D84 E1 FIND1: pop hl ; restore dictionary word address 2451 4D85 3E 3F ld a,$3f ; mask immed/precedence bits 2452 4D87 A6 and (hl) 2453 4D88 16 00 ld d,$00 ; word length in DE 2454 4D8A 5F ld e,a ; 2455 4D8B 13 inc de ; +1 2456 4D8C 19 add hl,de ; HL = LFA 2457 4D8D 5E ld e,(hl) ; get the link to next word in dictionary 2458 4D8E 23 inc hl ; 2459 4D8F 56 ld d,(hl) ; 2460 4D90 EB ex de,hl ; 2461 4D91 D1 pop de ; restore c-addr 2462 4D92 7C ld a,h ; test for end o dictionary (link = 0) 2463 4D93 B5 or l ; 2464 4D94 20 C6 jr nz,FIND4 ; if nonzero, jump to continue the search 2465 4D96 45 ld b,l ; word not found, leave flag = 0 in TOS 2466 4D97 EB ex de,hl ; 2467 4D98 E3 FIND3: ex (sp),hl ; leave CFA/c-addr in stack and IP in HL 2468 4D99 54 ld d,h ; restore IP 2469 4D9A 5D ld e,l ; 2470 4D9B C3 6A 46 jp NEXT 2471 4D9E 2472 4D9E ; ------------------------ 2473 4D9E ; NUMBER (addr u -- d 1) conv. ok, number with a dot 2474 4D9E ; (addr u -- d -1) conv. ok, number without a dot 2475 4D9E ; ( -- 0) if convert error 2476 4D9E ; convert string to number 2477 4D9E ; 2478 4D9E W_NUMBER: 2479 4D9E 064E554D4245 db $06,"NUMBER" 2479 4DA4 52 2480 4DA5 4B 4D dw W_FIND 2481 4DA7 C_NUMBER: 2482 4DA7 2483 4DA7 E1 pop hl ; HL=addr, BC=u 2484 4DA8 D9 exx 2485 4DA9 11 00 00 ld de,0 2486 4DAC 63 ld h,e ; D'E'H'L'=ud=0 2487 4DAD 6B ld l,e ; 2488 4DAE 43 ld b,e 2489 4DAF D9 exx 2490 4DB0 7E ld a,(hl) ; 2491 4DB1 FE 2D cp '-' ; first character is minus signal? 2492 4DB3 37 scf 2493 4DB4 20 03 jr nz,NUMB1 2494 4DB6 A7 and a ; Fc=0 for negative 2495 4DB7 0B dec bc 2496 4DB8 23 inc hl 2497 4DB9 F5 NUMB1: push af ; save signal (Fc) 2498 4DBA 2499 4DBA 78 NUMB5: ld a,b 2500 4DBB B1 or c 2501 4DBC 28 33 jr z,NUMB2 2502 4DBE 7E ld a,(hl) 2503 4DBF D6 30 sub '0' 2504 4DC1 38 47 jr c,NUMB3 2505 4DC3 FE 0A cp 10 2506 4DC5 38 06 jr c,OKDIG 2507 4DC7 D6 07 sub 7 2508 4DC9 FE 0A cp 10 2509 4DCB 38 45 jr c,NUMB4 2510 4DCD 2511 4DCD D9 OKDIG: exx 2512 4DCE 4F ld c,a 2513 4DCF 3A B7 43 ld a,(BASE) ; assumes base<256 (acceptable) 2514 4DD2 3D dec a 2515 4DD3 B9 cp c 2516 4DD4 D9 exx 2517 4DD5 38 3B jr c,NUMB4 2518 4DD7 2519 4DD7 D9 exx 2520 4DD8 C5 push bc ; save C=digit to add in 2521 4DD9 D5 push de ; udH to stack 2522 4DDA 44 ld b,h 2523 4DDB 4D ld c,l ; (SP)HL=DEBC=ud, A=base-1 2524 4DDC 09 NUMB6: add hl,bc 2525 4DDD E3 ex (sp),hl 2526 4DDE ED 5A adc hl,de 2527 4DE0 E3 ex (sp),hl 2528 4DE1 3D dec a 2529 4DE2 20 F8 jr nz,NUMB6 ; (SP)HL=ud*base 2530 4DE4 D1 pop de ; DEHL=ud*base 2531 4DE5 C1 pop bc ; restore C=digit to add in 2532 4DE6 09 add hl,bc 2533 4DE7 EB ex de,hl 2534 4DE8 48 ld c,b 2535 4DE9 ED 4A adc hl,bc 2536 4DEB EB ex de,hl ; DEHL=ud*BASE+digit 2537 4DEC D9 exx 2538 4DED 23 inc hl 2539 4DEE 0B dec bc 2540 4DEF 18 C9 jr NUMB5 2541 4DF1 2542 4DF1 0B NUMB2: dec bc ; bc=-1 (will be a single number) 2543 4DF2 D9 NUMB8: exx 2544 4DF3 F1 pop af ; restore signal (Fc) 2545 4DF4 38 0E jr c,NUMB7 ; jump to NUMB6 if positive (Fc=1) 2546 4DF6 2547 4DF6 7A ld a,d 2548 4DF7 2F cpl ; negate D'E' 2549 4DF8 57 ld d,a 2550 4DF9 7B ld a,e 2551 4DFA 2F cpl 2552 4DFB 5F ld e,a 2553 4DFC 13 inc de 2554 4DFD 2555 4DFD 7C ld a,h 2556 4DFE 2F cpl ; negate H'L' 2557 4DFF 67 ld h,a 2558 4E00 7D ld a,l 2559 4E01 2F cpl 2560 4E02 6F ld l,a 2561 4E03 23 inc hl 2562 4E04 2563 4E04 E5 NUMB7: push hl 2564 4E05 D5 push de ; stack ud 2565 4E06 D9 exx 2566 4E07 C3 6A 46 jp NEXT 2567 4E0A 2568 4E0A FE FE NUMB3: cp -2 ; test for a dot at end of string 2569 4E0C 20 04 jr nz,NUMB4 2570 4E0E 79 ld a,c 2571 4E0F 3D dec a 2572 4E10 28 E0 jr z,NUMB8 2573 4E12 F1 NUMB4: pop af ; error if string not exhausted or digit not valid 2574 4E13 C3 72 49 jp TOSFALSE 2575 4E16 2576 4E16 2577 4E16 ; ----------------- 2578 4E16 ; INTERPRET ( -- ) interpret given buffer 2579 4E16 ; BEGIN 2580 4E16 ; BL WORD DUP C@ 2581 4E16 ; WHILE 2582 4E16 ; FIND ?DUP 2583 4E16 ; IF 1+ STATE @ 0= OR IF EXECUTE ELSE , THEN 2584 4E16 ; ELSE COUNT NUMBER ?DUP 2585 4E16 ; IF 1+ IF STATE @ IF SWAP DLITERAL THEN 2586 4E16 ; ELSE DROP LITERAL 2587 4E16 ; THEN 2588 4E16 ; ELSE QUESTION 2589 4E16 ; THEN 2590 4E16 ; THEN ?STACK 2591 4E16 ; REPEAT DROP ; 2592 4E16 ; 2593 4E16 W_INTERPRET: 2594 4E16 09494E544552 db $09,"INTERPRET" 2594 4E1C 50524554 2595 4E20 9E 4D dw W_NUMBER 2596 4E22 C_INTERPRET: 2597 4E22 CD 22 46 call DOCOLON 2598 4E25 CF 49 INTE7: dw C_BL ; BEGIN 2599 4E27 0E 4D dw C_WORD 2600 4E29 B3 47 dw C_DUP 2601 4E2B 89 48 dw C_CFETCH 2602 4E2D 63 46 85 4E dw C_0BRANCH,INTE1 ; WHILE 2603 4E31 52 4D dw C_FIND 2604 4E33 BE 47 dw C_QUERYDUP 2605 4E35 63 46 53 4E dw C_0BRANCH,INTE2 ; IF 2606 4E39 01 49 dw C_ONEPLUS 2607 4E3B 06 4A dw C_STATE 2608 4E3D 7C 48 dw C_FETCH 2609 4E3F 50 49 dw C_0EQUAL 2610 4E41 BD 48 dw C_OR 2611 4E43 63 46 4D 4E dw C_0BRANCH,INTE3 ; IF 2612 4E47 45 47 dw C_EXECUTE 2613 4E49 4E 46 7F 4E dw C_BRANCH,INTE4 ; ELSE 2614 4E4D E8 4C INTE3: dw C_COMMA ; THEN 2615 4E4F 4E 46 7F 4E dw C_BRANCH,INTE4 ; ELSE 2616 4E53 4F 4B INTE2: dw C_COUNT 2617 4E55 A7 4D dw C_NUMBER 2618 4E57 BE 47 dw C_QUERYDUP 2619 4E59 63 46 7D 4E dw C_0BRANCH,INTE5 ; IF 2620 4E5D 01 49 dw C_ONEPLUS 2621 4E5F 63 46 75 4E dw C_0BRANCH,INTE6 ; IF 2622 4E63 06 4A dw C_STATE 2623 4E65 7C 48 dw C_FETCH 2624 4E67 63 46 7F 4E dw C_0BRANCH,INTE4 ; IF 2625 4E6B D7 47 dw C_SWAP 2626 4E6D 08 51 dw C_LITERAL 2627 4E6F 08 51 dw C_LITERAL ; THEN 2628 4E71 4E 46 7F 4E dw C_BRANCH,INTE4 ; ELSE 2629 4E75 CC 47 INTE6: dw C_DROP 2630 4E77 08 51 dw C_LITERAL ; THEN 2631 4E79 4E 46 7F 4E dw C_BRANCH,INTE4 ; ELSE 2632 4E7D 38 51 INTE5: dw C_QUESTION ; THEN THEN 2633 4E7F 95 51 INTE4: dw C_QSTACK 2634 4E81 4E 46 25 4E dw C_BRANCH,INTE7 ; REPEAT 2635 4E85 CC 47 INTE1: dw C_DROP 2636 4E87 1A 47 dw C_EXIT 2637 4E89 2638 4E89 ;------------------------------------ 2639 4E89 ; QUIT ( -- ) 2640 4E89 ; interpret from keyboard 2641 4E89 ; RP! [COMPILE] [ 2642 4E89 ; BEGIN 2643 4E89 ; TIB @ DUP LBP ! 2644 4E89 ; CR INPUT INTERPRET 2645 4E89 ; STATE @ 0= IF CR ." OK" THEN 2646 4E89 ; AGAIN ; 2647 4E89 ; 2648 4E89 W_QUIT: 2649 4E89 0451554954 db $04,"QUIT" 2650 4E8E 16 4E dw W_INTERPRET 2651 4E90 C_QUIT: 2652 4E90 CD 22 46 call DOCOLON 2653 4E93 54 48 dw C_RPSTORE 2654 4E95 A2 4F dw C_LEFTBRKT 2655 4E97 DC 49 QLOOP: dw C_TIB 2656 4E99 7C 48 dw C_FETCH 2657 4E9B B3 47 dw C_DUP 2658 4E9D E9 49 dw C_LBP 2659 4E9F 61 48 dw C_STORE 2660 4EA1 5D 4B dw C_CR 2661 4EA3 7A 4B dw C_INPUT 2662 4EA5 22 4E dw C_INTERPRET 2663 4EA7 06 4A dw C_STATE 2664 4EA9 7C 48 dw C_FETCH 2665 4EAB 50 49 dw C_0EQUAL 2666 4EAD 63 46 B8 4E dw C_0BRANCH,QUIT1 ;IF 2667 4EB1 5D 4B dw C_CR 2668 4EB3 A2 49 dw C_XDOTQUOTE 2669 4EB5 02 4F 4B db $02,"OK" 2670 4EB8 4E 46 97 4E QUIT1: dw C_BRANCH,QLOOP ;THEN AGAIN 2671 4EBC 2672 4EBC ; ------------- 2673 4EBC ; ABORT ( -- ) clear stk & QUIT 2674 4EBC ; SP! DECIMAL setchr 2675 4EBC ; CR ." ZX81 TODDY FORTH V1.0" 2676 4EBC ; CR MEM 2677 4EBC ; QUIT ; 2678 4EBC ; 2679 4EBC W_ABORT: 2680 4EBC 0541424F5254 db $05,"ABORT" 2681 4EC2 89 4E dw W_QUIT 2682 4EC4 C_ABORT: 2683 4EC4 CD 22 46 call DOCOLON 2684 4EC7 46 48 dw C_SPSTORE 2685 4EC9 B2 4C dw C_DECIMAL 2686 4ECB F1 45 dw C_SETCHR 2687 4ECD 5D 4B dw C_CR 2688 4ECF A2 49 dw C_XDOTQUOTE 2689 4ED1 165A58383120 db $16,"ZX81 TODDY FORTH V1.0",$0d 2689 4ED7 544F44445920464F5254482056312E300D 2690 4EE8 4C 52 dw C_MEM 2691 4EEA 90 4E dw C_QUIT 2692 4EEC 2693 4EEC ; ------------ 2694 4EEC ; COLD ( -- ) 2695 4EEC ; cold start Forth system 2696 4EEC ; 2697 4EEC W_COLD: 2698 4EEC 04434F4C44 db $04,"COLD" 2699 4EF1 BC 4E dw W_ABORT 2700 4EF3 2A 04 40 C_COLD: ld hl,(RAMTOP) 2701 4EF6 22 AD 43 ld (R0),hl ; = top of return stack 2702 4EF9 22 AF 43 ld (RSP),hl 2703 4EFC 25 dec h ; RAMTOP-100h 2704 4EFD 22 AB 43 ld (S0),hl ; = top of param stack 2705 4F00 F9 ld sp,hl 2706 4F01 22 B1 43 ld (TIB),hl 2707 4F04 CD 66 45 call X_CLS 2708 4F07 C3 C4 4E jp C_ABORT 2709 4F0A 2710 4F0A ; ------------- 2711 4F0A ; ' ( -- addr) 2712 4F0A ; find word in dictionary 2713 4F0A ; BL WORD FIND 0= 2714 4F0A ; IF QUESTION THEN 2715 4F0A ; 2716 4F0A W_TICK: 2717 4F0A 01 27 db $01,"'" 2718 4F0C EC 4E dw W_COLD 2719 4F0E C_TICK: 2720 4F0E CD 22 46 call DOCOLON 2721 4F11 CF 49 dw C_BL 2722 4F13 0E 4D dw C_WORD 2723 4F15 52 4D dw C_FIND 2724 4F17 50 49 dw C_0EQUAL 2725 4F19 63 46 1F 4F dw C_0BRANCH,TICK1 2726 4F1D 38 51 dw C_QUESTION 2727 4F1F 1A 47 TICK1: dw C_EXIT 2728 4F21 2729 4F21 ; -------------- 2730 4F21 ; ASCII ( -- C) 2731 4F21 ; parse ASCII character 2732 4F21 ; BL WORD 1+ C@ LITERAL ; IMMEDIATE 2733 4F21 ; 2734 4F21 W_ASCII: 2735 4F21 454153434949 db $45,"ASCII" 2736 4F27 0A 4F dw W_TICK 2737 4F29 C_ASCII: 2738 4F29 CD 22 46 call DOCOLON 2739 4F2C CF 49 dw C_BL 2740 4F2E 0E 4D dw C_WORD 2741 4F30 01 49 dw C_ONEPLUS 2742 4F32 89 48 dw C_CFETCH 2743 4F34 08 51 dw C_LITERAL 2744 4F36 1A 47 ASC1: dw C_EXIT 2745 4F38 2746 4F38 ; -------------- 2747 4F38 ; CREATE ( -- ) create an empty definition 2748 4F38 ; LATEST 2749 4F38 ; HERE CURRENT @ ! new "latest" link 2750 4F38 ; BL WORD C@ 1+ ALLOT , name and link field 2751 4F38 ; CD C, docreate , ; code field 2752 4F38 ; 2753 4F38 W_CREATE: 2754 4F38 064352454154 db $06,"CREATE" 2754 4F3E 45 2755 4F3F 21 4F dw W_ASCII 2756 4F41 C_CREATE: 2757 4F41 CD 22 46 call DOCOLON 2758 4F44 22 4A dw C_LATEST 2759 4F46 CB 4C dw C_HERE 2760 4F48 48 4A dw C_CURRENT 2761 4F4A 7C 48 dw C_FETCH 2762 4F4C 61 48 dw C_STORE 2763 4F4E CF 49 dw C_BL 2764 4F50 0E 4D dw C_WORD 2765 4F52 89 48 dw C_CFETCH 2766 4F54 01 49 dw C_ONEPLUS 2767 4F56 DB 4C dw C_ALLOT 2768 4F58 E8 4C dw C_COMMA 2769 4F5A 31 47 CD 00 dw C_LIT,$cd 2770 4F5E FB 4C dw C_CCOMMA 2771 4F60 31 47 5D 47 dw C_LIT,DOCREATE 2772 4F64 E8 4C dw C_COMMA 2773 4F66 1A 47 dw C_EXIT 2774 4F68 2775 4F68 ; --------------- 2776 4F68 ; (DOES>) ( -- ) run-time action of DOES> 2777 4F68 ; R> adrs of headless DOES> def'n 2778 4F68 ; LATEST CFA code field to fix up 2779 4F68 ; !CF ; 2780 4F68 ; 2781 4F68 W_XDOES: 2782 4F68 0728444F4553 db $07,"(DOES>)" 2782 4F6E 3E29 2783 4F70 38 4F dw W_CREATE 2784 4F72 C_XDOES: 2785 4F72 CD 22 46 call DOCOLON 2786 4F75 13 48 dw C_RFROM 2787 4F77 22 4A dw C_LATEST 2788 4F79 8C 51 dw C_CFA 2789 4F7B C8 51 dw C_STORECF 2790 4F7D 1A 47 dw C_EXIT 2791 4F7F 2792 4F7F ; ------------- 2793 4F7F ; DOES> ( -- ) change action of latest definition 2794 4F7F ; COMPILE (DOES>) dodoes 2795 4F7F ; HERE !CF 3 ALLOT ; IMMEDIATE 2796 4F7F 2797 4F7F W_DOES: 2798 4F7F 45444F45533E db $45,"DOES>" 2799 4F85 68 4F dw W_XDOES 2800 4F87 C_DOES: 2801 4F87 CD 22 46 call DOCOLON 2802 4F8A ED 50 dw C_COMPILE 2803 4F8C 72 4F dw C_XDOES 2804 4F8E 31 47 33 46 dw C_LIT,C_DODOES 2805 4F92 CB 4C dw C_HERE 2806 4F94 C8 51 dw C_STORECF 2807 4F96 31 47 03 00 dw C_LIT,3 2808 4F9A DB 4C dw C_ALLOT 2809 4F9C 1A 47 dw C_EXIT 2810 4F9E 2811 4F9E ; --------- 2812 4F9E ; [ ( -- ) 2813 4F9E ; enter interpretive state 2814 4F9E ; 0 STATE ! ; IMMEDIATE 2815 4F9E ; 2816 4F9E W_LEFTBRKT: 2817 4F9E 41 5B db $41,"[" 2818 4FA0 7F 4F dw W_DOES 2819 4FA2 C_LEFTBRKT: 2820 4FA2 21 00 00 ld hl,0 2821 4FA5 22 B5 43 LBKT1: ld (STATE),hl 2822 4FA8 C3 6A 46 jp NEXT 2823 4FAB 2824 4FAB ; --------- 2825 4FAB ; ] ( -- ) 2826 4FAB ; enter compiling state 2827 4FAB ; -1 STATE ! ; 2828 4FAB ; 2829 4FAB W_RIGHTBRKT: 2830 4FAB 01 5D db $01,"]" 2831 4FAD 9E 4F dw W_LEFTBRKT 2832 4FAF C_RIGHTBRKT: 2833 4FAF 21 FF FF ld hl,-1 2834 4FB2 18 F1 jr LBKT1 2835 4FB4 2836 4FB4 ; ----------------- 2837 4FB4 ; IMMEDIATE ( -- ). 2838 4FB4 ; make last definition immediate 2839 4FB4 ; LATEST DUP C@ 40 OR SWAP C! ; 2840 4FB4 ; 2841 4FB4 W_IMMEDIATE: 2842 4FB4 09494D4D4544 db $09,"IMMEDIATE" 2842 4FBA 49415445 2843 4FBE AB 4F dw W_RIGHTBRKT 2844 4FC0 C_IMMEDIATE: 2845 4FC0 2A C3 43 ld hl,(LAST) 2846 4FC3 7E ld a,(hl) 2847 4FC4 F6 40 or $40 2848 4FC6 77 ld (hl),a 2849 4FC7 C3 6A 46 jp NEXT 2850 4FCA 2851 4FCA ; --------- 2852 4FCA ; : ( -- ) begin a colon definition 2853 4FCA ; CURRENT @ CONTEXT ! CREATE 2854 4FCA ; LATEST DUP C@ 80 OR SWAP C! ] 2855 4FCA ; docolon LATEST CFA 1+ ! ; 2856 4FCA ; 2857 4FCA W_COLON: 2858 4FCA 01 3A db $01,":" 2859 4FCC B4 4F dw W_IMMEDIATE 2860 4FCE C_COLON: 2861 4FCE CD 22 46 call DOCOLON 2862 4FD1 48 4A dw C_CURRENT 2863 4FD3 7C 48 dw C_FETCH 2864 4FD5 37 4A dw C_CONTEXT 2865 4FD7 61 48 dw C_STORE 2866 4FD9 41 4F dw C_CREATE 2867 4FDB 22 4A dw C_LATEST 2868 4FDD B3 47 dw C_DUP 2869 4FDF 89 48 dw C_CFETCH 2870 4FE1 31 47 80 00 dw C_LIT,$80 2871 4FE5 BD 48 dw C_OR 2872 4FE7 D7 47 dw C_SWAP 2873 4FE9 70 48 dw C_CSTORE 2874 4FEB AF 4F dw C_RIGHTBRKT 2875 4FED 31 47 22 46 dw C_LIT,DOCOLON 2876 4FF1 22 4A dw C_LATEST 2877 4FF3 8C 51 dw C_CFA 2878 4FF5 01 49 dw C_ONEPLUS 2879 4FF7 61 48 dw C_STORE 2880 4FF9 1A 47 dw C_EXIT 2881 4FFB 2882 4FFB ; --------- 2883 4FFB ; ; ( -- ) end a colon definition 2884 4FFB ; LATEST DUP C@ 7F AND SWAP C! 2885 4FFB ; COMPILE EXIT [ ; IMMEDIATE 2886 4FFB ; 2887 4FFB W_SEMICOLON: 2888 4FFB 41 3B db $41,";" 2889 4FFD CA 4F dw W_COLON 2890 4FFF C_SEMICOLON: 2891 4FFF CD 22 46 call DOCOLON 2892 5002 22 4A dw C_LATEST 2893 5004 B3 47 dw C_DUP 2894 5006 89 48 dw C_CFETCH 2895 5008 31 47 7F 00 dw C_LIT,$7F 2896 500C AE 48 dw C_AND 2897 500E D7 47 dw C_SWAP 2898 5010 70 48 dw C_CSTORE 2899 5012 ED 50 dw C_COMPILE 2900 5014 1A 47 dw C_EXIT 2901 5016 A2 4F dw C_LEFTBRKT 2902 5018 1A 47 dw C_EXIT 2903 501A 2904 501A ; -------------- 2905 501A ; IF ( -- addr) 2906 501A ; conditional forward branch 2907 501A ; COMPILE 0BRANCH HERE DUP , ; IMMEDIATE 2908 501A ; 2909 501A W_IF: 2910 501A 42 49 46 db $42,"IF" 2911 501D FB 4F dw W_SEMICOLON 2912 501F C_IF: 2913 501F CD 22 46 call DOCOLON 2914 5022 ED 50 dw C_COMPILE 2915 5024 63 46 dw C_0BRANCH 2916 5026 CB 4C dw C_HERE 2917 5028 B3 47 dw C_DUP 2918 502A E8 4C dw C_COMMA 2919 502C 1A 47 dw C_EXIT 2920 502E 2921 502E ; ---------------- 2922 502E ; THEN (addr -- ) 2923 502E ; resolve forward branch 2924 502E ; HERE SWAP ! ; IMMEDIATE 2925 502E ; 2926 502E W_THEN: 2927 502E 445448454E db $44,"THEN" 2928 5033 1A 50 dw W_IF 2929 5035 C_THEN: 2930 5035 CD 22 46 call DOCOLON 2931 5038 CB 4C dw C_HERE 2932 503A D7 47 dw C_SWAP 2933 503C 61 48 dw C_STORE 2934 503E 1A 47 dw C_EXIT 2935 5040 2936 5040 ; ---------------------- 2937 5040 ; ELSE (addr1 -- addr2) 2938 5040 ; branch for IF..ELSE 2939 5040 ; COMPILE BRANCH HERE DUP , 2940 5040 ; SWAP [COMPILE] THEN ; IMMEDIATE 2941 5040 ; 2942 5040 W_ELSE: 2943 5040 44454C5345 db $44,"ELSE" 2944 5045 2E 50 dw W_THEN 2945 5047 C_ELSE: 2946 5047 CD 22 46 call DOCOLON 2947 504A ED 50 dw C_COMPILE 2948 504C 4E 46 dw C_BRANCH 2949 504E CB 4C dw C_HERE 2950 5050 B3 47 dw C_DUP 2951 5052 E8 4C dw C_COMMA 2952 5054 D7 47 dw C_SWAP 2953 5056 35 50 dw C_THEN 2954 5058 1A 47 dw C_EXIT 2955 505A 2956 505A ; ----------------- 2957 505A ; BEGIN ( -- addr) 2958 505A ; target for backward branch 2959 505A ; HERE ; IMMEDIATE 2960 505A ; 2961 505A W_BEGIN: 2962 505A 45424547494E db $45,"BEGIN" 2963 5060 40 50 dw W_ELSE 2964 5062 C_BEGIN: 2965 5062 CD 22 46 call DOCOLON 2966 5065 CB 4C dw C_HERE 2967 5067 1A 47 dw C_EXIT 2968 5069 2969 5069 ; ----------------- 2970 5069 ; UNTIL (addr -- ) 2971 5069 ; conditional backward branch 2972 5069 ; COMPILE 0BRANCH , ; IMMEDIATE 2973 5069 ; 2974 5069 W_UNTIL: 2975 5069 45554E54494C db $45,"UNTIL" 2976 506F 5A 50 dw W_BEGIN 2977 5071 C_UNTIL: 2978 5071 CD 22 46 call DOCOLON 2979 5074 ED 50 dw C_COMPILE 2980 5076 63 46 dw C_0BRANCH 2981 5078 E8 4C dw C_COMMA 2982 507A 1A 47 dw C_EXIT 2983 507C 2984 507C ; ----------------- 2985 507C ; AGAIN (addr -- ) 2986 507C ; unconditional backward branch 2987 507C ; COMPILE BRANCH , ; IMMEDIATE 2988 507C ; 2989 507C W_AGAIN: 2990 507C 45414741494E db $45,"AGAIN" 2991 5082 69 50 dw W_UNTIL 2992 5084 C_AGAIN: 2993 5084 CD 22 46 call DOCOLON 2994 5087 ED 50 dw C_COMPILE 2995 5089 4E 46 dw C_BRANCH 2996 508B E8 4C dw C_COMMA 2997 508D 1A 47 dw C_EXIT 2998 508F 2999 508F ; ----------------- 3000 508F ; WHILE ( -- addr) 3001 508F ; branch for WHILE loop 3002 508F ; COMPILE 0BRANCH HERE DUP , ; IMMEDIATE 3003 508F ; 3004 508F W_WHILE: 3005 508F 455748494C45 db $45,"WHILE" 3006 5095 7C 50 dw W_AGAIN 3007 5097 C_WHILE: 3008 5097 C3 1F 50 jp C_IF 3009 509A 3010 509A ; ------------------------- 3011 509A ; REPEAT (addr1 addr2 -- ) 3012 509A ; resolve WHILE loop 3013 509A ; SWAP [COMPILE] AGAIN 3014 509A ; [COMPILE] THEN ; IMMEDIATE 3015 509A ; 3016 509A W_REPEAT: 3017 509A 465245504541 db $46,"REPEAT" 3017 50A0 54 3018 50A1 8F 50 dw W_WHILE 3019 50A3 C_REPEAT: 3020 50A3 CD 22 46 call DOCOLON 3021 50A6 D7 47 dw C_SWAP 3022 50A8 84 50 dw C_AGAIN 3023 50AA 35 50 dw C_THEN 3024 50AC 1A 47 dw C_EXIT 3025 50AE 3026 50AE ; --------------- 3027 50AE ; DO (n1 n2 -- ) at execution 3028 50AE ; (addr -- ) at compilation 3029 50AE ; COMPILE (DO) HERE ; IMMEDIATE 3030 50AE ; 3031 50AE W_DO: 3032 50AE 42 44 4F db $42,"DO" 3033 50B1 9A 50 dw W_REPEAT 3034 50B3 C_DO: 3035 50B3 CD 22 46 call DOCOLON 3036 50B6 ED 50 dw C_COMPILE 3037 50B8 78 46 dw C_XDO 3038 50BA CB 4C dw C_HERE 3039 50BC 1A 47 dw C_EXIT 3040 50BE 3041 50BE ; ---------------- 3042 50BE ; LOOP (addr -- ) at compilation 3043 50BE ; COMPILE (LOOP) , ; IMMEDIATE 3044 50BE ; 3045 50BE W_LOOP: 3046 50BE 444C4F4F50 db $44,"LOOP" 3047 50C3 AE 50 dw W_DO 3048 50C5 C_LOOP: 3049 50C5 CD 22 46 call DOCOLON 3050 50C8 ED 50 dw C_COMPILE 3051 50CA A1 46 dw C_XLOOP 3052 50CC E8 4C dw C_COMMA 3053 50CE 1A 47 dw C_EXIT 3054 50D0 3055 50D0 ; ----------------- 3056 50D0 ; +LOOP (addr -- ) 3057 50D0 ; COMPILE (+LOOP) , ; IMMEDIATE 3058 50D0 ; 3059 50D0 W_PLOOP: 3060 50D0 452B4C4F4F50 db $45,"+LOOP" 3061 50D6 BE 50 dw W_LOOP 3062 50D8 C_PLOOP: 3063 50D8 CD 22 46 call DOCOLON 3064 50DB ED 50 dw C_COMPILE 3065 50DD CC 46 dw C_XPLOOP 3066 50DF E8 4C dw C_COMMA 3067 50E1 1A 47 dw C_EXIT 3068 50E3 3069 50E3 ; --------------- 3070 50E3 ; COMPILE ( -- ) 3071 50E3 ; append inline execution token 3072 50E3 ; R> DUP 2+ >R @ , ; 3073 50E3 ; 3074 50E3 W_COMPILE: 3075 50E3 07434F4D5049 db $07,"COMPILE" 3075 50E9 4C45 3076 50EB D0 50 dw W_PLOOP 3077 50ED C_COMPILE: 3078 50ED CD 22 46 call DOCOLON 3079 50F0 13 48 dw C_RFROM 3080 50F2 B3 47 dw C_DUP 3081 50F4 0A 49 dw C_TWOPLUS 3082 50F6 00 48 dw C_TOR 3083 50F8 7C 48 dw C_FETCH 3084 50FA E8 4C dw C_COMMA 3085 50FC 1A 47 dw C_EXIT 3086 50FE 3087 50FE ; ------------------- 3088 50FE ; LITERAL ( x -- ) 3089 50FE ; ( x -- x ) 3090 50FE ; append numeric literal if in compilation mode 3091 50FE ; STATE @ IF COMPILE LIT , THEN ; IMMEDIATE 3092 50FE ; 3093 50FE W_LITERAL: 3094 50FE 474C49544552 db $47,"LITERAL" 3094 5104 414C 3095 5106 E3 50 dw W_COMPILE 3096 5108 C_LITERAL: 3097 5108 CD 22 46 call DOCOLON 3098 510B 06 4A dw C_STATE 3099 510D 7C 48 dw C_FETCH 3100 510F 63 46 19 51 dw C_0BRANCH,LITRL1 3101 5113 ED 50 dw C_COMPILE 3102 5115 31 47 dw C_LIT 3103 5117 E8 4C dw C_COMMA 3104 5119 1A 47 LITRL1: dw C_EXIT 3105 511B 3106 511B ; ---------------- 3107 511B ; LOAD (addr -- ) 3108 511B ; interpret the text in the buffer at addr 3109 511B ; LBP ! INTERPRET ; 3110 511B ; 3111 511B W_LOAD: 3112 511B 044C4F4144 db $04,"LOAD" 3113 5120 FE 50 dw W_LITERAL 3114 5122 C_LOAD: 3115 5122 CD 22 46 call DOCOLON 3116 5125 E9 49 dw C_LBP 3117 5127 61 48 dw C_STORE 3118 5129 22 4E dw C_INTERPRET 3119 512B 1A 47 dw C_EXIT 3120 512D 3121 512D ; ----------------------------------------- 3122 512D ; QUESTION ( -- ) 3123 512D ; HERE COUNT TYPE 3F EMIT 3124 512D ; STATE @ IF LATEST DUP DP ! HERE C@ 7F 3125 512D ; AND + 1+ @ CURRENT @ ! 3126 512D ; THEN 3127 512D ; SP! QUIT ; 3128 512D ; 3129 512D W_QUESTION: 3130 512D 085155455354 db $08,"QUESTION" 3130 5133 494F4E 3131 5136 1B 51 dw W_LOAD 3132 5138 C_QUESTION: 3133 5138 CD 22 46 call DOCOLON 3134 513B CB 4C dw C_HERE 3135 513D 4F 4B dw C_COUNT 3136 513F C0 4B dw C_TYPE 3137 5141 31 47 3F 00 dw C_LIT,$3F 3138 5145 87 47 dw C_EMIT 3139 5147 06 4A QUEST1: dw C_STATE 3140 5149 7C 48 dw C_FETCH 3141 514B 63 46 6D 51 dw C_0BRANCH,QUEST2 ;IF 3142 514F 22 4A dw C_LATEST 3143 5151 B3 47 dw C_DUP 3144 5153 12 4A dw C_DP 3145 5155 61 48 dw C_STORE 3146 5157 CB 4C dw C_HERE 3147 5159 89 48 dw C_CFETCH 3148 515B 31 47 7F 00 dw C_LIT,$7f 3149 515F AE 48 dw C_AND 3150 5161 94 48 dw C_PLUS 3151 5163 01 49 dw C_ONEPLUS 3152 5165 7C 48 dw C_FETCH 3153 5167 48 4A dw C_CURRENT 3154 5169 7C 48 dw C_FETCH 3155 516B 61 48 dw C_STORE ;THEN 3156 516D 46 48 QUEST2: dw C_SPSTORE 3157 516F 90 4E dw C_QUIT 3158 5171 3159 5171 3160 5171 ; -------------------------------------------------------- 3161 5171 ; LFA (nfa -- lfa) name adr -> link field 3162 5171 ; COUNT 3F AND + mask off 'smudge' and 'immed' bits 3163 5171 ; 3164 5171 W_LFA: 3165 5171 03 4C 46 41 db $03,"LFA" 3166 5175 2D 51 dw W_QUESTION 3167 5177 C_LFA: 3168 5177 CD 22 46 call DOCOLON 3169 517A 4F 4B dw C_COUNT 3170 517C 31 47 3F 00 dw C_LIT,$3f 3171 5180 AE 48 dw C_AND 3172 5182 94 48 dw C_PLUS 3173 5184 1A 47 dw C_EXIT 3174 5186 3175 5186 ; -------------------------------------------- 3176 5186 ; CFA (nfa -- cfa) name adr -> code field 3177 5186 ; LFA 2+ ; 3178 5186 ; 3179 5186 W_CFA: 3180 5186 03 43 46 41 db $03,"CFA" 3181 518A 71 51 dw W_LFA 3182 518C C_CFA: 3183 518C CD 22 46 call DOCOLON 3184 518F 77 51 dw C_LFA 3185 5191 0A 49 dw C_TWOPLUS 3186 5193 1A 47 dw C_EXIT 3187 5195 3188 5195 ; test for empty stack 3189 5195 C_QSTACK: 3190 5195 2A AB 43 ld hl,(S0) 3191 5198 23 inc hl 3192 5199 23 inc hl 3193 519A A7 and a 3194 519B ED 72 sbc hl,sp 3195 519D D2 6A 46 jp nc,NEXT 3196 51A0 11 A6 51 ld de,QSTK1 3197 51A3 C3 A2 49 jp C_XDOTQUOTE 3198 51A6 0B454D505459QSTK1: db $0b,"EMPTY STACK" 3198 51AC 20535441434B 3199 51B2 B4 51 dw QSTK2 3200 51B4 21 47 51 QSTK2: ld hl,QUEST1 3201 51B7 E5 push hl 3202 51B8 C3 22 46 jp DOCOLON 3203 51BB ; 3204 51BB ; test for BREAK key 3205 51BB C_QTERMINAL: 3206 51BB CD 46 0F call BREAK_1 3207 51BE C5 push bc 3208 51BF 01 00 00 ld bc,0 3209 51C2 38 01 jr c,QTERM1 3210 51C4 0B dec bc 3211 51C5 C3 6A 46 QTERM1: jp NEXT 3212 51C8 3213 51C8 ; ------------------------------------------------ 3214 51C8 ; !CF (adrs cfa -- ) set code action of a word 3215 51C8 ; CD OVER C! store 'CALL adrs' instr 3216 51C8 ; 1+ ! ; 3217 51C8 ; (internal word) 3218 51C8 C_STORECF: 3219 51C8 CD 22 46 call DOCOLON 3220 51CB 31 47 CD 00 dw C_LIT,$cd 3221 51CF E5 47 dw C_OVER 3222 51D1 70 48 dw C_CSTORE 3223 51D3 01 49 dw C_ONEPLUS 3224 51D5 61 48 dw C_STORE 3225 51D7 1A 47 dw C_EXIT 3226 51D9 3227 51D9 ; -------------- 3228 51D9 ; FORGET ( -- ) Delete definition and all entries that follow it 3229 51D9 ; CURRENT @ CONTEXT ! ' 3230 51D9 ; DUP 2 - @ CURRENT @ ! 3231 51D9 ; DP @ C@ 3 + - DP ! ; 3232 51D9 ; 3233 51D9 W_FORGET: 3234 51D9 06464F524745 db $06,"FORGET" 3234 51DF 54 3235 51E0 86 51 dw W_CFA 3236 51E2 C_FORGET: 3237 51E2 CD 22 46 call DOCOLON 3238 51E5 48 4A dw C_CURRENT 3239 51E7 7C 48 dw C_FETCH 3240 51E9 37 4A dw C_CONTEXT 3241 51EB 61 48 dw C_STORE 3242 51ED 0E 4F dw C_TICK 3243 51EF B3 47 dw C_DUP 3244 51F1 31 47 02 00 dw C_LIT,2 3245 51F5 9F 48 dw C_MINUS 3246 51F7 7C 48 dw C_FETCH 3247 51F9 48 4A dw C_CURRENT 3248 51FB 7C 48 dw C_FETCH 3249 51FD 61 48 dw C_STORE 3250 51FF 12 4A dw C_DP 3251 5201 7C 48 dw C_FETCH 3252 5203 89 48 dw C_CFETCH 3253 5205 31 47 03 00 dw C_LIT,3 3254 5209 94 48 dw C_PLUS 3255 520B 9F 48 dw C_MINUS 3256 520D 12 4A dw C_DP 3257 520F 61 48 dw C_STORE 3258 5211 1A 47 dw C_EXIT 3259 5213 3260 5213 ; -------------- 3261 5213 ; VLIST ( -- ) list all words in dict. 3262 5213 ; CR LATEST BEGIN 3263 5213 ; DUP COUNT 3F AND TYPE SPACE 3264 5213 ; BEGIN ?terminal 0= UNTIL 3265 5213 ; LFA @ 3266 5213 ; ?DUP 0= UNTIL ; 3267 5213 ; 3268 5213 W_VLIST: 3269 5213 05564C495354 db $05,"VLIST" 3270 5219 D9 51 dw W_FORGET 3271 521B C_VLIST: 3272 521B CD 22 46 call DOCOLON 3273 521E 5D 4B dw C_CR 3274 5220 22 4A dw C_LATEST 3275 5222 B3 47 VLIST2: dw C_DUP ; BEGIN 3276 5224 4F 4B dw C_COUNT 3277 5226 31 47 3F 00 dw C_LIT,$3F 3278 522A AE 48 dw C_AND 3279 522C C0 4B dw C_TYPE 3280 522E 6D 4B dw C_SPACE 3281 5230 BB 51 VLIST1: dw C_QTERMINAL ; BEGIN 3282 5232 50 49 dw C_0EQUAL 3283 5234 63 46 30 52 dw C_0BRANCH,VLIST1 ; UNTIL 3284 5238 77 51 dw C_LFA 3285 523A 7C 48 dw C_FETCH 3286 523C BE 47 dw C_QUERYDUP 3287 523E 50 49 dw C_0EQUAL 3288 5240 63 46 22 52 dw C_0BRANCH,VLIST2 ; UNTIL 3289 5244 1A 47 dw C_EXIT 3290 5246 3291 5246 ; ----------- 3292 5246 ; MEM ( -- ) Print the amount of memory left. 3293 5246 ; SP@ HERE - U. ." BYTES FREE." ; 3294 5246 ; 3295 5246 W_MEM: 3296 5246 03 4D 45 4D db $03,"MEM" 3297 524A 13 52 dw W_VLIST 3298 524C C_MEM: 3299 524C CD 22 46 call DOCOLON 3300 524F 36 48 dw C_SPFETCH 3301 5251 CB 4C dw C_HERE 3302 5253 9F 48 dw C_MINUS 3303 5255 76 4C dw C_UDOT 3304 5257 A2 49 dw C_XDOTQUOTE 3305 5259 0B4259544553 db $0b,"BYTES FREE",$0d 3305 525F 20465245450D 3306 5265 1A 47 dw C_EXIT 3307 5267 3308 5267 ; ------------- 3309 5267 ; CSAVE ( -- ) 3310 5267 ; save the compiler on tape 3311 5267 ; 3312 5267 W_CSAVE: 3313 5267 054353415645 db $05,"CSAVE" 3314 526D 46 52 dw W_MEM 3315 526F C_CSAVE: 3316 526F 2A BD 43 ld hl,(DP) 3317 5272 22 14 40 ld ($4014),hl 3318 5275 D9 exx 3319 5276 CD E7 02 call SETFAST 3320 5279 CD F5 02 call SAVE-1 3321 527C CD 2B 0F call SLOW 3322 527F D9 exx 3323 5280 C3 6A 46 jp NEXT 3324 5283 3325 5283 ; ---------- 3326 5283 ; CODE ( -- ) Create code definition 3327 5283 ; CREATE -3 ALLOT ; 3328 5283 ; 3329 5283 W_CODE: 3330 5283 04434F4445 db $04,"CODE" 3331 5288 67 52 dw W_CSAVE 3332 528A C_CODE: 3333 528A CD 22 46 call DOCOLON 3334 528D 41 4F dw C_CREATE 3335 528F 31 47 FD FF dw C_LIT,-3 3336 5293 DB 4C dw C_ALLOT 3337 5295 1A 47 dw C_EXIT 3338 5297 3339 5297 ; ---------------- 3340 5297 ; NEXT ( -- ) Append "jp NEXT" in a code definition 3341 5297 ; C3 C, next , ; 3342 5297 ; 3343 5297 W_NEXT: 3344 5297 044E455854 db $04,"NEXT" 3345 529C 83 52 dw W_CODE 3346 529E C_NEXT: 3347 529E CD 22 46 call DOCOLON 3348 52A1 31 47 C3 00 dw C_LIT,$C3 3349 52A5 FB 4C dw C_CCOMMA 3350 52A7 31 47 6A 46 dw C_LIT,NEXT 3351 52AB E8 4C dw C_COMMA 3352 52AD 1A 47 dw C_EXIT 3353 52AF 3354 52AF ; --------- 3355 52AF ; \ ( -- ) Comments to end of line 3356 52AF ; 0A WORD DROP ; IMMEDIATE 3357 52AF ; 3358 52AF W_BKSLASH: 3359 52AF 41 5C db $41,$5c 3360 52B1 97 52 dw W_NEXT 3361 52B3 C_BKSLASH: 3362 52B3 CD 22 46 call DOCOLON 3363 52B6 31 47 0A 00 dw C_LIT,$0a 3364 52BA 0E 4D dw C_WORD 3365 52BC CC 47 dw C_DROP 3366 52BE 1A 47 dw C_EXIT 3367 52C0 3368 52C0 ; -------------------------------- 3369 52C0 ; ( ( -- ) 3370 52C0 ; ASCII ) WORD DROP ; IMMEDIATE 3371 52C0 ; Skip input until ) 3372 52C0 ; 3373 52C0 W_PAREN: 3374 52C0 41 28 db $41,"(" 3375 52C2 AF 52 dw W_BKSLASH 3376 52C4 C_PAREN: 3377 52C4 CD 22 46 call DOCOLON 3378 52C7 31 47 29 00 dw C_LIT,$29 3379 52CB 0E 4D dw C_WORD 3380 52CD CC 47 dw C_DROP 3381 52CF 1A 47 dw C_EXIT 3382 52D1 3383 52D1 ; ---------------------- 3384 52D1 ; .( ( -- ) 3385 52D1 ; ( HERE COUNT TYPE ; 3386 52D1 ; display comments 3387 52D1 ; 3388 52D1 W_DOTPAREN: 3389 52D1 02 2E 28 db $02,".(" 3390 52D4 C0 52 dw W_PAREN 3391 52D6 C_DOTPAREN: 3392 52D6 CD 22 46 call DOCOLON 3393 52D9 C4 52 dw C_PAREN 3394 52DB CB 4C dw C_HERE 3395 52DD 4F 4B dw C_COUNT 3396 52DF C0 4B dw C_TYPE 3397 52E1 1A 47 dw C_EXIT 3398 52E3 3399 52E3 3400 52E3 last: ; DP point here 3401 52E3 3402 52E3 ; Show code statistics when compiling 3403 52E3 3404 52E3 .ECHO "Lenght: " 3405 52E3 .ECHO (last - VERSN) 3406 52E3 .ECHO " bytes\n" 3407 52E3 3408 52E3 end tasm: Number of errors = 0