├── .gitignore ├── LICENSE.md ├── Makefile ├── NMAKE.ERR ├── NMAKE.EXE ├── README.md ├── WDCDB.INI ├── ans-forth.asm ├── ans-forth.bin ├── ans-forth.lst ├── ans-forth.map ├── build.bat ├── clean.bat ├── debug.bat ├── device.asm ├── documents └── ANS Forth 94.pdf ├── w65c816.inc ├── w65c816sxb.asm ├── w65c816sxb.inc └── w65c816sxb.lst /.gitignore: -------------------------------------------------------------------------------- 1 | /*.obj 2 | /ans-forth.sym 3 | /ans-forth.bin 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (C)2015-2016 HandCoded Software Ltd. 2 | All rights reserved. 3 | 4 | This work is made available under the terms of the Creative Commons 5 | Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 6 | following URL to see the details. 7 | 8 | http://creativecommons.org/licenses/by-nc-sa/4.0/ -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #=============================================================================== 2 | # WDC Tools Assembler Definitions 3 | #------------------------------------------------------------------------------- 4 | 5 | AS = wdc816as 6 | 7 | LD = wdcln 8 | 9 | RM = erase 10 | 11 | AS_FLAGS = -g -l 12 | 13 | LD_FLAGS = -g -t -C0300 14 | 15 | DEBUG = wdcdb.exe 16 | 17 | #=============================================================================== 18 | # Rules 19 | #------------------------------------------------------------------------------- 20 | 21 | .asm.obj: 22 | $(AS) $(AS_FLAGS) $< 23 | 24 | #=============================================================================== 25 | # Targets 26 | #------------------------------------------------------------------------------- 27 | 28 | OBJS = \ 29 | w65c816sxb.obj \ 30 | ans-forth.obj 31 | 32 | all: ans-forth.bin 33 | 34 | clean: 35 | $(RM) $(OBJS) 36 | $(RM) *.bin 37 | $(RM) *.lst 38 | 39 | debug: 40 | $(DEBUG) 41 | 42 | #=============================================================================== 43 | # Dependencies 44 | #------------------------------------------------------------------------------- 45 | 46 | ans-forth.bin: $(OBJS) 47 | $(LD) $(LD_FLAGS) -O $@ $(OBJS) 48 | 49 | w65c816sxb.obj: \ 50 | w65c816.inc \ 51 | w65c816sxb.inc \ 52 | w65c816sxb.asm 53 | 54 | ans-forth.obj: \ 55 | w65c816.inc \ 56 | device.asm \ 57 | ans-forth.asm 58 | -------------------------------------------------------------------------------- /NMAKE.ERR: -------------------------------------------------------------------------------- 1 | 1000 "syntax error : ')' missing in macro invocation" 2 | 1001 "syntax error : illegal character '%c' in macro" 3 | 1002 "syntax error : invalid macro invocation '$'" 4 | 1003 "syntax error : '=' missing in macro" 5 | 1004 "syntax error : macro name missing" 6 | 1005 "syntax error : text must follow ':' in macro" 7 | 1006 "syntax error : missing closing double quotation mark" 8 | 1007 "double quotation mark not allowed in name" 9 | 1017 "unknown directive '!%s'" 10 | 1018 "directive and/or expression part missing" 11 | 1019 "too many nested !IF blocks" 12 | 1020 "end-of-file found before next directive" 13 | 1021 "syntax error : !ELSE unexpected" 14 | 1022 "missing terminating character for string/program invocation : '%c'" 15 | 1023 "syntax error in expression" 16 | 1024 "illegal argument to !CMDSWITCHES" 17 | 1031 "filename missing (or macro is null)" 18 | 1033 "syntax error : '%s' unexpected" 19 | 1034 "syntax error : separator missing" 20 | 1035 "syntax error : expected ':' or '=' separator" 21 | 1036 "syntax error : too many names to left of '='" 22 | 1037 "syntax error : target name missing" 23 | 1038 "internal error : lexer" 24 | 1039 "internal error : parser" 25 | 1040 "internal error : macro expansion" 26 | 1041 "internal error : target building" 27 | 1042 "internal error : expression stack overflow" 28 | 1043 "internal error : temp file limit exceeded" 29 | 1045 "spawn failed : %s" 30 | 1046 "internal error : out of search handles" 31 | 1047 "argument before ')' expands to nothing" 32 | 1048 "cannot write to file '%s'" 33 | 1049 "macro or inline file too long (maximum : 64K)" 34 | 1050 "%s" 35 | 1051 "out of memory" 36 | 1052 "file '%s' not found" 37 | 1053 "file '%s' unreadable" 38 | 1054 "cannot create inline file '%s'" 39 | 1055 "out of environment space" 40 | 1056 "cannot find command processor" 41 | 1057 "cannot delete temporary file '%s'" 42 | 1058 "terminated by user" 43 | 1059 "syntax error : '}' missing in dependent" 44 | 1060 "unable to close file : '%s'" 45 | 1061 "/F option requires a filename" 46 | 1062 "missing filename with /X option" 47 | 1063 "missing macro name before '='" 48 | 1064 "MAKEFILE not found and no target specified" 49 | 1065 "invalid option '%c'" 50 | 1069 "no match found for wildcard '%s'" 51 | 1070 "cycle in macro definition '%s'" 52 | 1071 "cycle in dependency tree for target '%s'" 53 | 1072 "cycle in include files : '%s'" 54 | 1073 "don't know how to make '%s'" 55 | 1076 "name too long" 56 | 1077 "'%s' : return code '0x%x'" 57 | 1078 "constant overflow at '%s'" 58 | 1079 "illegal expression : divide by zero" 59 | 1080 "operator and/or operand usage illegal" 60 | 1081 "'%s' : program not found" 61 | 1082 "'%s' : cannot execute command; out of memory" 62 | 1083 "target macro '%s' expands to nothing" 63 | 1084 "cannot create temporary file '%s'" 64 | 1085 "cannot mix implicit and explicit rules" 65 | 1086 "inference rule cannot have dependents" 66 | 1087 "cannot have : and :: dependents for same target" 67 | 1088 "invalid separator '::' on inference rule" 68 | 1089 "cannot have build commands for directive '%s'" 69 | 1090 "cannot have dependents for directive '%s'" 70 | 1092 "too many names in rule" 71 | 1093 "cannot mix dot directives" 72 | 1094 "syntax error : only (NO)KEEP allowed here" 73 | 1095 "expanded command line '%s' too long" 74 | 1096 "cannot open inline file '%s'" 75 | 1097 "filename-parts syntax requires dependent" 76 | 1098 "illegal filename-parts syntax in '%s'" 77 | 2001 "no more file handles (too many files open)" 78 | 4001 "command file can be invoked only from command line" 79 | 4002 "resetting value of special macro '%s'" 80 | 4004 "too many rules for target '%s'" 81 | 4005 "ignoring rule '%s' (extension not in .SUFFIXES)" 82 | 4006 "special macro undefined : '%s'" 83 | 4007 "filename '%s' too long; truncating to 8.3" 84 | 4008 "removed target '%s'" 85 | 4010 "'%s' : build failed; /K specified, continuing ..." 86 | 4011 "'%s' : not all dependents available; target not built" 87 | 1 "file %s doesn't exist" 88 | 2 "'%s' is up-to-date" 89 | 3 "** %s newer than %s" 90 | 4 "%*s%-14s %*s" 91 | 5 "\ttouch %s" 92 | 6 "%*s%-14s target does not exist" 93 | 7 "\nINFERENCE RULES:\n" 94 | 8 "\nMACROS:\n" 95 | 9 "\nTARGETS:\n" 96 | 10 "\n\tcommands:\t" 97 | 11 "\n\tflags:\t" 98 | 12 "\n\tdependents:\t" 99 | 13 "%s\n" 100 | 14 "%13s = %s\n" 101 | 15 "Building: %s" 102 | 20 "fatal error" 103 | 21 "error" 104 | 22 "warning" 105 | 23 "Stop.\n" 106 | 24 "Microsoft (R) Program Maintenance Utility Version %s" 107 | 25 "Copyright (c) Microsoft Corp %s. All rights reserved.\n" 108 | 100 "Usage: %s @commandfile" 109 | 101 "\t%s [options] [/f makefile] [/x stderrfile] [macrodefs] [targets]\n" 110 | 102 "Options:\n" 111 | 103 "/A Build all evaluated targets" 112 | 104 "/B Build if time stamps are equal" 113 | 105 "/C Suppress output messages" 114 | 106 "/D Display build information" 115 | 107 "/E Override env-var macros" 116 | 108 "/HELP Display brief usage message" 117 | 109 "/I Ignore exit codes from commands" 118 | 110 "/K Build unrelated targets on error" 119 | 111 "/M Ignore extended/expanded memory" 120 | 112 "/N Display commands but do not execute" 121 | 113 "/NOLOGO Suppress copyright message" 122 | 114 "/P Display NMAKE information" 123 | 115 "/Q Check time stamps but do not build" 124 | 116 "/R Ignore predefined rules/macros" 125 | 117 "/S Suppress executed-commands display" 126 | 118 "/T Change time stamps but do not build" 127 | 119 "/V Inherit macros during recursion" 128 | 120 "/? Display brief usage message\n" 129 | 125 "%-39s%s" 130 | -------------------------------------------------------------------------------- /NMAKE.EXE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrew-jacobs/w65c816sxb-forth/9c8e4a14a3715489621c0e7bb42f1421c9d3fb75/NMAKE.EXE -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # W65C816SXB ANS Forth 2 | 3 | This project builds a Forth environment for a WDC W65C816SXB which can be 4 | accessed via a USB serial connection to the ACIA port. (I use a cheap PL2303 5 | module with jumper wires acquired from ebay). 6 | 7 | The code is split into two modules namely: 8 | 9 | - The w65c816sxb.asm file is a general purpose vector handler and UART 10 | handler (to get around hardware problems in the W65C51 ACIA chip). 11 | 12 | - The ans-forth.asm file is implements the forth environment. This file includes 13 | device.asm to implement hardware specific words. 14 | 15 | A number of include files are used to support the code, namely: 16 | 17 | - The w65c816.inc file contains useful definitions and macros for the W65C816 18 | processor. 19 | 20 | - The w65c816sxb.inc file contains hardware definitions for the WDC W65C816SXB 21 | development board. 22 | 23 | ## Current Status 24 | 25 | The code in this repository builds a functional Forth environment that can 26 | execute standard commands and compile new words. 27 | 28 | ``` 29 | 30 | W65C816SXB ANS-Forth [16.04] 31 | 32 | : STAR ( -- ) 42 EMIT ; Ok 33 | : STARS ( n -- ) 0 DO STAR LOOP ; Ok 34 | CR 7 STARS 35 | *******Ok 36 | : SQUARE ( n -- ) DUP 0 DO DUP STARS CR LOOP DROP ; Ok 37 | CR 6 SQUARE CR 38 | ****** 39 | ****** 40 | ****** 41 | ****** 42 | ****** 43 | ****** 44 | 45 | Ok 46 | ``` 47 | 48 | I will continue to add documentation, more words and debug. 49 | 50 | ## Bugs 51 | 52 | - The generation of new lines during command entry needs to be improved. 53 | -------------------------------------------------------------------------------- /WDCDB.INI: -------------------------------------------------------------------------------- 1 | [Setup] 2 | Source=. 3 | Program=ans-forth.bin 4 | Command Line= 5 | About Time=0 6 | Target=65816 7 | Simulate=0 8 | Run to Main=0 9 | Max Main Window=0 10 | Number Radix=hex 11 | C Tab Size=4 12 | Asm Tab Size=4 13 | Line Addresses=1 14 | Line Numbers=1 15 | Step in Library=1 16 | AutoSave=1 17 | AutoSave Watches=1 18 | AutoSave Breakpoints=0 19 | Update while Animating=1 20 | [Memory] 21 | memory size=0x20000 22 | shift=0 23 | chunk size=0x400 24 | number of defs=1 25 | mem01=0x0,0x1FFFF,RAM 26 | [Windows] 27 | Num=6 28 | Wind01=code,497,8,804,617,0 29 | Wind02=modules,2,508,472,166,0 30 | Wind03=data,7,287,559,217,0,0x0000078A,0 31 | Wind04=data,7,287,559,217,0,0x0000005E,0 32 | Wind05=status,8,8,320,200,0 33 | Wind06=register,344,8,146,277,0 34 | [Main Window] 35 | x=79 36 | y=49 37 | w=1330 38 | h=745 39 | [Watches] 40 | Num=1 41 | Watch01=ctype,4,$200 42 | [Code Window] 43 | x=497 44 | y=8 45 | w=804 46 | h=617 47 | cycle=0 48 | [Status Window] 49 | x=8 50 | y=8 51 | w=320 52 | h=200 53 | cycle=0 54 | [Register Window] 55 | x=344 56 | y=8 57 | w=146 58 | h=277 59 | cycle=0 60 | [Inspect Window] 61 | x=15 62 | y=449 63 | w=400 64 | h=200 65 | cycle=0 66 | [Data Window] 67 | x=7 68 | y=287 69 | w=559 70 | h=217 71 | cycle=0 72 | [Modules Window] 73 | x=2 74 | y=508 75 | w=472 76 | h=166 77 | cycle=0 78 | [Locals Window] 79 | x=0 80 | y=0 81 | w=400 82 | h=200 83 | cycle=0 84 | [Watch Window] 85 | x=1 86 | y=472 87 | w=400 88 | h=200 89 | cycle=0 90 | [Symbol Window] 91 | x=0 92 | y=0 93 | w=400 94 | h=200 95 | cycle=0 96 | [Stack Window] 97 | x=111 98 | y=338 99 | w=400 100 | h=200 101 | cycle=0 102 | -------------------------------------------------------------------------------- /ans-forth.asm: -------------------------------------------------------------------------------- 1 | ;=============================================================================== 2 | ; _ _ _ ____ _____ _ _ _ ___ _ __ 3 | ; / \ | \ | / ___| | ___|__ _ __| |_| |__ ( )( _ )/ |/ /_ 4 | ; / _ \ | \| \___ \ | |_ / _ \| '__| __| '_ \ |/ / _ \| | '_ \ 5 | ; / ___ \| |\ |___) | | _| (_) | | | |_| | | | | (_) | | (_) | 6 | ; /_/ \_\_| \_|____/ |_| \___/|_| \__|_| |_| \___/|_|\___/ 7 | ; 8 | ; A Direct Threaded ANS Forth for the WDC 65C816 9 | ;------------------------------------------------------------------------------- 10 | ; Copyright (C)2015-2016 HandCoded Software Ltd. 11 | ; All rights reserved. 12 | ; 13 | ; This work is made available under the terms of the Creative Commons 14 | ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 15 | ; following URL to see the details. 16 | ; 17 | ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 18 | ; 19 | ;=============================================================================== 20 | ; Notes: 21 | ; 22 | ; This implementation is designed to run in the 65C816's native mode with both 23 | ; the accumulator and index registers in 16-bit mode except when the word needs 24 | ; 8-bit memory access. 25 | ; 26 | ; The DP register is used for the Forth data stack is values can be accessed 27 | ; using the direct-page addressing modes. The code uses the same offsets as 28 | ; would be used with the stack relative instructions (i.e <1, <3, etc.). 29 | ; 30 | ; The Y register holds the forth instruction pointer leaving X free for general 31 | ; use in words. Some words push Y if they need an extra register. 32 | ; 33 | ; Some of the high-level definitions are based on Bradford J. Rodriguez's 34 | ; CamelForth implementations. 35 | ; 36 | ;------------------------------------------------------------------------------- 37 | 38 | pw 132 39 | inclist on 40 | maclist off 41 | 42 | chip 65816 43 | longi off 44 | longa off 45 | 46 | include "w65c816.inc" 47 | 48 | ;=============================================================================== 49 | ; Macros 50 | ;------------------------------------------------------------------------------- 51 | 52 | ; The LINK macro deposits the link section of a word header automatically 53 | ; linking the new word to the last. 54 | 55 | WORDZ set 0 ; Word counter 56 | WORD0 equ 0 ; Null address for first word 57 | 58 | LINK macro TYPE 59 | dw WORD@ ; Link 60 | db TYPE ; Type 61 | WORDZ set WORDZ+1 62 | WORD@: 63 | endm 64 | 65 | ; Deposits a word header containing the name which is linked back to the 66 | ; previous word. 67 | ; 68 | ; The WDC assembler does not handle string parameters to macros very well, 69 | ; stopping at the first comma or space in them, so some headers must be 70 | ; manually constructed. 71 | 72 | NORMAL equ $00 73 | IMMEDIATE equ $80 74 | 75 | HEADER macro LEN,NAME,TYPE 76 | LINK TYPE 77 | db LEN,NAME 78 | endm 79 | 80 | ; The CONTINUE macro is used at the end of a native word to invoke the next 81 | ; word pointer. 82 | 83 | CONTINUE macro 84 | tyx ; Copy IP to X 85 | iny 86 | iny 87 | jmp (0,x) ; Then execute word 88 | endm 89 | 90 | TRAILER macro 91 | LAST_WORD equ WORD@ 92 | endm 93 | 94 | ;=============================================================================== 95 | ; Definitions 96 | ;------------------------------------------------------------------------------- 97 | 98 | USER_SIZE equ 22 99 | DSTACK_SIZE equ 128 100 | RSTACK_SIZE equ 128 101 | 102 | TO_IN_OFFSET equ 0 103 | BASE_OFFSET equ 2 104 | BLK_OFFSET equ 4 105 | DP_OFFSET equ 6 106 | LATEST_OFFSET equ 8 107 | SCR_OFFSET equ 10 108 | SOURCEID_OFFSET equ 12 ; Input source flag 109 | STATE_OFFSET equ 14 ; Compiling/Interpreting flag 110 | BUFFER_OFFSET equ 16 ; Address of the input buffer 111 | LENGTH_OFFSET equ 18 ; Length of the input buffer 112 | HP_OFFSET equ 20 113 | 114 | TIB_SIZE equ 128 115 | PAD_SIZE equ 48 116 | 117 | ;=============================================================================== 118 | ; Data Areas 119 | ;------------------------------------------------------------------------------- 120 | 121 | page0 122 | org $00 123 | 124 | USER_AREA ds USER_SIZE ; User Variables 125 | 126 | 127 | DSTACK_START equ $0100 128 | DSTACK_END equ DSTACK_START+DSTACK_SIZE 129 | 130 | RSTACK_START equ $0180 131 | RSTACK_END equ RSTACK_START+RSTACK_SIZE 132 | 133 | 134 | data 135 | org $0200 136 | 137 | TIB_AREA: ds TIB_SIZE ; Terminal Input Buffer 138 | ds PAD_SIZE ; Pad area 139 | PAD_AREA: ds 0 140 | 141 | ;=============================================================================== 142 | ; Forth Entry Point 143 | ;------------------------------------------------------------------------------- 144 | 145 | FORTH section OFFSET $0400 146 | 147 | public Start 148 | Start: 149 | native ; Go to native mode 150 | long_ai ; And all 16-bit registers 151 | lda #RSTACK_END-1 ; Initialise return stack 152 | tcs 153 | lda #DSTACK_END-1 ; .. and data stack 154 | tcd 155 | 156 | ldy #COLD ; Then perform COLD start 157 | CONTINUE 158 | 159 | COLD: 160 | dw DECIMAL 161 | dw ZERO 162 | dw BLK 163 | dw STORE 164 | dw FALSE 165 | dw STATE 166 | dw STORE 167 | dw DO_LITERAL,NEXT_WORD 168 | dw DP 169 | dw STORE 170 | dw DO_LITERAL,LAST_WORD 171 | dw LATEST 172 | dw STORE 173 | dw CR 174 | dw CR 175 | dw DO_TITLE 176 | dw TYPE 177 | dw CR 178 | dw CR 179 | dw ABORT 180 | 181 | ;=============================================================================== 182 | ; System/User Variables 183 | ;------------------------------------------------------------------------------- 184 | 185 | ; #TIB ( -- a-addr ) 186 | ; 187 | ; a-addr is the address of a cell containing the number of characters in the 188 | ; terminal input buffer. 189 | 190 | HEADER 4,"#TIB",NORMAL 191 | HASH_TIB: jsr DO_CONSTANT 192 | dw $+2 193 | dw TIB_SIZE-2 194 | 195 | ; >IN ( -- a-addr ) 196 | ; 197 | ; a-addr is the address of a cell containing the offset in characters from the 198 | ; start of the input buffer to the start of the parse area. 199 | 200 | HEADER 3,">IN",NORMAL 201 | TO_IN: jsr DO_USER 202 | dw TO_IN_OFFSET 203 | 204 | ; BASE ( -- a-addr ) 205 | ; 206 | ; a-addr is the address of a cell containing the current number-conversion 207 | ; radix {{2...36}}. 208 | 209 | HEADER 4,"BASE",NORMAL 210 | BASE: jsr DO_USER 211 | dw BASE_OFFSET 212 | 213 | ; BLK ( -- a-addr ) 214 | ; 215 | ; a-addr is the address of a cell containing zero or the number of the mass- 216 | ; storage block being interpreted. If BLK contains zero, the input source is 217 | ; not a block and can be identified by SOURCE-ID, if SOURCE-ID is available. An 218 | ; ambiguous condition exists if a program directly alters the contents of BLK. 219 | 220 | HEADER 3,"BLK",NORMAL 221 | BLK: jsr DO_USER 222 | dw BLK_OFFSET 223 | 224 | ; (BUFFER) 225 | 226 | BUFFER: jsr DO_USER 227 | dw BUFFER_OFFSET 228 | 229 | ; DP ( -- a-addr ) 230 | ; 231 | ; Dictionary Pointer 232 | 233 | HEADER 2,"DP",NORMAL 234 | DP: jsr DO_USER 235 | dw DP_OFFSET 236 | 237 | ; HP ( -- a-addr ) 238 | ; 239 | ; Hold Pointer 240 | 241 | HP: jsr DO_USER 242 | dw HP_OFFSET 243 | 244 | ; LATEST ( -- a-addr ) 245 | 246 | HEADER 6,"LATEST",NORMAL 247 | LATEST: jsr DO_USER 248 | dw LATEST_OFFSET 249 | 250 | ; (LENGTH) 251 | 252 | LENGTH: jsr DO_USER 253 | dw LENGTH_OFFSET 254 | 255 | ; SCR ( -- a-addr ) 256 | ; 257 | ; a-addr is the address of a cell containing the block number of the block most 258 | ; recently LISTed. 259 | 260 | HEADER 3,"SCR",NORMAL 261 | SCR: jsr DO_USER 262 | dw SCR_OFFSET 263 | 264 | ; (SOURCE-ID) 265 | 266 | SOURCEID: jsr DO_USER 267 | dw SOURCEID_OFFSET 268 | 269 | ; STATE ( -- a-addr ) 270 | ; 271 | ; a-addr is the address of a cell containing the compilation-state flag. STATE 272 | ; is true when in compilation state, false otherwise. The true value in STATE 273 | ; is non-zero, but is otherwise implementation-defined. 274 | 275 | HEADER 5,"STATE",NORMAL 276 | STATE: jsr DO_USER 277 | dw STATE_OFFSET 278 | 279 | ; TIB ( -- c-addr ) 280 | ; 281 | ; c-addr is the address of the terminal input buffer. 282 | 283 | HEADER 3,"TIB",NORMAL 284 | TIB: jsr DO_CONSTANT 285 | dw TIB_AREA 286 | 287 | ;=============================================================================== 288 | ; Constants 289 | ;------------------------------------------------------------------------------- 290 | 291 | ; 0 ( -- 0 ) 292 | ; 293 | ; Push the constant value zero on the stack 294 | 295 | HEADER 1,"0",NORMAL 296 | ZERO: 297 | tdc 298 | dec a ; Make space on the stack 299 | dec a 300 | tcd 301 | stz <1 ; And create a zero value 302 | CONTINUE ; Done 303 | 304 | ; BL ( -- char ) 305 | ; 306 | ; char is the character value for a space. 307 | 308 | HEADER 2,"BL",NORMAL 309 | BL: 310 | tdc 311 | dec a ; Make space on the stack 312 | dec a 313 | tcd 314 | lda #' ' ; And save a space value 315 | sta <1 316 | CONTINUE ; Done 317 | 318 | ; FALSE ( -- false ) 319 | ; 320 | ; Return a false flag. 321 | 322 | HEADER 5,"FALSE",NORMAL 323 | FALSE: 324 | tdc 325 | dec a ; Make space on the stack 326 | dec a 327 | tcd 328 | stz <1 ; And create a false value 329 | CONTINUE ; Done 330 | 331 | ; TRUE ( -- true ) 332 | ; 333 | ; Return a true flag, a single-cell value with all bits set. 334 | 335 | HEADER 4,"TRUE",NORMAL 336 | TRUE: 337 | tdc 338 | dec a ; Make space on the stack 339 | dec a 340 | tcd 341 | stz <1 ; And create a true value 342 | dec <1 343 | CONTINUE ; Done 344 | 345 | ;=============================================================================== 346 | ; Radix 347 | ;------------------------------------------------------------------------------- 348 | 349 | ; DECIMAL ( -- ) 350 | ; 351 | ; Set the numeric conversion radix to ten (decimal). 352 | 353 | HEADER 7,"DECIMAL",NORMAL 354 | DECIMAL: jsr DO_COLON 355 | dw DO_LITERAL,10 356 | dw BASE 357 | dw STORE 358 | dw EXIT 359 | 360 | ; HEX ( -- ) 361 | ; 362 | ; Set contents of BASE to sixteen. 363 | 364 | HEADER 3,"HEX",NORMAL 365 | HEX: jsr DO_COLON 366 | dw DO_LITERAL,16 367 | dw BASE 368 | dw STORE 369 | dw EXIT 370 | 371 | ;=============================================================================== 372 | ; Memory Operations 373 | ;------------------------------------------------------------------------------- 374 | 375 | ; ! ( x a-addr -- ) 376 | ; 377 | ; Store x at a-addr. 378 | 379 | HEADER 1,"!",NORMAL 380 | STORE: 381 | lda <3 ; Fetch data value 382 | sta (1) ; .. and store 383 | tdc ; Clean up data stack 384 | inc a 385 | inc a 386 | inc a 387 | inc a 388 | tcd 389 | CONTINUE ; Done 390 | 391 | ; +! ( n|u a-addr -- ) 392 | ; 393 | ; Add n|u to the single-cell number at a-addr. 394 | 395 | HEADER 2,"+!",NORMAL 396 | PLUS_STORE: 397 | clc 398 | lda <3 ; Fetch data value 399 | adc (1) 400 | sta (1) 401 | tdc ; Clean up data stack 402 | inc a 403 | inc a 404 | inc a 405 | inc a 406 | tcd 407 | CONTINUE ; Done 408 | 409 | ; , ( x -- ) 410 | ; 411 | ; Reserve one cell of data space and store x in the cell. If the data-space 412 | ; pointer is aligned when , begins execution, it will remain aligned when , 413 | ; finishes execution. An ambiguous condition exists if the data-space pointer 414 | ; is not aligned prior to execution of ,. 415 | ; 416 | ; In this implementation is its defined as: 417 | ; 418 | ; HERE ! 1 CELLS ALLOT 419 | 420 | LINK NORMAL 421 | db 1,"," 422 | COMMA: jsr DO_COLON 423 | dw HERE 424 | dw STORE 425 | dw DO_LITERAL,1 426 | dw CELLS 427 | dw ALLOT 428 | dw EXIT 429 | 430 | ; 2! ( x1 x2 a-addr -- ) 431 | ; 432 | ; Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the next 433 | ; consecutive cell. 434 | ; 435 | ; In this implementation is its defined as: 436 | ; 437 | ; SWAP OVER ! CELL+ !. 438 | 439 | HEADER 2,"2!",NORMAL 440 | TWO_STORE: jsr DO_COLON 441 | dw SWAP 442 | dw OVER 443 | dw STORE 444 | dw CELL_PLUS 445 | dw STORE 446 | dw EXIT 447 | 448 | ; 2@ ( a-addr -- x1 x2 ) 449 | ; 450 | ; Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and x1 at 451 | ; the next consecutive cell. 452 | ; 453 | ; In this implementation is its defined as: 454 | ; 455 | ; DUP CELL+ @ SWAP @ 456 | 457 | HEADER 2,"2@",NORMAL 458 | TWO_FETCH: jsr DO_COLON 459 | dw DUP 460 | dw CELL_PLUS 461 | dw FETCH 462 | dw SWAP 463 | dw FETCH 464 | dw EXIT 465 | 466 | ; @ ( a-addr -- x ) 467 | ; 468 | ; x is the value stored at a-addr. 469 | 470 | HEADER 1,"@",NORMAL 471 | FETCH: 472 | lda (1) ; Fetch from memory 473 | sta <1 ; .. and replace top value 474 | CONTINUE ; Done 475 | 476 | ; ALLOT ( n -- ) 477 | ; 478 | ; If n is greater than zero, reserve n address units of data space. If n is 479 | ; less than zero, release |n| address units of data space. If n is zero, leave 480 | ; the data-space pointer unchanged. 481 | ; 482 | ; In this implementation its is defined as: 483 | ; 484 | ; DP +! 485 | 486 | HEADER 5,"ALLOT",NORMAL 487 | ALLOT: jsr DO_COLON 488 | dw DP 489 | dw PLUS_STORE 490 | dw EXIT 491 | 492 | ; C! ( char c-addr -- ) 493 | ; 494 | ; Store char at c-addr. When character size is smaller than cell size, only the 495 | ; number of low-order bits corresponding to character size are transferred. 496 | 497 | HEADER 2,"C!",NORMAL 498 | C_STORE: 499 | lda <3 ; Fetch the data value 500 | short_a 501 | sta (1) ; And store it 502 | long_a 503 | tdc ; Clean up the stack 504 | inc a 505 | inc a 506 | inc a 507 | inc a 508 | tcd 509 | CONTINUE ; Done 510 | 511 | ; C, ( char -- ) 512 | ; 513 | ; Reserve space for one character in the data space and store char in the 514 | ; space. If the data-space pointer is character aligned when C, begins 515 | ; execution, it will remain character aligned when C, finishes execution. 516 | ; An ambiguous condition exists if the data-space pointer is not character- 517 | ; aligned prior to execution of C, 518 | ; 519 | ; HERE C! 1 CHARS ALLOT 520 | 521 | LINK NORMAL 522 | db 2,"C," 523 | C_COMMA: jsr DO_COLON 524 | dw HERE 525 | dw C_STORE 526 | dw DO_LITERAL,1 527 | dw CHARS 528 | dw ALLOT 529 | dw EXIT 530 | 531 | ; C@ ( c-addr -- char ) 532 | ; 533 | ; Fetch the character stored at c-addr. When the cell size is greater than 534 | ; character size, the unused high-order bits are all zeroes. 535 | 536 | HEADER 2,"C@",NORMAL 537 | C_FETCH: 538 | short_a 539 | lda (1) ; Fetch the data byte 540 | sta <1 ; .. and replace stack value 541 | stz <2 542 | long_a 543 | CONTINUE ; Done 544 | 545 | ; HERE ( -- addr ) 546 | ; 547 | ; addr is the data-space pointer. 548 | 549 | HEADER 4,"HERE",NORMAL 550 | HERE: jsr DO_COLON 551 | dw DP 552 | dw FETCH 553 | dw EXIT 554 | 555 | ;=============================================================================== 556 | ; Alignment 557 | ;------------------------------------------------------------------------------- 558 | 559 | ; ALIGN ( -- ) 560 | ; 561 | ; If the data-space pointer is not aligned, reserve enough space to align it. 562 | 563 | HEADER 5,"ALIGN",NORMAL 564 | ALIGN: 565 | CONTINUE ; Done 566 | 567 | ; ALIGNED ( addr -- a-addr ) 568 | ; 569 | ; a-addr is the first aligned address greater than or equal to addr. 570 | 571 | HEADER 7,"ALIGNED",NORMAL 572 | ALIGNED: 573 | CONTINUE ; Done 574 | 575 | ; CELL+ ( a-addr1 -- a-addr2 ) 576 | ; 577 | ; Add the size in address units of a cell to a-addr1, giving a-addr2. 578 | 579 | HEADER 5,"CELL+",NORMAL 580 | CELL_PLUS: 581 | inc <1 ; Bump the address by two 582 | inc <1 583 | CONTINUE ; Done 584 | 585 | ; CELLS ( n1 -- n2 ) 586 | ; 587 | ; n2 is the size in address units of n1 cells. 588 | 589 | HEADER 5,"CELLS",NORMAL 590 | CELLS: 591 | asl <1 ; Two bytes per cell 592 | CONTINUE ; Done 593 | 594 | ; CHAR+ ( c-addr1 -- c-addr2 ) 595 | ; 596 | ; Add the size in address units of a character to c-addr1, giving c-addr2. 597 | 598 | HEADER 5,"CHAR+",NORMAL 599 | CHAR_PLUS: 600 | inc <1 ; Bump the address by one 601 | CONTINUE ; Done 602 | 603 | ; CHAR- ( c-addr1 -- c-addr2 ) 604 | ; 605 | ; Subtract the size in address units of a character to c-addr1, giving c-addr2. 606 | 607 | HEADER 5,"CHAR-",NORMAL 608 | CHAR_MINUS: 609 | dec <1 610 | CONTINUE ; Done 611 | 612 | ; CHARS ( n1 -- n2 ) 613 | ; 614 | ; n2 is the size in address units of n1 characters. 615 | 616 | HEADER 5,"CHARS",NORMAL 617 | CHARS: 618 | CONTINUE ; Done 619 | 620 | ;=============================================================================== 621 | ; Stack Operations 622 | ;------------------------------------------------------------------------------- 623 | 624 | ; 2DROP ( x1 x2 -- ) 625 | ; 626 | ; Drop cell pair x1 x2 from the stack. 627 | 628 | HEADER 5,"2DROP",NORMAL 629 | TWO_DROP: 630 | tdc ; Removed two words from stack 631 | inc a 632 | inc a 633 | inc a 634 | inc a 635 | tcd 636 | CONTINUE ; Done 637 | 638 | ; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) 639 | ; 640 | ; Duplicate cell pair x1 x2. 641 | 642 | HEADER 4,"2DUP",NORMAL 643 | TWO_DUP: 644 | tdc ; Make space for new value 645 | dec a 646 | dec a 647 | dec a 648 | dec a 649 | tcd 650 | lda <5 ; Copy top two values 651 | sta <1 652 | lda <7 653 | sta <3 654 | CONTINUE ; Done 655 | 656 | ; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) 657 | ; 658 | ; Copy cell pair x1 x2 to the top of the stack. 659 | 660 | HEADER 5,"2OVER",NORMAL 661 | TWO_OVER: 662 | tdc ; Make space for new value 663 | dec a 664 | dec a 665 | dec a 666 | dec a 667 | tcd 668 | lda <9 ; Ciopy top two values 669 | sta <1 670 | lda <11 671 | sta <3 672 | CONTINUE ; Done 673 | 674 | ; 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) 675 | ; 676 | ; Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to 677 | ; the top of the stack. 678 | 679 | HEADER 4,"2ROT",NORMAL 680 | TWO_ROT: 681 | lda <11 ; Save x1 682 | pha 683 | lda <9 ; Save x2 684 | pha 685 | lda <7 ; Move x3 686 | sta <11 687 | lda <5 ; Move x4 688 | sta <9 689 | lda <3 ; Move x5 690 | sta <7 691 | lda <1 ; Move x6 692 | sta <5 693 | pla ; Restore x2 694 | sta <1 695 | pla ; Restore x1 696 | sta <3 697 | CONTINUE ; Done 698 | 699 | ; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) 700 | ; 701 | ; Exchange the top two cell pairs. 702 | 703 | HEADER 5,"2SWAP",NORMAL 704 | TWO_SWAP: 705 | lda <3 ; Save x3 706 | pha 707 | lda <1 ; Save x4 708 | pha 709 | lda <7 ; Move x1 710 | sta <3 711 | lda <5 ; Move x2 712 | sta <1 713 | pla ; Move x4 714 | sta <5 715 | pla ; Move x3 716 | sta <7 717 | CONTINUE ; Done 718 | 719 | ; ?DUP ( x -- 0 | x x ) 720 | ; 721 | ; Duplicate x if it is non-zero. 722 | 723 | HEADER 4,"?DUP",NORMAL 724 | QUERY_DUP: 725 | lda <1 ; Fetch top value 726 | bne DUP ; Non-zero value? 727 | CONTINUE ; Done 728 | 729 | ; DEPTH ( -- +n ) 730 | ; 731 | ; +n is the number of single-cell values contained in the data stack before +n 732 | ; was placed on the stack. 733 | 734 | HEADER 5,"DEPTH",NORMAL 735 | DEPTH: jsr DO_COLON 736 | dw AT_DP 737 | dw DO_LITERAL,DSTACK_END-1 738 | dw SWAP 739 | dw MINUS 740 | dw TWO_SLASH 741 | dw EXIT 742 | 743 | ; DROP ( x -- ) 744 | ; 745 | ; Remove x from the stack. 746 | 747 | HEADER 4,"DROP",NORMAL 748 | DROP: 749 | tdc ; Drop the top value 750 | inc a 751 | inc a 752 | tcd 753 | CONTINUE ; Done 754 | 755 | ; DUP ( x -- x x ) 756 | ; 757 | ; Duplicate x. 758 | 759 | HEADER 3,"DUP",NORMAL 760 | DUP: 761 | tdc 762 | dec a 763 | dec a 764 | tcd 765 | lda <3 ; Fetch top value 766 | sta <1 ; And make a copy 767 | CONTINUE ; Done 768 | 769 | ; NIP ( x1 x2 -- x2 ) 770 | ; 771 | ; Drop the first item below the top of stack. 772 | 773 | HEADER 3,"NIP",NORMAL 774 | NIP: 775 | lda <1 ; Copy x2 over x1 776 | sta <3 777 | bra DROP 778 | 779 | ; OVER ( x1 x2 -- x1 x2 x1 ) 780 | ; 781 | ; Place a copy of x1 on top of the stack. 782 | 783 | HEADER 4,"OVER",NORMAL 784 | OVER: 785 | tdc 786 | dec a 787 | dec a 788 | tcd 789 | lda <5 ; Fetch second value 790 | sta <1 ; And make a copy 791 | CONTINUE ; Done 792 | 793 | ; PICK ( xu ... x1 x0 u -- xu ... x1 x0 xu ) 794 | ; 795 | ; Remove u. Copy the xu to the top of the stack. An ambiguous condition exists 796 | ; if there are less than u+2 items on the stack before PICK is executed. 797 | 798 | HEADER 4,"PICK",NORMAL 799 | PICK: 800 | lda <1 ; Fetch the index 801 | asl a 802 | tax 803 | lda <3,x ; Load the target value 804 | sta <1 ; .. and save 805 | CONTINUE ; Done 806 | 807 | ; ROLL ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) 808 | ; 809 | ; Remove u. Rotate u+1 items on the top of the stack. An ambiguous condition 810 | ; exists if there are less than u+2 items on the stack before ROLL is executed. 811 | 812 | HEADER 4,"ROLL",NORMAL 813 | ROLL: 814 | asl <1 ; Convert count to index 815 | ldx <1 816 | beq ROLL_2 ; Zero? Nothing to do 817 | lda <3,x ; Save the final value 818 | pha 819 | ROLL_1: lda <1,x ; Move x-1 to x 820 | sta <3,x 821 | dex ; And repeat 822 | dex 823 | bne ROLL_1 824 | pla ; Recover the new top value 825 | sta <3 826 | ROLL_2: jmp DROP ; Drop the count 827 | 828 | ; ROT ( x1 x2 x3 -- x2 x3 x1 ) 829 | ; 830 | ; Rotate the top three stack entries. 831 | 832 | HEADER 3,"ROT",NORMAL 833 | ROT: 834 | ldx <5 ; Save x1 835 | lda <3 ; Move x2 836 | sta <5 837 | lda <1 ; Move x3 838 | sta <3 839 | stx <1 ; Restore x1 840 | CONTINUE 841 | 842 | ; SWAP ( x1 x2 -- x2 x1 ) 843 | ; 844 | ; Exchange the top two stack items. 845 | 846 | HEADER 4,"SWAP",NORMAL 847 | SWAP: 848 | lda <1 ; Switch top two words 849 | ldx <3 850 | sta <3 851 | stx <1 852 | CONTINUE ; Done 853 | 854 | ; TUCK ( x1 x2 -- x2 x1 x2 ) 855 | ; 856 | ; Copy the first (top) stack item below the second stack item. 857 | 858 | HEADER 4,"TUCK",NORMAL 859 | TUCK: jsr DO_COLON 860 | dw SWAP 861 | dw OVER 862 | dw EXIT 863 | 864 | ;=============================================================================== 865 | ; Return Stack Operations 866 | ;------------------------------------------------------------------------------- 867 | 868 | ; 2>R ( x1 x2 -- ) ( R: -- x1 x2 ) 869 | ; 870 | ; Transfer cell pair x1 x2 to the return stack. Semantically equivalent to 871 | ; SWAP >R >R. 872 | 873 | HEADER 3,"2>R",NORMAL 874 | TWO_TO_R: 875 | lda <3 ; Transfer x1 876 | pha 877 | lda <1 ; Transfer x2 878 | pha 879 | tdc 880 | inc a ; Clean up data stack 881 | inc a 882 | inc a 883 | inc a 884 | tcd 885 | CONTINUE ; Done 886 | 887 | ; 2R> ( -- x1 x2 ) ( R: x1 x2 -- ) 888 | ; 889 | ; Transfer cell pair x1 x2 from the return stack. Semantically equivalent to R> 890 | ; R> SWAP. 891 | 892 | HEADER 3,"2R>",NORMAL 893 | TWO_R_FROM: 894 | tdc 895 | dec a ; Make space for values 896 | dec a 897 | dec a 898 | dec a 899 | tcd 900 | pla ; Transfer x2 901 | sta <1 902 | pla ; Transfer x1 903 | sta <3 904 | CONTINUE ; Done 905 | 906 | ; 2R@ ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) 907 | ; 908 | ; Copy cell pair x1 x2 from the return stack. Semantically equivalent to R> R> 909 | ; 2DUP >R >R SWAP. 910 | 911 | HEADER 3,"2R@",NORMAL 912 | TWO_R_FETCH: 913 | tdc 914 | dec a ; Make space for values 915 | dec a 916 | dec a 917 | dec a 918 | tcd 919 | lda 1,s ; Transfer x2 920 | sta <1 921 | lda 3,s ; Transfer x1 922 | sta <3 923 | CONTINUE ; Done 924 | 925 | ; >R ( x -- ) ( R: -- x ) 926 | ; 927 | ; Move x to the return stack. 928 | 929 | HEADER 2,">R",NORMAL 930 | TO_R: 931 | lda <1 ; Transfer top value 932 | pha ; .. to return stack 933 | tdc 934 | inc a 935 | inc a 936 | tcd 937 | CONTINUE ; Done 938 | 939 | ; I ( -- n|u ) ( R: loop-sys -- loop-sys ) 940 | ; 941 | ; n|u is a copy of the current (innermost) loop index. An ambiguous condition 942 | ; exists if the loop control parameters are unavailable. 943 | 944 | HEADER 1,"I",NORMAL 945 | I: 946 | tdc 947 | dec a 948 | dec a 949 | tcd 950 | lda 1,s 951 | sta <1 952 | CONTINUE 953 | 954 | ; J ( -- n|u ) ( R: loop-sys1 loop-sys2 -- loop-sys1 loop-sys2 ) 955 | ; 956 | ; n|u is a copy of the next-outer loop index. An ambiguous condition exists if 957 | ; the loop control parameters of the next-outer loop, loop-sys1, are 958 | ; unavailable. 959 | 960 | HEADER 1,"J",NORMAL 961 | J: 962 | tdc 963 | dec a 964 | dec a 965 | tcd 966 | lda 5,s 967 | sta <1 968 | CONTINUE 969 | 970 | ; R> ( -- x ) ( R: x -- ) 971 | ; 972 | ; Move x from the return stack to the data stack. 973 | 974 | HEADER 2,"R>",NORMAL 975 | R_FROM: 976 | tdc 977 | dec a 978 | dec a 979 | tcd 980 | pla ; Fetch return stack value 981 | sta <1 982 | CONTINUE ; Done 983 | 984 | ; R@ ( -- x ) ( R: x -- x ) 985 | ; 986 | ; Copy x from the return stack to the data stack. 987 | 988 | HEADER 2,"R@",NORMAL 989 | R_FETCH: 990 | tdc 991 | dec a 992 | dec a 993 | tcd 994 | lda 1,s 995 | sta <1 996 | CONTINUE 997 | 998 | ;=============================================================================== 999 | ; Single Precision Arithmetic 1000 | ;------------------------------------------------------------------------------- 1001 | 1002 | ; * ( n1|u1 n2|u2 -- n3|u3 ) 1003 | ; 1004 | ; Multiply n1|u1 by n2|u2 giving the product n3|u3. 1005 | ; 1006 | ; In this implementation it is defined as: 1007 | ; 1008 | ; M* DROP 1009 | 1010 | HEADER 1,"*",NORMAL 1011 | STAR: jsr DO_COLON 1012 | dw M_STAR 1013 | dw DROP 1014 | dw EXIT 1015 | 1016 | ; */ ( n1 n2 n3 -- n4 ) 1017 | ; 1018 | ; Multiply n1 by n2 producing the intermediate double-cell result d. Divide d 1019 | ; by n3 giving the single-cell quotient n4. An ambiguous condition exists if 1020 | ; n3 is zero or if the quotient n4 lies outside the range of a signed number. 1021 | ; If d and n3 differ in sign, the implementation-defined result returned will 1022 | ; be the same as that returned by either the phrase >R M* R> FM/MOD SWAP DROP 1023 | ; or the phrase >R M* R> SM/REM SWAP DROP. 1024 | ; 1025 | ; In this implementation it is defined as: 1026 | ; 1027 | ; >R M* R> FM/MOD SWAP DROP 1028 | 1029 | HEADER 2,"*/",NORMAL 1030 | STAR_SLASH: jsr DO_COLON 1031 | dw TO_R 1032 | dw M_STAR 1033 | dw R_FROM 1034 | dw FM_SLASH_MOD 1035 | dw SWAP 1036 | dw DROP 1037 | dw EXIT 1038 | 1039 | ; */MOD ( n1 n2 n3 -- n4 n5 ) 1040 | ; 1041 | ; Multiply n1 by n2 producing the intermediate double-cell result d. Divide d 1042 | ; by n3 producing the single-cell remainder n4 and the single-cell quotient n5. 1043 | ; An ambiguous condition exists if n3 is zero, or if the quotient n5 lies 1044 | ; outside the range of a single-cell signed integer. If d and n3 differ in 1045 | ; sign, the implementation-defined result returned will be the same as that 1046 | ; returned by either the phrase >R M* R> FM/MOD or the phrase >R M* R> SM/REM. 1047 | ; 1048 | ; In this implementation it is defined as: 1049 | ; 1050 | ; >R M* R> FM/MOD 1051 | 1052 | HEADER 5,"*/MOD",NORMAL 1053 | STAR_SLASH_MOD: jsr DO_COLON 1054 | dw TO_R 1055 | dw M_STAR 1056 | dw R_FROM 1057 | dw FM_SLASH_MOD 1058 | dw EXIT 1059 | 1060 | ; + ( n1|u1 n2|u2 -- n3|u3 ) 1061 | ; 1062 | ; Add n2|u2 to n1|u1, giving the sum n3|u3. 1063 | 1064 | HEADER 1,"+",NORMAL 1065 | PLUS: 1066 | clc ; Add top two values 1067 | lda <3 1068 | adc <1 1069 | sta <3 ; Save result 1070 | tdc 1071 | inc a ; Clean up data stack 1072 | inc a 1073 | tcd 1074 | CONTINUE ; Done 1075 | 1076 | ; - ( n1|u1 n2|u2 -- n3|u3 ) 1077 | ; 1078 | ; Subtract n2|u2 from n1|u1, giving the difference n3|u3. 1079 | 1080 | HEADER 1,"-",NORMAL 1081 | MINUS: 1082 | sec ; Subtract top two values 1083 | lda <3 1084 | sbc <1 1085 | sta <3 ; Save result 1086 | tdc 1087 | inc a ; Clean up data stack 1088 | inc a 1089 | tcd 1090 | CONTINUE ; Done 1091 | 1092 | ; / ( n1 n2 -- n3 ) 1093 | ; 1094 | ; Divide n1 by n2, giving the single-cell quotient n3. An ambiguous condition 1095 | ; exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined 1096 | ; result returned will be the same as that returned by either the phrase >R S>D 1097 | ; R> FM/MOD SWAP DROP or the phrase >R S>D R> SM/REM SWAP DROP. 1098 | ; 1099 | ; In this implementatio it is defined as: 1100 | ; 1101 | ; >R S>D R> FM/MOD SWAP DROP 1102 | 1103 | HEADER 1,"/",NORMAL 1104 | SLASH: jsr DO_COLON 1105 | dw TO_R 1106 | dw S_TO_D 1107 | dw R_FROM 1108 | dw FM_SLASH_MOD 1109 | dw SWAP 1110 | dw DROP 1111 | dw EXIT 1112 | 1113 | ; /MOD ( n1 n2 -- n3 n4 ) 1114 | ; 1115 | ; Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 1116 | ; quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 differ 1117 | ; in sign, the implementation-defined result returned will be the same as that 1118 | ; returned by either the phrase >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM. 1119 | ; 1120 | ; In this implementation it is defined as: 1121 | ; 1122 | ; >R S>D R> FM/MOD 1123 | 1124 | HEADER 4,"/MOD",NORMAL 1125 | SLASH_MOD: jsr DO_COLON 1126 | dw TO_R 1127 | dw S_TO_D 1128 | dw R_FROM 1129 | dw FM_SLASH_MOD 1130 | dw EXIT 1131 | 1132 | ; 1+ ( n1|u1 -- n2|u2 ) 1133 | ; 1134 | ; Add one (1) to n1|u1 giving the sum n2|u2. 1135 | 1136 | HEADER 2,"1+",NORMAL 1137 | ONE_PLUS: 1138 | inc <1 ; Increment top of stack 1139 | CONTINUE ; Done 1140 | 1141 | ; 1- ( n1|u1 -- n2|u2 ) 1142 | ; 1143 | ; Subtract one (1) from n1|u1 giving the difference n2|u2. 1144 | 1145 | HEADER 2,"1-",NORMAL 1146 | ONE_MINUS: 1147 | dec <1 ; Decrement top of stack 1148 | CONTINUE ; Done 1149 | 1150 | ; 2* ( x1 -- x2 ) 1151 | ; 1152 | ; x2 is the result of shifting x1 one bit toward the most-significant bit, 1153 | ; filling the vacated least-significant bit with zero. 1154 | 1155 | HEADER 2,"2*",NORMAL 1156 | TWO_STAR: 1157 | asl <1 ; Multiply top value by two 1158 | CONTINUE ; Done 1159 | 1160 | ; 2/ ( x1 -- x2 ) 1161 | ; 1162 | ; x2 is the result of shifting x1 one bit toward the least-significant bit, 1163 | ; leaving the most-significant bit unchanged. 1164 | 1165 | HEADER 2,"2/",NORMAL 1166 | TWO_SLASH: 1167 | lda <1 ; Load the top value 1168 | rol a ; Extract the top bit 1169 | ror <1 ; And shift back into value 1170 | CONTINUE 1171 | 1172 | ; ?NEGATE ( x sign -- x/-x) 1173 | ; 1174 | ; If the sign value is negative then negate the value of x to match. 1175 | ; 1176 | ; In this implementation it is defined as: 1177 | ; 1178 | ; 0< IF NEGATE THEN 1179 | 1180 | QUERY_NEGATE: jsr DO_COLON 1181 | dw ZERO_LESS 1182 | dw QUERY_BRANCH,QUERY_NEGATE_1 1183 | dw NEGATE 1184 | QUERY_NEGATE_1: dw EXIT 1185 | 1186 | ; ABS ( n -- u ) 1187 | ; 1188 | ; u is the absolute value of n. 1189 | 1190 | HEADER 3,"ABS",NORMAL 1191 | ABS: 1192 | lda <1 1193 | bpl ABS_1 1194 | jmp NEGATE 1195 | ABS_1: CONTINUE ; Done 1196 | 1197 | ; FM/MOD ( n1 n2 -- n3 n4 ) 1198 | ; 1199 | ; Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 1200 | ; quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 differ 1201 | ; in sign, the implementation-defined result returned will be the same as that 1202 | ; returned by either the phrase >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM. 1203 | ; 1204 | ; In this implementation it is defined as: 1205 | ; 1206 | ; DUP >R divisor 1207 | ; 2DUP XOR >R sign of quotient 1208 | ; >R divisor 1209 | ; DABS R@ ABS UM/MOD 1210 | ; SWAP R> ?NEGATE SWAP apply sign to remainder 1211 | ; R> 0< IF if quotient negative, 1212 | ; NEGATE 1213 | ; OVER IF if remainder nonzero, 1214 | ; R@ ROT - SWAP 1- adjust rem,quot 1215 | ; THEN 1216 | ; THEN R> DROP ; 1217 | 1218 | HEADER 6,"FM/MOD",NORMAL 1219 | FM_SLASH_MOD: jsr DO_COLON 1220 | dw DUP 1221 | dw TO_R 1222 | dw TWO_DUP 1223 | dw XOR 1224 | dw TO_R 1225 | dw TO_R 1226 | dw DABS 1227 | dw R_FETCH 1228 | dw ABS 1229 | dw UM_SLASH_MOD 1230 | dw SWAP 1231 | dw R_FROM 1232 | dw QUERY_NEGATE 1233 | dw SWAP 1234 | dw R_FROM 1235 | dw ZERO_LESS 1236 | dw QUERY_BRANCH,FM_SLASH_MOD_1 1237 | dw NEGATE 1238 | dw OVER 1239 | dw QUERY_BRANCH,FM_SLASH_MOD_1 1240 | dw R_FETCH 1241 | dw ROT 1242 | dw MINUS 1243 | dw SWAP 1244 | dw ONE_MINUS 1245 | FM_SLASH_MOD_1: dw R_FROM 1246 | dw DROP 1247 | dw EXIT 1248 | 1249 | ; MAX ( n1 n2 -- n3 ) 1250 | ; 1251 | ; n3 is the greater of n1 and n2. 1252 | 1253 | HEADER 3,"MAX",NORMAL 1254 | MAX: jsr DO_COLON 1255 | dw TWO_DUP 1256 | dw LESS 1257 | dw QUERY_BRANCH,MAX_1 1258 | dw SWAP 1259 | MAX_1: dw DROP 1260 | dw EXIT 1261 | 1262 | ; MIN ( n1 n2 -- n3 ) 1263 | ; 1264 | ; n3 is the lesser of n1 and n2. 1265 | 1266 | HEADER 3,"MIN",NORMAL 1267 | MIN: jsr DO_COLON 1268 | dw TWO_DUP 1269 | dw GREATER 1270 | dw QUERY_BRANCH,MIN_1 1271 | dw SWAP 1272 | MIN_1: dw DROP 1273 | dw EXIT 1274 | 1275 | ; MOD ( n1 n2 -- n3 ) 1276 | ; 1277 | ; Divide n1 by n2, giving the single-cell remainder n3. An ambiguous condition 1278 | ; exists if n2 is zero. If n1 and n2 differ in sign, the implementation-defined 1279 | ; result returned will be the same as that returned by either the phrase >R S>D 1280 | ; R> FM/MOD DROP or the phrase >R S>D R> SM/REM DROP. 1281 | ; 1282 | ; In this implementation it is defined as: 1283 | ; 1284 | ; >R S>D R> FM/MOD DROP 1285 | 1286 | HEADER 3,"MOD",NORMAL 1287 | MOD: jsr DO_COLON 1288 | dw TO_R 1289 | dw S_TO_D 1290 | dw R_FROM 1291 | dw FM_SLASH_MOD 1292 | dw DROP 1293 | dw EXIT 1294 | 1295 | ; NEGATE ( n1 -- n2 ) 1296 | ; 1297 | ; Negate n1, giving its arithmetic inverse n2. 1298 | 1299 | HEADER 6,"NEGATE",NORMAL 1300 | NEGATE: 1301 | sec ; Negate the top of stack 1302 | lda #0 1303 | sbc <1 1304 | sta <1 1305 | CONTINUE ; Done 1306 | 1307 | ; UMAX ( x1 x2 -- x3 ) 1308 | ; 1309 | ; x3 is the greater of x1 and x2. 1310 | 1311 | HEADER 4,"UMAX",NORMAL 1312 | UMAX: 1313 | lda <1 ; Compare the top values 1314 | cmp <3 1315 | bcs UMAX_EXIT ; Is x2 biggest? 1316 | jmp DROP ; No, x1 is 1317 | UMAX_EXIT: jmp NIP 1318 | 1319 | ; UMIN ( x1 x2 -- x3 ) 1320 | ; 1321 | ; x3 is the lesser of x1 and x2. 1322 | 1323 | HEADER 4,"UMIN",NORMAL 1324 | UMIN: 1325 | lda <1 ; Compare the top values 1326 | cmp <3 1327 | bcc UMIN_EXIT ; Is x2 smallest? 1328 | jmp DROP ; No, x1 is 1329 | UMIN_EXIT: jmp NIP 1330 | 1331 | ;=============================================================================== 1332 | ; Double Precision Arithmetic 1333 | ;------------------------------------------------------------------------------- 1334 | 1335 | ; ?DNEGATE ( d1 sign -- d1/-d1 ) 1336 | ; 1337 | ; If sign is less than zero than negate d1 otherwise leave it unchanged. 1338 | 1339 | QUERY_DNEGATE: jsr DO_COLON 1340 | dw ZERO_LESS 1341 | dw QUERY_BRANCH,QUERY_DNEG_1 1342 | dw DNEGATE 1343 | QUERY_DNEG_1: dw EXIT 1344 | 1345 | ; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) 1346 | ; 1347 | ; Add d2|ud2 to d1|ud1, giving the sum d3|ud3. 1348 | 1349 | HEADER 2,"D+",NORMAL 1350 | D_PLUS: 1351 | clc 1352 | lda <7 ; Add low words 1353 | adc <3 1354 | sta <7 1355 | lda <5 ; Then the high words 1356 | adc <1 1357 | sta <5 1358 | tdc ; Drop top double 1359 | inc a 1360 | inc a 1361 | inc a 1362 | inc a 1363 | tcd 1364 | CONTINUE ; Done 1365 | 1366 | ; D- ( d1|ud1 d2|ud2 -- d3|ud3 ) 1367 | ; 1368 | ; Subtract d2|ud2 from d1|ud1, giving the difference d3|ud3. 1369 | 1370 | HEADER 2,"D-",NORMAL 1371 | D_MINUS: 1372 | sec 1373 | lda <7 ; Subtract low words 1374 | sbc <3 1375 | sta <7 1376 | lda <5 ; Then the high words 1377 | sbc <1 1378 | sta <5 1379 | tdc ; Drop top double 1380 | inc a 1381 | inc a 1382 | inc a 1383 | inc a 1384 | tcd 1385 | CONTINUE ; Done 1386 | 1387 | ; D0< ( d -- flag ) 1388 | ; 1389 | ; flag is true if and only if d is less than zero. 1390 | 1391 | HEADER 3,"D0<",NORMAL 1392 | D_ZERO_LESS: 1393 | ldx <1 ; Fetch sign 1394 | tdc ; Drop a word 1395 | inc a 1396 | inc a 1397 | tcd 1398 | stz <1 ; Assume false 1399 | txa 1400 | bpl D_ZERO_LESS_1 1401 | dec <1 1402 | D_ZERO_LESS_1: CONTINUE 1403 | 1404 | ; D0= ( d -- flag ) 1405 | ; 1406 | ; flag is true if and only if d is equal to zero. 1407 | 1408 | HEADER 3,"D0=",NORMAL 1409 | D_ZERO_EQUAL: 1410 | ldx <1 ; Fetch sign 1411 | tdc ; Drop a word 1412 | inc a 1413 | inc a 1414 | tcd 1415 | stz <1 ; Assume false 1416 | txa 1417 | bne D_ZERO_EQUAL_1 1418 | dec <1 1419 | D_ZERO_EQUAL_1: CONTINUE 1420 | 1421 | ; D2* ( xd1 -- xd2 ) 1422 | ; 1423 | ; xd2 is the result of shifting xd1 one bit toward the most-significant bit, 1424 | ; filling the vacated least-significant bit with zero. 1425 | 1426 | HEADER 3,"D2*",NORMAL 1427 | D_TWO_STAR: 1428 | asl <3 1429 | rol <1 1430 | CONTINUE 1431 | 1432 | ; D2/ ( xd1 -- xd2 ) 1433 | ; 1434 | ; xd2 is the result of shifting xd1 one bit toward the least-significant bit, 1435 | ; leaving the most-significant bit unchanged. 1436 | 1437 | HEADER 3,"D2/",NORMAL 1438 | D_TWO_SLASH: 1439 | lda <1 1440 | rol a 1441 | ror <1 1442 | ror <3 1443 | CONTINUE 1444 | 1445 | ; D< ( d1 d2 -- flag ) 1446 | ; 1447 | ; flag is true if and only if d1 is less than d2. 1448 | 1449 | HEADER 2,"D<",NORMAL 1450 | D_LESS: jsr DO_COLON 1451 | dw D_MINUS 1452 | dw D_ZERO_LESS 1453 | dw EXIT 1454 | 1455 | ; D= ( d1 d2 -- flag ) 1456 | ; 1457 | ; flag is true if and only if d1 is bit-for-bit the same as d2. 1458 | 1459 | HEADER 2,"D=",NORMAL 1460 | D_EQUAL: jsr DO_COLON 1461 | dw D_MINUS 1462 | dw D_ZERO_EQUAL 1463 | dw EXIT 1464 | 1465 | ; DABS ( d -- ud ) 1466 | ; 1467 | ; ud is the absolute value of d. 1468 | 1469 | HEADER 4,"DABS",NORMAL 1470 | DABS: 1471 | lda <1 1472 | bpl DABS_1 1473 | jmp DNEGATE 1474 | DABS_1: CONTINUE 1475 | 1476 | ; DMAX ( d1 d2 -- d3 ) 1477 | ; 1478 | ; d3 is the greater of d1 and d2. 1479 | 1480 | HEADER 4,"DMAX",NORMAL 1481 | DMAX: jsr DO_COLON 1482 | dw TWO_OVER 1483 | dw TWO_OVER 1484 | dw D_LESS 1485 | dw QUERY_BRANCH,DMAX_1 1486 | dw TWO_SWAP 1487 | DMAX_1: dw TWO_DROP 1488 | dw EXIT 1489 | 1490 | ; DMIN ( d1 d2 -- d3 ) 1491 | ; 1492 | ; d3 is the lesser of d1 and d2. 1493 | 1494 | HEADER 4,"DMIN",NORMAL 1495 | DMIN: jsr DO_COLON 1496 | dw TWO_OVER 1497 | dw TWO_OVER 1498 | dw D_LESS 1499 | dw INVERT 1500 | dw QUERY_BRANCH,DMIN_1 1501 | dw TWO_SWAP 1502 | DMIN_1: dw TWO_DROP 1503 | dw EXIT 1504 | 1505 | ; DNEGATE ( d1 -- d2 ) 1506 | ; 1507 | ; d2 is the negation of d1. 1508 | 1509 | HEADER 7,"DNEGATE",NORMAL 1510 | DNEGATE: 1511 | sec 1512 | lda #0 ; Subtract low word from zero 1513 | sbc <3 1514 | sta <3 1515 | lda #0 ; Then the high word 1516 | sbc <1 1517 | sta <1 1518 | CONTINUE ; Done 1519 | 1520 | ;=============================================================================== 1521 | ; Mixed Arithmetic 1522 | ;------------------------------------------------------------------------------- 1523 | 1524 | ; D>S ( d -- n ) 1525 | ; 1526 | ; n is the equivalent of d. An ambiguous condition exists if d lies outside the 1527 | ; range of a signed single-cell number. 1528 | 1529 | HEADER 3,"D>S",NORMAL 1530 | D_TO_S: 1531 | tdc 1532 | inc a ; Drop the high word 1533 | inc a 1534 | tcd 1535 | CONTINUE 1536 | 1537 | ; M* ( n1 n2 -- d ) 1538 | ; 1539 | ; d is the signed product of n1 times n2. 1540 | ; 1541 | ; In this implementation it is defined as: 1542 | ; 1543 | ; 2DUP XOR >R carries sign of the result 1544 | ; SWAP ABS SWAP ABS UM* 1545 | ; R> ?DNEGATE 1546 | 1547 | HEADER 2,"M*",NORMAL 1548 | M_STAR: jsr DO_COLON 1549 | dw TWO_DUP 1550 | dw XOR 1551 | dw TO_R 1552 | dw SWAP 1553 | dw ABS 1554 | dw SWAP 1555 | dw ABS 1556 | dw UM_STAR 1557 | dw R_FROM 1558 | dw QUERY_DNEGATE 1559 | dw EXIT 1560 | 1561 | ; M*/ ( d1 n1 +n2 -- d2 ) 1562 | ; 1563 | ; Multiply d1 by n1 producing the triple-cell intermediate result t. Divide t 1564 | ; by +n2 giving the double-cell quotient d2. An ambiguous condition exists if 1565 | ; +n2 is zero or negative, or the quotient lies outside of the range of a 1566 | ; double-precision signed integer. 1567 | 1568 | 1569 | 1570 | ; M+ ( d1|ud1 n -- d2|ud2 ) 1571 | ; 1572 | ; Add n to d1|ud1, giving the sum d2|ud2. 1573 | 1574 | HEADER 2,"M+",NORMAL 1575 | M_PLUS: 1576 | clc 1577 | lda <1 1578 | adc <5 1579 | sta <5 1580 | bcc $+4 1581 | inc <3 1582 | tdc 1583 | inc a 1584 | inc a 1585 | tcd 1586 | CONTINUE 1587 | 1588 | ; S>D ( n -- d ) 1589 | ; 1590 | ; Convert the number n to the double-cell number d with the same numerical 1591 | ; value. 1592 | 1593 | HEADER 3,"S>D",NORMAL 1594 | S_TO_D: 1595 | tdc 1596 | dec a ; Assume n is positive 1597 | dec a 1598 | tcd 1599 | stz <1 ; .. push a zero value 1600 | lda <3 ; Test the number 1601 | bpl S_TO_D_1 1602 | dec <1 ; Make top -1 if negative 1603 | S_TO_D_1 CONTINUE ; Done 1604 | 1605 | ; SM/REM ( d1 n1 -- n2 n3 ) 1606 | ; 1607 | ; Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 1608 | ; Input and output stack arguments are signed. An ambiguous condition exists if 1609 | ; n1 is zero or if the quotient lies outside the range of a single-cell signed 1610 | ; integer. 1611 | ; 1612 | ; In this implementation it is defined as: 1613 | ; 1614 | ; 2DUP XOR >R sign of quotient 1615 | ; OVER >R sign of remainder 1616 | ; ABS >R DABS R> UM/MOD 1617 | ; SWAP R> ?NEGATE 1618 | ; SWAP R> ?NEGATE ; 1619 | 1620 | HEADER 6,"SM/REM",NORMAL 1621 | SM_SLASH_REM: jsr DO_COLON 1622 | dw TWO_DUP 1623 | dw XOR 1624 | dw TO_R 1625 | dw OVER 1626 | dw TO_R 1627 | dw ABS 1628 | dw TO_R 1629 | dw DABS 1630 | dw R_FROM 1631 | dw UM_SLASH_MOD 1632 | dw SWAP 1633 | dw R_FROM 1634 | dw QUERY_NEGATE 1635 | dw SWAP 1636 | dw R_FROM 1637 | dw QUERY_NEGATE 1638 | dw EXIT 1639 | 1640 | ; UD* ( ud1 d2 -- ud3) 1641 | ; 1642 | ; 32*16->32 multiply 1643 | ; 1644 | ; DUP >R UM* DROP SWAP R> UM* ROT + ; 1645 | 1646 | HEADER 3,"UD*",NORMAL 1647 | UD_STAR: jsr DO_COLON 1648 | dw DUP 1649 | dw TO_R 1650 | dw UM_STAR 1651 | dw DROP 1652 | dw SWAP 1653 | dw R_FROM 1654 | dw UM_STAR 1655 | dw ROT 1656 | dw PLUS 1657 | dw EXIT 1658 | 1659 | ; UM* ( u1 u2 -- ud ) 1660 | ; 1661 | ; Multiply u1 by u2, giving the unsigned double-cell product ud. All values and 1662 | ; arithmetic are unsigned. 1663 | 1664 | HEADER 3,"UM*",NORMAL 1665 | UM_STAR: 1666 | lda <1 ; Fetch multiplier 1667 | pha 1668 | stz <1 ; Clear the result 1669 | ldx #16 1670 | UM_STAR_1: lda <3 ; Shift multiplier one bit 1671 | lsr a 1672 | bcc UM_STAR_2 ; Not set, no add 1673 | lda 1,s ; Fetch multiplicand 1674 | clc 1675 | adc <1 1676 | sta <1 1677 | UM_STAR_2: ror <1 ; Rotate high word down 1678 | ror <3 1679 | dex 1680 | bne UM_STAR_1 1681 | pla 1682 | CONTINUE ; Done 1683 | 1684 | ; UM/MOD ( ud u1 -- u2 u3 ) 1685 | ; 1686 | ; Divide ud by u1, giving the quotient u3 and the remainder u2. All values and 1687 | ; arithmetic are unsigned. An ambiguous condition exists if u1 is zero or if the 1688 | ; quotient lies outside the range of a single-cell unsigned integer. 1689 | 1690 | HEADER 6,"UM/MOD",NORMAL 1691 | UM_SLASH_MOD: 1692 | sec ; Check for overflow 1693 | lda <3 1694 | sbc <1 1695 | bcs UM_SLASH_MOD_3 1696 | 1697 | ldx #17 1698 | UM_SLASH_MOD_1: rol <5 ; Rotate dividend lo 1699 | dex 1700 | beq UM_SLASH_MOD_4 1701 | rol <3 1702 | bcs UM_SLASH_MOD_2 ; Carry set dividend > divisor 1703 | 1704 | lda <3 ; Is dividend < divisor? 1705 | cmp <1 1706 | bcc UM_SLASH_MOD_1 ; Yes, shift in 0 1707 | 1708 | UM_SLASH_MOD_2: lda <3 ; Reduce dividend 1709 | sbc <1 1710 | sta <3 1711 | bra UM_SLASH_MOD_1 ; Shift in 1 1712 | 1713 | UM_SLASH_MOD_3: lda #$ffff ; Overflowed set results 1714 | sta <3 1715 | sta <5 1716 | UM_SLASH_MOD_4: tdc ; Drop top word 1717 | inc a 1718 | inc a 1719 | tcd 1720 | jmp SWAP ; Swap quotient and remainder 1721 | 1722 | ;=============================================================================== 1723 | ; Comparisons 1724 | ;------------------------------------------------------------------------------- 1725 | 1726 | ; 0< ( n -- flag ) 1727 | ; 1728 | ; flag is true if and only if n is less than zero. 1729 | 1730 | HEADER 2,"0<",NORMAL 1731 | ZERO_LESS: 1732 | lda <1 ; Test top of stack 1733 | stz <1 ; Assume false result 1734 | bpl ZERO_LT_1 ; Was the value negative? 1735 | dec <1 ; Yes, make true result 1736 | ZERO_LT_1: CONTINUE ; Done 1737 | 1738 | ; 0<> ( x -- flag ) 1739 | ; 1740 | ; flag is true if and only if x is not equal to zero. 1741 | 1742 | HEADER 3,"0<>",NORMAL 1743 | ZERO_NOT_EQUAL: 1744 | lda <1 ; Test top of stack 1745 | stz <1 ; Assume false result 1746 | beq ZERO_NE_1 ; Was the value non-zero? 1747 | dec <1 ; Yes, make true result 1748 | ZERO_NE_1: CONTINUE ; Done 1749 | 1750 | ; 0= ( x -- flag ) 1751 | ; 1752 | ; flag is true if and only if x is equal to zero. 1753 | 1754 | HEADER 2,"0=",NORMAL 1755 | ZERO_EQUAL: 1756 | lda <1 ; Test top of stack 1757 | stz <1 ; Assume false result 1758 | bne ZERO_EQ_1 ; Was the value zero? 1759 | dec <1 ; Yes, make true result 1760 | ZERO_EQ_1: CONTINUE ; Done 1761 | 1762 | ; 0> ( n -- flag ) 1763 | ; 1764 | ; flag is true if and only if n is greater than zero. 1765 | 1766 | HEADER 2,"0>",NORMAL 1767 | ZERO_GREATER: 1768 | lda <1 ; Test top of stack 1769 | stz <1 ; Assume false result 1770 | bmi ZERO_GT_EXIT ; Was the value positive? 1771 | beq ZERO_GT_EXIT ; .. but not zero 1772 | dec <1 ; Yes, make true result 1773 | ZERO_GT_EXIT: CONTINUE ; Done 1774 | 1775 | ; < ( n1 n2 -- flag ) 1776 | ; 1777 | ; flag is true if and only if n1 is less than n2. 1778 | 1779 | HEADER 1,"<",NORMAL 1780 | LESS: jsr DO_COLON 1781 | dw SWAP 1782 | dw GREATER 1783 | dw EXIT 1784 | 1785 | ; <> ( x1 x2 -- flag ) 1786 | ; 1787 | ; flag is true if and only if x1 is not bit-for-bit the same as x2. 1788 | 1789 | HEADER 2,"<>",NORMAL 1790 | NOT_EQUAL: 1791 | ldx <1 ; Pull x2 from stack 1792 | tdc 1793 | inc a 1794 | inc a 1795 | tcd 1796 | cpx <1 ; Compare with x1 1797 | stz <1 ; Assume equal 1798 | beq NE_EXIT ; Test flags 1799 | dec <1 ; Make result true 1800 | NE_EXIT: CONTINUE ; Done 1801 | 1802 | ; = ( x1 x2 -- flag ) 1803 | ; 1804 | ; flag is true if and only if x1 is bit-for-bit the same as x2. 1805 | 1806 | HEADER 1,"=",NORMAL 1807 | EQUAL: 1808 | ldx <1 ; Pull x2 from stack 1809 | tdc 1810 | inc a 1811 | inc a 1812 | tcd 1813 | cpx <1 ; Compare with x1 1814 | stz <1 ; Assume not equal 1815 | bne EQ_EXIT ; Test the flags 1816 | dec <1 ; Make result true 1817 | EQ_EXIT: CONTINUE ; Done 1818 | 1819 | ; > ( n1 n2 -- flag ) 1820 | ; 1821 | ; flag is true if and only if n1 is greater than n2. 1822 | 1823 | HEADER 1,">",NORMAL 1824 | GREATER: 1825 | ldx <1 ; Pull x2 from stack 1826 | tdc 1827 | inc a 1828 | inc a 1829 | tcd 1830 | txa 1831 | sec ; Compare with x1 1832 | sbc <1 1833 | stz <1 ; Assume false result 1834 | bvc GREATER_1 1835 | eor #$8000 1836 | GREATER_1: bpl GREATER_2 ; V == 1 && N == 1 1837 | dec <1 1838 | GREATER_2: CONTINUE 1839 | 1840 | ; U< ( u1 u2 -- flag ) 1841 | ; 1842 | ; flag is true if and only if u1 is less than u2. 1843 | 1844 | HEADER 2,"U<",NORMAL 1845 | U_LESS: 1846 | ldx <1 ; Pull x2 1847 | tdc ; Drop from stack 1848 | inc a 1849 | inc a 1850 | tcd 1851 | cpx <1 ; Compare with x1 1852 | stz <1 ; Assume false 1853 | beq U_LESS_1 ; Equal 1854 | bcc U_LESS_1 ; Less 1855 | dec <1 1856 | U_LESS_1: CONTINUE 1857 | 1858 | ; U> ( u1 u2 -- flag ) 1859 | ; 1860 | ; flag is true if and only if u1 is greater than u2. 1861 | 1862 | HEADER 2,"U>",NORMAL 1863 | U_GREATER: jsr DO_COLON 1864 | dw SWAP 1865 | dw U_LESS 1866 | dw EXIT 1867 | 1868 | ;=============================================================================== 1869 | ; Logical Operations 1870 | ;------------------------------------------------------------------------------- 1871 | 1872 | ; AND ( x1 x2 -- x3 ) 1873 | ; 1874 | ; x3 is the bit-by-bit logical “and” of x1 with x2. 1875 | 1876 | HEADER 3,"AND",NORMAL 1877 | AND: 1878 | lda <1 1879 | and <3 1880 | sta <3 1881 | tdc 1882 | inc a 1883 | inc a 1884 | tcd 1885 | CONTINUE 1886 | 1887 | ; INVERT ( x1 -- x2 ) 1888 | ; 1889 | ; Invert all bits of x1, giving its logical inverse x2. 1890 | 1891 | HEADER 6,"INVERT",NORMAL 1892 | INVERT: 1893 | lda <1 ; Fetch top value 1894 | eor #$ffff ; Invert all the bits 1895 | sta <1 ; .. and write back 1896 | CONTINUE ; Done 1897 | 1898 | ; LSHIFT ( x1 u -- x2 ) 1899 | ; 1900 | ; Perform a logical left shift of u bit-places on x1, giving x2. Put zeroes 1901 | ; into the least significant bits vacated by the shift. An ambiguous condition 1902 | ; exists if u is greater than or equal to the number of bits in a cell. 1903 | 1904 | HEADER 6,"LSHIFT",NORMAL 1905 | LSHIFT: 1906 | ldx <1 ; Pull bit count 1907 | php 1908 | tdc 1909 | inc a ; .. from the stack 1910 | inc a 1911 | tcd 1912 | plp 1913 | beq LSHIFT_0 ; Zero shift? 1914 | cpx #16 ; Shifting by 16+ bits 1915 | bcs LSHIFT_2 ; Yes, result will be zero 1916 | LSHIFT_1 asl <1 ; Shift one bit left 1917 | dex ; Update count 1918 | bne LSHIFT_1 ; .. and repeat as needed 1919 | LSHIFT_0 CONTINUE ; Done 1920 | LSHIFT_2 stz <1 ; Clear top value 1921 | CONTINUE ; Done 1922 | 1923 | ; OR ( x1 x2 -- x3 ) 1924 | ; 1925 | ; x3 is the bit-by-bit inclusive-or of x1 with x2. 1926 | 1927 | HEADER 2,"OR",NORMAL 1928 | OR: 1929 | lda <1 1930 | ora <3 1931 | sta <3 1932 | tdc 1933 | inc a 1934 | inc a 1935 | tcd 1936 | CONTINUE 1937 | 1938 | ; RSHIFT ( x1 u -- x2 ) 1939 | ; 1940 | ; Perform a logical right shift of u bit-places on x1, giving x2. Put zeroes 1941 | ; into the most significant bits vacated by the shift. An ambiguous condition 1942 | ; exists if u is greater than or equal to the number of bits in a cell. 1943 | 1944 | HEADER 6,"RSHIFT",NORMAL 1945 | RSHIFT: 1946 | ldx <1 ; Pull bit count 1947 | php 1948 | tdc 1949 | inc a ; .. from the stack 1950 | inc a 1951 | tcd 1952 | plp 1953 | beq RSHIFT_0 ; Zero shift? 1954 | cpx #16 ; Shifting by 16+ bits 1955 | bcs RSHIFT_2 ; Yes, result will be zero 1956 | RSHIFT_1 lsr <1 ; Shift one bit left 1957 | dex ; Update count 1958 | bne RSHIFT_1 ; .. and repeat as needed 1959 | RSHIFT_0 CONTINUE ; Done 1960 | RSHIFT_2 stz <1 ; Clear top value 1961 | CONTINUE ; Done 1962 | 1963 | ; XOR ( x1 x2 -- x3 ) 1964 | ; 1965 | ; x3 is the bit-by-bit exclusive-or of x1 with x2. 1966 | 1967 | HEADER 3,"XOR",NORMAL 1968 | XOR: 1969 | lda <1 1970 | eor <3 1971 | sta <3 1972 | tdc 1973 | inc a 1974 | inc a 1975 | tcd 1976 | CONTINUE 1977 | 1978 | ;=============================================================================== 1979 | ; Control Words 1980 | ;------------------------------------------------------------------------------- 1981 | 1982 | ; ?ABORT 1983 | ; 1984 | ; ROT IF TYPE ABORT THEN 2DROP ; 1985 | 1986 | QUERY_ABORT: jsr DO_COLON 1987 | dw ROT 1988 | dw QUERY_BRANCH,QUERY_ABORT_1 1989 | dw TYPE 1990 | dw ABORT 1991 | QUERY_ABORT_1: dw TWO_DROP 1992 | dw EXIT 1993 | 1994 | ; ABORT ( i*x -- ) ( R: j*x -- ) 1995 | ; 1996 | ; Empty the data stack and perform the function of QUIT, which includes 1997 | ; emptying the return stack, without displaying a message. 1998 | 1999 | HEADER 5,"ABORT",NORMAL 2000 | ABORT: jsr DO_COLON 2001 | dw DO_ABORT 2002 | dw QUIT 2003 | 2004 | DO_ABORT: 2005 | lda #DSTACK_END-1 2006 | tcd 2007 | CONTINUE 2008 | 2009 | ; (BUILD) ( dtc-addr -- ) 2010 | ; 2011 | ; Adds a jump the to exection function for the new word. 2012 | 2013 | ; HEADER 7,"(BUILD)",NORMAL 2014 | BUILD: jsr DO_COLON 2015 | dw DO_LITERAL,$20 2016 | dw C_COMMA 2017 | dw COMMA 2018 | dw EXIT 2019 | 2020 | ; CREATE ( -- ) 2021 | ; 2022 | ; Skip leading space delimiters. Parse name delimited by a space. Create a 2023 | ; definition for name with the execution semantics defined below. If the data- 2024 | ; space pointer is not aligned, reserve enough data space to align it. The new 2025 | ; data-space pointer defines name’s data field. CREATE does not allocate data 2026 | ; space in name’s data field. 2027 | 2028 | HEADER 6,"CREATE",NORMAL 2029 | CREATE: jsr DO_COLON 2030 | dw LATEST 2031 | dw FETCH 2032 | dw COMMA 2033 | dw ZERO 2034 | dw C_COMMA 2035 | dw HERE 2036 | dw LATEST 2037 | dw STORE 2038 | dw BL 2039 | dw WORD 2040 | dw C_FETCH 2041 | dw ONE_PLUS 2042 | dw ALLOT 2043 | dw EXIT 2044 | 2045 | ; EXECUTE ( i*x xt -- j*x ) 2046 | ; 2047 | ; Remove xt from the stack and perform the semantics identified by it. Other 2048 | ; stack effects are due to the word EXECUTEd. 2049 | 2050 | HEADER 7,"EXECUTE",NORMAL 2051 | EXECUTE: 2052 | ldx <1 2053 | tdc 2054 | inc a 2055 | inc a 2056 | tcd 2057 | dex 2058 | phx 2059 | rts 2060 | 2061 | ; EXIT ( -- ) ( R: nest-sys -- ) 2062 | ; 2063 | ; Return control to the calling definition specified by nest-sys. Before 2064 | ; executing EXIT within a do-loop, a program shall discard the loop-control 2065 | ; parameters by executing UNLOOP. 2066 | 2067 | HEADER 4,"EXIT",NORMAL 2068 | EXIT: 2069 | ply 2070 | CONTINUE 2071 | 2072 | ; QUIT ( -- ) ( R: i*x -- ) 2073 | ; 2074 | ; Empty the return stack, store zero in SOURCE-ID if it is present, make the 2075 | ; user input device the input source, and enter interpretation state. Do not 2076 | ; display a message. Repeat the following: 2077 | ; – Accept a line from the input source into the input buffer, set >IN to zero, 2078 | ; and interpret. 2079 | ; – Display the implementation-defined system prompt if in interpretation state, 2080 | ; all processing has been completed, and no ambiguous condition exists. 2081 | ; 2082 | ; In this implementation it is defined as: 2083 | ; 2084 | ; DO_QUIT 0 STATE ! 2085 | ; 0 (SOURCE-ID) ! 2086 | ; BEGIN 2087 | ; REFILL 2088 | ; WHILE SOURCE EVALUATE 2089 | ; STATE @ 0= IF S" Ok" CR TYPE THEN 2090 | ; AGAIN ; 2091 | 2092 | HEADER 4,"QUIT",NORMAL 2093 | QUIT: jsr DO_COLON 2094 | dw DO_QUIT 2095 | dw ZERO 2096 | dw STATE 2097 | dw STORE 2098 | dw ZERO 2099 | dw SOURCEID 2100 | dw STORE 2101 | QUIT_1: dw REFILL 2102 | dw QUERY_BRANCH,QUIT_2 2103 | dw INTERPRET 2104 | QUIT_2: dw STATE 2105 | dw FETCH 2106 | dw ZERO_EQUAL 2107 | dw QUERY_BRANCH,QUIT_3 2108 | dw DO_S_QUOTE 2109 | db 2,"Ok" 2110 | dw TYPE 2111 | dw CR 2112 | QUIT_3: dw BRANCH,QUIT_1 2113 | 2114 | DO_QUIT: 2115 | lda #RSTACK_END-1 ; Reset the return stack 2116 | tcs 2117 | CONTINUE ; Done 2118 | 2119 | ;=============================================================================== 2120 | ; Parser & Interpreter 2121 | ;------------------------------------------------------------------------------- 2122 | 2123 | ; ?NUMBER 2124 | ; 2125 | ; DUP 0 0 ROT COUNT -- ca ud adr n 2126 | ; ?SIGN >R >NUMBER -- ca ud adr' n' 2127 | ; IF R> 2DROP 2DROP 0 -- ca 0 (error) 2128 | ; ELSE 2DROP NIP R> 2129 | ; IF NEGATE THEN -1 -- n -1 (ok) 2130 | ; THEN ; 2131 | 2132 | HEADER 7,"?NUMBER",NORMAL 2133 | QUERY_NUMBER: jsr DO_COLON 2134 | dw DUP 2135 | dw ZERO 2136 | dw ZERO 2137 | dw ROT 2138 | dw COUNT 2139 | dw QUERY_SIGN 2140 | dw TO_R 2141 | dw TO_NUMBER 2142 | dw QUERY_BRANCH,QNUM_1 2143 | dw R_FROM 2144 | dw TWO_DROP 2145 | dw TWO_DROP 2146 | dw ZERO 2147 | dw BRANCH,QNUM_3 2148 | QNUM_1: dw TWO_DROP 2149 | dw NIP 2150 | dw R_FROM 2151 | dw QUERY_BRANCH,QNUM_2 2152 | dw NEGATE 2153 | QNUM_2: dw DO_LITERAL,-1 2154 | QNUM_3: dw EXIT 2155 | 2156 | ; ?SIGN ( c-addr n -- adr' n' f ) 2157 | ; 2158 | ; OVER C@ -- adr n c 2159 | ; 2C - DUP ABS 1 = AND -- +=-1, -=+1, else 0 2160 | ; DUP IF 1+ -- +=0, -=+2 2161 | ; >R 1 /STRING R> -- adr' n' f 2162 | ; THEN ; 2163 | 2164 | HEADER 5,"?SIGN",NORMAL 2165 | QUERY_SIGN: jsr DO_COLON 2166 | dw OVER 2167 | dw C_FETCH 2168 | dw DO_LITERAL,',' 2169 | dw MINUS 2170 | dw DUP 2171 | dw ABS 2172 | dw DO_LITERAL,1 2173 | dw EQUAL 2174 | dw AND 2175 | dw DUP 2176 | dw QUERY_BRANCH,QSIGN_1 2177 | dw ONE_PLUS 2178 | dw TO_R 2179 | dw DO_LITERAL,1 2180 | dw SLASH_STRING 2181 | dw R_FROM 2182 | QSIGN_1: dw EXIT 2183 | 2184 | ; >COUNTED ( c-addr n -- ) 2185 | ; 2186 | ; 2DUP C! CHAR+ SWAP CMOVE 2187 | 2188 | TO_COUNTED: jsr DO_COLON 2189 | dw TWO_DUP 2190 | dw C_STORE 2191 | dw CHAR_PLUS 2192 | dw SWAP 2193 | dw CMOVE 2194 | dw EXIT 2195 | 2196 | ; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 2197 | ; 2198 | ; ud2 is the unsigned result of converting the characters within the string 2199 | ; specified by c-addr1 u1 into digits, using the number in BASE, and adding 2200 | ; each into ud1 after multiplying ud1 by the number in BASE. Conversion 2201 | ; continues left-to-right until a character that is not convertible, including 2202 | ; any “+” or “-”, is encountered or the string is entirely converted. c-addr2 2203 | ; is the location of the first unconverted character or the first character 2204 | ; past the end of the string if the string was entirely converted. u2 is the 2205 | ; number of unconverted characters in the string. An ambiguous condition exists 2206 | ; if ud2 overflows during the conversion. 2207 | ; 2208 | ; In this implementation its is defined as: 2209 | ; 2210 | ; BEGIN 2211 | ; DUP WHILE 2212 | ; OVER C@ DIGIT? 2213 | ; 0= IF DROP EXIT THEN 2214 | ; >R 2SWAP BASE @ UD* 2215 | ; R> M+ 2SWAP 2216 | ; 1 /STRING 2217 | ; REPEAT ; 2218 | 2219 | HEADER 7,">NUMBER",NORMAL 2220 | TO_NUMBER: jsr DO_COLON 2221 | TO_NUM_1: dw DUP 2222 | dw QUERY_BRANCH,TO_NUM_3 2223 | dw OVER 2224 | dw C_FETCH 2225 | dw DIGIT_QUERY 2226 | dw ZERO_EQUAL 2227 | dw QUERY_BRANCH,TO_NUM_2 2228 | dw DROP 2229 | dw EXIT 2230 | TO_NUM_2: dw TO_R 2231 | dw TWO_SWAP 2232 | dw BASE 2233 | dw FETCH 2234 | dw UD_STAR 2235 | dw R_FROM 2236 | dw M_PLUS 2237 | dw TWO_SWAP 2238 | dw DO_LITERAL,1 2239 | dw SLASH_STRING 2240 | dw BRANCH,TO_NUM_1 2241 | TO_NUM_3: dw EXIT 2242 | 2243 | ; ACCEPT ( c-addr +n1 -- +n2 ) 2244 | ; 2245 | ; Receive a string of at most +n1 characters. An ambiguous condition exists if 2246 | ; +n1 is zero or greater than 32,767. Display graphic characters as they are 2247 | ; received. A program that depends on the presence or absence of non-graphic 2248 | ; characters in the string has an environmental dependency. The editing 2249 | ; functions, if any, that the system performs in order to construct the string 2250 | ; are implementation-defined. 2251 | ; 2252 | ; Input terminates when an implementation-defined line terminator is received. 2253 | ; When input terminates, nothing is appended to the string, and the display is 2254 | ; maintained in an implementation-defined way. 2255 | ; 2256 | ; +n2 is the length of the string stored at c-addr. 2257 | ; 2258 | ; In this implementation it is defined as: 2259 | ; 2260 | ; OVER + 1- OVER -- sa ea a 2261 | ; BEGIN KEY -- sa ea a c 2262 | ; DUP 0D <> WHILE 2263 | ; DUP 8 = OVER 127 = OR IF 2264 | ; DROP 1- 2265 | ; >R OVER R> UMAX 2266 | ; 8 EMIT SPACE 8 EMIT 2267 | ; ELSE 2268 | ; DUP EMIT -- sa ea a c 2269 | ; OVER C! 1+ OVER UMIN 2270 | ; THEN -- sa ea a 2271 | ; REPEAT -- sa ea a c 2272 | ; DROP NIP SWAP - ; 2273 | 2274 | HEADER 6,"ACCEPT",NORMAL 2275 | ACCEPT: jsr DO_COLON 2276 | dw OVER 2277 | dw PLUS 2278 | dw ONE_MINUS 2279 | dw OVER 2280 | ACCEPT_1: dw KEY 2281 | dw DUP 2282 | dw DO_LITERAL,$0D 2283 | dw NOT_EQUAL 2284 | dw QUERY_BRANCH,ACCEPT_4 2285 | dw DUP 2286 | dw DO_LITERAL,$08 2287 | dw EQUAL 2288 | dw OVER 2289 | dw DO_LITERAL,$7f 2290 | dw EQUAL 2291 | dw OR 2292 | dw QUERY_BRANCH,ACCEPT_2 2293 | dw DROP 2294 | dw ONE_MINUS 2295 | dw TO_R 2296 | dw OVER 2297 | dw R_FROM 2298 | dw UMAX 2299 | dw DO_LITERAL,8 2300 | dw EMIT 2301 | dw SPACE 2302 | dw DO_LITERAL,8 2303 | dw EMIT 2304 | dw BRANCH,ACCEPT_3 2305 | ACCEPT_2: dw DUP 2306 | dw EMIT 2307 | dw OVER 2308 | dw C_STORE 2309 | dw ONE_PLUS 2310 | dw OVER 2311 | dw UMIN 2312 | ACCEPT_3: dw BRANCH,ACCEPT_1 2313 | ACCEPT_4: dw DROP 2314 | dw NIP 2315 | dw SWAP 2316 | dw MINUS 2317 | dw EXIT 2318 | 2319 | ; DIGIT? 2320 | ; 2321 | ; [ HEX ] DUP 39 > 100 AND + silly looking 2322 | ; DUP 140 > 107 AND - 30 - but it works! 2323 | ; DUP BASE @ U< ; 2324 | 2325 | HEADER 6,"DIGIT?",NORMAL 2326 | DIGIT_QUERY: jsr DO_COLON 2327 | dw DUP 2328 | dw DO_LITERAL,'9' 2329 | dw GREATER 2330 | dw DO_LITERAL,$100 2331 | dw AND 2332 | dw PLUS 2333 | dw DUP 2334 | dw DO_LITERAL,$140 2335 | dw GREATER 2336 | dw DO_LITERAL,$107 2337 | dw AND 2338 | dw MINUS 2339 | dw DO_LITERAL,'0' 2340 | dw MINUS 2341 | dw DUP 2342 | dw BASE 2343 | dw FETCH 2344 | dw U_LESS 2345 | dw EXIT 2346 | 2347 | ; EVALUATE ( i*x c-addr u -- j*x ) 2348 | ; 2349 | ; Save the current input source specification. Store minus-one (-1) in 2350 | ; SOURCE-ID if it is present. Make the string described by c-addr and u both 2351 | ; the input source and input buffer, set >IN to zero, and interpret. When the 2352 | ; parse area is empty, restore the prior input source specification. Other 2353 | ; stack effects are due to the words EVALUATEd. 2354 | ; 2355 | ; >R >R SAVE-INPUT 2356 | ; -1 (SOURCE-ID) ! 2357 | ; 0 >IN ! (LENGTH) ! (BUFFER) ! 2358 | ; INTERPRET 2359 | ; RESTORE-INPUT DROP 2360 | 2361 | HEADER 8,"EVALUATE",NORMAL 2362 | EVALUATE: jsr DO_COLON 2363 | dw TO_R 2364 | dw TO_R 2365 | dw SAVE_INPUT 2366 | dw R_FROM 2367 | dw R_FROM 2368 | dw TRUE 2369 | dw SOURCEID 2370 | dw STORE 2371 | dw ZERO 2372 | dw TO_IN 2373 | dw STORE 2374 | dw LENGTH 2375 | dw STORE 2376 | dw BUFFER 2377 | dw STORE 2378 | dw INTERPRET 2379 | dw RESTORE_INPUT 2380 | dw DROP 2381 | dw EXIT 2382 | 2383 | ; INTERPRET ( -- ) 2384 | ; 2385 | ; 2386 | ; BEGIN 2387 | ; BL WORD DUP C@ WHILE -- textadr 2388 | ; FIND -- a 0/1/-1 2389 | ; ?DUP IF -- xt 1/-1 2390 | ; 1+ STATE @ 0= OR immed or interp? 2391 | ; IF EXECUTE ELSE , THEN 2392 | ; ELSE -- textadr 2393 | ; ?NUMBER 2394 | ; IF STATE @ 2395 | ; IF POSTPONE LITERAL THEN converted ok 2396 | ; ELSE COUNT TYPE 3F EMIT CR ABORT err 2397 | ; THEN 2398 | ; THEN 2399 | ; REPEAT DROP ; 2400 | 2401 | HEADER 9,"INTERPRET",NORMAL 2402 | INTERPRET: jsr DO_COLON 2403 | INTERPRET_1: dw BL 2404 | dw WORD 2405 | dw DUP 2406 | dw C_FETCH 2407 | dw QUERY_BRANCH,INTERPRET_7 2408 | dw FIND 2409 | dw QUERY_DUP 2410 | dw QUERY_BRANCH,INTERPRET_4 2411 | dw ONE_PLUS 2412 | dw STATE 2413 | dw FETCH 2414 | dw ZERO_EQUAL 2415 | dw OR 2416 | dw QUERY_BRANCH,INTERPRET_2 2417 | dw EXECUTE 2418 | dw BRANCH,INTERPRET_3 2419 | INTERPRET_2: dw COMMA 2420 | INTERPRET_3: dw BRANCH,INTERPRET_6 2421 | INTERPRET_4: dw QUERY_NUMBER 2422 | dw QUERY_BRANCH,INTERPRET_5 2423 | dw STATE 2424 | dw FETCH 2425 | dw QUERY_BRANCH,INTERPRET_6 2426 | dw LITERAL 2427 | dw BRANCH,INTERPRET_6 2428 | INTERPRET_5: dw COUNT 2429 | dw TYPE 2430 | dw DO_LITERAL,$3f 2431 | dw EMIT 2432 | dw CR 2433 | dw ABORT 2434 | INTERPRET_6 dw BRANCH,INTERPRET_1 2435 | INTERPRET_7: dw DROP 2436 | dw EXIT 2437 | 2438 | ; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2439 | ; 2440 | ; Find the definition named in the counted string at c-addr. If the definition 2441 | ; is not found, return c-addr and zero. If the definition is found, return its 2442 | ; execution token xt. If the definition is immediate, also return one (1), 2443 | ; otherwise also return minus-one (-1). For a given string, the values returned 2444 | ; by FIND while compiling may differ from those returned while not compiling. 2445 | ; 2446 | ; In this implementation it is defined as: 2447 | ; 2448 | ; LATEST @ BEGIN -- a nfa 2449 | ; 2DUP OVER C@ CHAR+ -- a nfa a nfa n+1 2450 | ; S= -- a nfa f 2451 | ; DUP IF 2452 | ; DROP 2453 | ; NFA>LFA @ DUP -- a link link 2454 | ; THEN 2455 | ; 0= UNTIL -- a nfa OR a 0 2456 | ; DUP IF 2457 | ; NIP DUP NFA>CFA -- nfa xt 2458 | ; SWAP IMMED? -- xt iflag 2459 | ; 0= 1 OR -- xt 1/-1 2460 | ; THEN ; 2461 | 2462 | HEADER 4,"FIND",NORMAL 2463 | FIND: jsr DO_COLON 2464 | dw LATEST 2465 | dw FETCH 2466 | FIND1: dw TWO_DUP 2467 | dw OVER 2468 | dw C_FETCH 2469 | dw CHAR_PLUS 2470 | dw S_EQUAL 2471 | dw DUP 2472 | dw QUERY_BRANCH,FIND2 2473 | dw DROP 2474 | dw NFA_TO_LFA 2475 | dw FETCH 2476 | dw DUP 2477 | FIND2: dw ZERO_EQUAL 2478 | dw QUERY_BRANCH,FIND1 2479 | dw DUP 2480 | dw QUERY_BRANCH,FIND3 2481 | dw NIP 2482 | dw DUP 2483 | dw NFA_TO_CFA 2484 | dw SWAP 2485 | dw IMMED_QUERY 2486 | dw ZERO_EQUAL 2487 | dw DO_LITERAL,1 2488 | dw OR 2489 | FIND3: dw EXIT 2490 | 2491 | ; IMMED? ( nfa -- f ) 2492 | 2493 | IMMED_QUERY: jsr DO_COLON 2494 | dw ONE_MINUS 2495 | dw C_FETCH 2496 | dw EXIT 2497 | 2498 | ; NFA>CFA ( nfa -- cfa ) 2499 | 2500 | NFA_TO_CFA: jsr DO_COLON 2501 | dw COUNT 2502 | dw PLUS 2503 | dw EXIT 2504 | 2505 | ; NFA>LFA ( nfa -- lfa ) 2506 | 2507 | NFA_TO_LFA: jsr DO_COLON 2508 | dw DO_LITERAL,3 2509 | dw MINUS 2510 | dw EXIT 2511 | 2512 | ; REFILL ( -- flag ) 2513 | ; 2514 | ; Attempt to fill the input buffer from the input source, returning a true flag 2515 | ; if successful. 2516 | ; 2517 | ; When the input source is the user input device, attempt to receive input into 2518 | ; the terminal input buffer. If successful, make the result the input buffer, 2519 | ; set >IN to zero, and return true. Receipt of a line containing no characters 2520 | ; is considered successful. If there is no input available from the current 2521 | ; input source, return false. 2522 | ; 2523 | ; When the input source is a string from EVALUATE, return false and perform no 2524 | ; other action. 2525 | ; 2526 | ; In this implementation it is defined as: 2527 | ; 2528 | ; SOURCE-ID 0= IF 2529 | ; TIB DUP #TIB @ ACCEPT SPACE 2530 | ; LENGTH ! BUFFER ! 2531 | ; 0 >IN ! TRUE EXIT 2532 | ; THEN 2533 | ; FALSE 2534 | 2535 | HEADER 6,"REFILL",NORMAL 2536 | REFILL: jsr DO_COLON 2537 | dw SOURCE_ID 2538 | dw ZERO_EQUAL 2539 | dw QUERY_BRANCH,REFILL_1 2540 | dw TIB 2541 | dw DUP 2542 | dw HASH_TIB 2543 | dw FETCH 2544 | dw ACCEPT 2545 | dw SPACE 2546 | dw LENGTH 2547 | dw STORE 2548 | dw BUFFER 2549 | dw STORE 2550 | dw ZERO 2551 | dw TO_IN 2552 | dw STORE 2553 | dw TRUE 2554 | dw EXIT 2555 | REFILL_1: dw FALSE 2556 | dw EXIT 2557 | 2558 | ; RESTORE-INPUT ( xn ... x1 n -- flag ) 2559 | ; 2560 | ; Attempt to restore the input source specification to the state described by 2561 | ; x1 through xn. flag is true if the input source specification cannot be so 2562 | ; restored. 2563 | ; 2564 | ; An ambiguous condition exists if the input source represented by the 2565 | ; arguments is not the same as the current input source. 2566 | ; 2567 | ; In this implementation it is defined as: 2568 | ; 2569 | ; >IN ! (LENGTH) ! BUFFER ! 2570 | ; SOURCEID ! 2571 | ; TRUE 2572 | 2573 | HEADER 13,"RESTORE-INPUT",NORMAL 2574 | RESTORE_INPUT jsr DO_COLON 2575 | dw TO_IN 2576 | dw STORE 2577 | dw LENGTH 2578 | dw STORE 2579 | dw BUFFER 2580 | dw STORE 2581 | dw SOURCEID 2582 | dw STORE 2583 | dw TRUE 2584 | dw EXIT 2585 | 2586 | ; S= ( c-addr1 caddr2 u -- n) 2587 | ; 2588 | ; Misnamed, more like C's strncmp. Note that counted length bytes are compared! 2589 | 2590 | S_EQUAL: 2591 | phy 2592 | ldx <1 ; Fetch maximum length 2593 | beq S_EQUAL_3 2594 | ldy #0 2595 | short_a 2596 | S_EQUAL_1: 2597 | lda (5),y ; Compare bytes 2598 | cmp (3),y 2599 | bne S_EQUAL_2 2600 | iny 2601 | dex ; End of strings? 2602 | bne S_EQUAL_1 ; No 2603 | bra S_EQUAL_3 ; Yes. must be the same 2604 | S_EQUAL_2: 2605 | ldx #$ffff ; Difference found 2606 | S_EQUAL_3: 2607 | long_a 2608 | tdc ; Clean up the stack 2609 | inc a 2610 | inc a 2611 | inc a 2612 | inc a 2613 | tcd 2614 | stx <1 ; Save the flag 2615 | ply 2616 | CONTINUE 2617 | 2618 | ; SAVE-INPUT ( -- xn ... x1 n ) 2619 | ; 2620 | ; x1 through xn describe the current state of the input source specification 2621 | ; for later use by RESTORE-INPUT. 2622 | 2623 | HEADER 10,"SAVE-INPUT",NORMAL 2624 | SAVE_INPUT: jsr DO_COLON 2625 | dw SOURCEID 2626 | dw FETCH 2627 | dw BUFFER 2628 | dw FETCH 2629 | dw LENGTH 2630 | dw FETCH 2631 | dw TO_IN 2632 | dw FETCH 2633 | dw EXIT 2634 | 2635 | ; SCAN ( c-addr n c == c-addr' n' ) 2636 | 2637 | SCAN: 2638 | SCAN_1: 2639 | lda <3 ; Any data left to scan? 2640 | beq SCAN_2 ; No. 2641 | lda <1 ; Fetch and compare with scan 2642 | short_a 2643 | cmp (5) 2644 | long_a 2645 | beq SCAN_2 2646 | inc <5 2647 | dec <3 2648 | bra SCAN_1 2649 | SCAN_2: 2650 | jmp DROP ; Drop the character 2651 | 2652 | ; SKIP ( c-addr n c == c-addr' n' ) 2653 | 2654 | SKIP: 2655 | SKIP_1: lda <3 ; Any data left to skip over? 2656 | beq SKIP_2 ; No. 2657 | lda <1 ; Fetch and compare with skip 2658 | short_a 2659 | cmp (5) 2660 | long_a 2661 | bne SKIP_2 ; Cannot be skipped 2662 | inc <5 ; Bump data address 2663 | dec <3 ; and update length 2664 | bra SKIP_1 ; And repeat 2665 | SKIP_2: 2666 | jmp DROP ; Drop the character 2667 | 2668 | ; SOURCE ( -- c-addr u ) 2669 | ; 2670 | ; c-addr is the address of, and u is the number of characters in, the input 2671 | ; buffer. 2672 | ; 2673 | ; In this implementation it is defined as 2674 | ; 2675 | ; BUFFER @ LENGTH @ 2676 | 2677 | HEADER 6,"SOURCE",NORMAL 2678 | SOURCE: jsr DO_COLON 2679 | dw BUFFER 2680 | dw FETCH 2681 | dw LENGTH 2682 | dw FETCH 2683 | dw EXIT 2684 | 2685 | ; SOURCE-ID ( -- 0 | -1 ) 2686 | ; 2687 | ; Identifies the input source: -1 if string (via EVALUATE), 0 if user input 2688 | ; device. 2689 | 2690 | HEADER 9,"SOURCE-ID",NORMAL 2691 | SOURCE_ID: jsr DO_COLON 2692 | dw SOURCEID 2693 | dw FETCH 2694 | dw EXIT 2695 | 2696 | ; WORD ( char “ccc” -- c-addr ) 2697 | ; 2698 | ; Skip leading delimiters. Parse characters ccc delimited by char. An 2699 | ; ambiguous condition exists if the length of the parsed string is greater 2700 | ; than the implementation-defined length of a counted string. 2701 | ; 2702 | ; c-addr is the address of a transient region containing the parsed word as 2703 | ; a counted string. If the parse area was empty or contained no characters 2704 | ; other than the delimiter, the resulting string has a zero length. A space, 2705 | ; not included in the length, follows the string. A program may replace 2706 | ; characters within the string. 2707 | ; 2708 | ; In this implementation it is defined as: 2709 | ; 2710 | ; DUP SOURCE >IN @ /STRING -- c c adr n 2711 | ; DUP >R ROT SKIP -- c adr' n' 2712 | ; OVER >R ROT SCAN -- adr" n" 2713 | ; DUP IF CHAR- THEN skip trailing delim. 2714 | ; R> R> ROT - >IN +! update >IN offset 2715 | ; TUCK - -- adr' N 2716 | ; HERE >counted -- 2717 | ; HERE -- a 2718 | ; BL OVER COUNT + C! ; append trailing blank 2719 | 2720 | HEADER 4,"WORD",NORMAL 2721 | WORD: jsr DO_COLON 2722 | dw DUP 2723 | dw SOURCE 2724 | dw TO_IN 2725 | dw FETCH 2726 | dw SLASH_STRING 2727 | dw DUP 2728 | dw TO_R 2729 | dw ROT 2730 | dw SKIP 2731 | dw OVER 2732 | dw TO_R 2733 | dw ROT 2734 | dw SCAN 2735 | dw DUP 2736 | dw QUERY_BRANCH,WORD_1 2737 | dw CHAR_MINUS 2738 | WORD_1: dw R_FROM 2739 | dw R_FROM 2740 | dw ROT 2741 | dw MINUS 2742 | dw TO_IN 2743 | dw PLUS_STORE 2744 | dw TUCK 2745 | dw MINUS 2746 | dw HERE 2747 | dw TO_COUNTED 2748 | dw HERE 2749 | dw BL 2750 | dw OVER 2751 | dw COUNT 2752 | dw PLUS 2753 | dw C_STORE 2754 | dw EXIT 2755 | 2756 | ;=============================================================================== 2757 | ; String Words 2758 | ;------------------------------------------------------------------------------- 2759 | 2760 | ; -TRAILING ( c-addr u1 -- c-addr u2 ) 2761 | ; 2762 | ; If u1 is greater than zero, u2 is equal to u1 less the number of spaces at 2763 | ; the end of the character string specified by c-addr u1. If u1 is zero or the 2764 | ; entire string consists of spaces, u2 is zero. 2765 | 2766 | HEADER 9,"-TRAILING",NORMAL 2767 | DASH_TRAILING: 2768 | phy ; Save IP 2769 | ldy <1 ; Is u1 > 0? 2770 | beq DASH_TRAIL_3 ; No 2771 | short_a 2772 | dey ; Convert to offset 2773 | DASH_TRAIL_1: lda (3),y ; Space character at end? 2774 | cmp #' ' 2775 | bne DASH_TRAIL_2 ; No 2776 | dey ; More characters to check? 2777 | bpl DASH_TRAIL_1 ; Yes 2778 | DASH_TRAIL_2: long_a 2779 | iny ; Convert to length 2780 | DASH_TRAIL_3: sty <1 ; Update 2781 | ply ; Restore IP 2782 | CONTINUE ; Done 2783 | 2784 | ; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) 2785 | ; 2786 | ; Adjust the character string at c-addr1 by n characters. The resulting 2787 | ; character string, specified by c-addr2 u2, begins at c-addr1 plus n; 2788 | ; characters and is u1 minus n characters long. 2789 | ; 2790 | ; In this implementation it is defined as: 2791 | ; 2792 | ; ROT OVER + ROT ROT - 2793 | 2794 | HEADER 7,"/STRING",NORMAL 2795 | SLASH_STRING: jsr DO_COLON 2796 | dw ROT 2797 | dw OVER 2798 | dw PLUS 2799 | dw ROT 2800 | dw ROT 2801 | dw MINUS 2802 | dw EXIT 2803 | 2804 | ; BLANK ( c-addr u -- ) 2805 | ; 2806 | ; If u is greater than zero, store the character value for space in u 2807 | ; consecutive character positions beginning at c-addr. 2808 | ; 2809 | ; In this implementation it is defined as 2810 | ; 2811 | ; ?DUP IF OVER + SWAP DO BL I C! LOOP ELSE DROP THEN 2812 | 2813 | HEADER 5,"BLANK",NORMAL 2814 | BLANK: jsr DO_COLON 2815 | dw QUERY_DUP 2816 | dw QUERY_BRANCH,BLANK_2 2817 | dw OVER 2818 | dw PLUS 2819 | dw SWAP 2820 | dw DO_DO 2821 | BLANK_1: dw BL 2822 | dw I 2823 | dw C_STORE 2824 | dw DO_LOOP,BLANK_1 2825 | dw EXIT 2826 | BLANK_2: dw DROP 2827 | dw EXIT 2828 | 2829 | ; CMOVE ( c-addr1 c-addr2 u -- ) 2830 | ; 2831 | ; If u is greater than zero, copy u consecutive characters from the data space 2832 | ; starting at c-addr1 to that starting at c-addr2, proceeding character-by- 2833 | ; character from lower addresses to higher addresses. 2834 | 2835 | HEADER 5,"CMOVE",NORMAL 2836 | CMOVE: 2837 | phy 2838 | ldx <1 ; Any characters to move? 2839 | beq CMOVE_2 ; No 2840 | ldy #0 2841 | short_a 2842 | CMOVE_1: ; Transfer a byte 2843 | lda (5),y 2844 | sta (3),y 2845 | iny 2846 | dex ; Decrement count 2847 | bne CMOVE_1 ; .. and repeat until done 2848 | long_a 2849 | CMOVE_2: 2850 | tdc ; Clean up the stack 2851 | clc 2852 | adc #6 2853 | tcd 2854 | ply 2855 | CONTINUE ; Done 2856 | 2857 | ; CMOVE> ( c-addr1 c-addr2 u -- ) 2858 | ; 2859 | ; If u is greater than zero, copy u consecutive characters from the data space 2860 | ; starting at c-addr1 to that starting at c-addr2, proceeding character-by- 2861 | ; character from higher addresses to lower addresses. 2862 | 2863 | HEADER 6,"CMOVE>",NORMAL 2864 | CMOVE_GREATER: 2865 | phy 2866 | ldx <1 ; Any characters to move? 2867 | beq CMOVE_GT_2 ; No. 2868 | ldy <1 2869 | short_a 2870 | CMOVE_GT_1: 2871 | dey ; Transfer a byte 2872 | lda (5),y 2873 | sta (3),y 2874 | dex ; Decrement length 2875 | bne CMOVE_GT_1 ; .. and repeat until done 2876 | long_a 2877 | CMOVE_GT_2: 2878 | tdc ; Clean up the stack 2879 | clc 2880 | adc #6 2881 | tcd 2882 | ply 2883 | CONTINUE ; Done 2884 | 2885 | ; COMPARE ( c-addr1 u1 c-addr2 u2 -- n ) 2886 | ; 2887 | ; Compare the string specified by c-addr1 u1 to the string specified by c-addr2 2888 | ; u2. The strings are compared, beginning at the given addresses, character by 2889 | ; character, up to the length of the shorter string or until a difference is 2890 | ; found. If the two strings are identical, n is zero. If the two strings are 2891 | ; identical up to the length of the shorter string, n is minus-one (-1) if u1 2892 | ; is less than u2 and one (1) otherwise. If the two strings are not identical 2893 | ; up to the length of the shorter string, n is minus-one (-1) if the first 2894 | ; non-matching character in the string specified by c-addr1 u1 has a lesser 2895 | ; numeric value than the corresponding character in the string specified by 2896 | ; c-addr2 u2 and one (1) otherwise. 2897 | 2898 | HEADER 7,"COMPARE",NORMAL 2899 | COMPARE: 2900 | lda <1 ; Both string lengths zero? 2901 | ora <5 2902 | beq COMPARE_X ; Yes, must be equal 2903 | 2904 | lda <1 ; Second string length zero? 2905 | beq COMPARE_P ; Yes, must be shorter 2906 | lda <5 ; First string length zero? 2907 | beq COMPARE_N ; Yes, must be shorter 2908 | short_a 2909 | lda (7) ; Compare next characters 2910 | cmp (3) 2911 | long_a 2912 | bcc COMPARE_N 2913 | bne COMPARE_P 2914 | 2915 | inc <3 ; Bump string pointers 2916 | inc <7 2917 | dec <1 ; And reduce lengths 2918 | dec <5 2919 | bra COMPARE 2920 | 2921 | COMPARE_P: lda #1 2922 | bra COMPARE_X 2923 | COMPARE_N: lda #-1 2924 | 2925 | COMPARE_X: sta <7 ; Save the result 2926 | tdc 2927 | clc 2928 | adc #6 2929 | tcd 2930 | CONTINUE ; Done 2931 | 2932 | ; COUNT ( c-addr1 -- c-addr2 u ) 2933 | ; 2934 | ; Return the character string specification for the counted string stored at 2935 | ; c-addr1. c-addr2 is the address of the first character after c-addr1. u is 2936 | ; the contents of the character at c-addr1, which is the length in characters 2937 | ; of the string at c-addr2. 2938 | ; 2939 | ; In this implementation it is defined as 2940 | ; 2941 | ; DUP CHAR+ SWAP C@ 2942 | 2943 | HEADER 5,"COUNT",NORMAL 2944 | COUNT: jsr DO_COLON 2945 | dw DUP 2946 | dw CHAR_PLUS 2947 | dw SWAP 2948 | dw C_FETCH 2949 | dw EXIT 2950 | 2951 | ; SEARCH ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) 2952 | ; 2953 | ; Search the string specified by c-addr1 u1 for the string specified by c-addr2 2954 | ; u2. If flag is true, a match was found at c-addr3 with u3 characters 2955 | ; remaining. If flag is false there was no match and c-addr3 is c-addr1 and u3 2956 | ; is u1. 2957 | 2958 | HEADER 6,"SEARCH",NORMAL 2959 | SEARCH: jsr DO_COLON 2960 | ; TODO 2961 | CONTINUE 2962 | 2963 | ;=============================================================================== 2964 | ; Compiling Words 2965 | ;------------------------------------------------------------------------------- 2966 | 2967 | ; ( ( -- ) 2968 | ; 2969 | ; Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 2970 | ; 2971 | ; The number of characters in ccc may be zero to the number of characters in the 2972 | ; parse area. 2973 | ; 2974 | ; In this implementation it is defined as: 2975 | ; 2976 | ; [ HEX ] 29 WORD DROP ; IMMEDIATE 2977 | 2978 | HEADER 1,"(",IMMEDIATE 2979 | jsr DO_COLON 2980 | dw DO_LITERAL,')' 2981 | dw WORD 2982 | dw DROP 2983 | dw EXIT 2984 | 2985 | ; .( 2986 | 2987 | HEADER 2,".(",IMMEDIATE 2988 | DOT_PAREN: jsr DO_COLON 2989 | dw DO_LITERAL,')' 2990 | dw WORD 2991 | dw COUNT 2992 | dw TYPE 2993 | dw EXIT 2994 | 2995 | ; ." ( -- ) 2996 | 2997 | LINK IMMEDIATE 2998 | db 2,".",'"' 2999 | DOT_QUOTE: jsr DO_COLON 3000 | dw S_QUOTE 3001 | dw DO_LITERAL,TYPE 3002 | dw COMMA 3003 | dw EXIT 3004 | 3005 | 3006 | ; +LOOP ( -- ) 3007 | 3008 | HEADER 5,"+LOOP",IMMEDIATE 3009 | PLUS_LOOP: jsr DO_COLON 3010 | dw DO_LITERAL,DO_PLUS_LOOP 3011 | dw COMMA 3012 | dw COMMA 3013 | dw QUERY_DUP 3014 | dw QUERY_BRANCH,PLUS_LOOP_1 3015 | dw HERE 3016 | dw SWAP 3017 | dw STORE 3018 | PLUS_LOOP_1: dw EXIT 3019 | 3020 | DO_PLUS_LOOP: 3021 | ldx <1 ; Fetch increment 3022 | tdc ; And drop 3023 | inc a 3024 | inc a 3025 | tcd 3026 | clc ; Add to loop counter 3027 | txa 3028 | adc 1,s 3029 | sta 1,s 3030 | cmp 3,s ; Reached limit? 3031 | bcs DO_PLOOP_END ; Yes 3032 | lda !0,y ; No, branch back to start 3033 | tay 3034 | CONTINUE ; Done 3035 | 3036 | DO_PLOOP_END: iny ; Skip over address 3037 | iny 3038 | pla ; Drop loop variables 3039 | pla 3040 | CONTINUE ; Done 3041 | 3042 | ; : ( -- ) 3043 | 3044 | HEADER 1,":",NORMAL 3045 | COLON: jsr DO_COLON 3046 | dw CREATE 3047 | dw DO_LITERAL,DO_COLON 3048 | dw BUILD 3049 | dw RIGHT_BRACKET 3050 | dw EXIT 3051 | 3052 | DO_COLON: 3053 | plx ; Pull new word IP-1 3054 | phy ; Save the old IP 3055 | inx ; Work out new IP 3056 | txy 3057 | CONTINUE ; Done 3058 | 3059 | ; :NONAME ( -- xt ) 3060 | 3061 | HEADER 7,":NONAME",NORMAL 3062 | NONAME: jsr DO_COLON 3063 | dw HERE 3064 | dw DO_LITERAL,DO_COLON 3065 | dw BUILD 3066 | dw RIGHT_BRACKET 3067 | dw EXIT 3068 | 3069 | ; ; ( -- ) 3070 | 3071 | LINK IMMEDIATE 3072 | db 1,";" 3073 | SEMICOLON: jsr DO_COLON 3074 | dw DO_LITERAL,EXIT 3075 | dw COMMA 3076 | dw LEFT_BRACKET 3077 | dw EXIT 3078 | 3079 | ; ?DO ( -- ) 3080 | 3081 | HEADER 3,"?DO",IMMEDIATE 3082 | QUERY_DO: jsr DO_COLON 3083 | dw DO_LITERAL,QUERY_DO_DO 3084 | dw COMMA 3085 | dw HERE 3086 | dw ZERO 3087 | dw COMMA 3088 | dw HERE 3089 | dw EXIT 3090 | 3091 | QUERY_DO_DO: 3092 | lda <1 ; Are the start and limit 3093 | eor <3 ; .. the same? 3094 | beq QUERY_DO_DO_1 3095 | iny ; No, Skip over jump address 3096 | iny 3097 | jmp DO_DO ; And start a normal loop 3098 | 3099 | QUERY_DO_DO_1: tdc ; Drop the loop parameters 3100 | inc a 3101 | inc a 3102 | inc a 3103 | inc a 3104 | tcd 3105 | jmp BRANCH ; And skip over loop 3106 | 3107 | ; 2CONSTANT ( x “name” -- ) 3108 | ; 3109 | ; Skip leading space delimiters. Parse name delimited by a space. Create a 3110 | ; definition for name with the execution semantics defined below. 3111 | 3112 | HEADER 9,"2CONSTANT",NORMAL 3113 | TWO_CONSTANT: jsr DO_COLON 3114 | dw CREATE 3115 | dw DO_LITERAL,DO_TWO_CONSTANT 3116 | dw BUILD 3117 | dw COMMA 3118 | dw COMMA 3119 | dw EXIT; AGAIN ( -- ) 3120 | 3121 | DO_TWO_CONSTANT: 3122 | plx ; Get return address 3123 | tdc ; Create space on stack 3124 | dec a 3125 | dec a 3126 | dec a 3127 | dec a 3128 | tcd 3129 | lda !1,x ; Transfer the value 3130 | sta <1 3131 | lda !3,x 3132 | sta <3 3133 | CONTINUE ; Done 3134 | 3135 | ; 2LITERAL 3136 | 3137 | HEADER 8,"2LITERAL",IMMEDIATE 3138 | TWO_LITERAL: jsr DO_COLON 3139 | dw DO_LITERAL,DO_TWO_LITERAL 3140 | dw COMMA 3141 | dw COMMA 3142 | dw COMMA 3143 | dw EXIT 3144 | 3145 | DO_TWO_LITERAL: 3146 | tdc ; Make room on stack 3147 | dec a 3148 | dec a 3149 | dec a 3150 | dec a 3151 | tcd 3152 | lda !0,y ; Fetch constant from IP 3153 | sta <1 3154 | lda !2,y 3155 | sta <3 3156 | iny ; Bump IP 3157 | iny 3158 | iny 3159 | iny 3160 | CONTINUE ; Done 3161 | 3162 | ; 2VARIABLE 3163 | 3164 | HEADER 9,"2VARIABLE",IMMEDIATE 3165 | TWO_VARIABLE: jsr DO_COLON 3166 | dw CREATE 3167 | dw DO_LITERAL,DO_VARIABLE 3168 | dw BUILD 3169 | dw DO_LITERAL,2 3170 | dw CELLS 3171 | dw ALLOT 3172 | dw EXIT 3173 | 3174 | ; ABORT" ( -- ) 3175 | 3176 | LINK IMMEDIATE 3177 | db 6,"ABORT",'"' 3178 | ABORT_QUOTE: jsr DO_COLON 3179 | dw S_QUOTE 3180 | dw DO_LITERAL,QUERY_ABORT 3181 | dw COMMA 3182 | dw EXIT 3183 | 3184 | ; AGAIN ( -- ) 3185 | HEADER 5,"AGAIN",IMMEDIATE 3186 | AGAIN: jsr DO_COLON 3187 | dw DO_LITERAL,BRANCH 3188 | dw COMMA 3189 | dw COMMA 3190 | dw EXIT 3191 | 3192 | ; BEGIN ( -- ) 3193 | 3194 | HEADER 5,"BEGIN",IMMEDIATE 3195 | BEGIN: jsr DO_COLON 3196 | dw HERE 3197 | dw EXIT 3198 | 3199 | ; CONSTANT ( x “name” -- ) 3200 | ; 3201 | ; Skip leading space delimiters. Parse name delimited by a space. Create a 3202 | ; definition for name with the execution semantics defined below. 3203 | 3204 | HEADER 8,"CONSTANT",NORMAL 3205 | CONSTANT: jsr DO_COLON 3206 | dw CREATE 3207 | dw DO_LITERAL,DO_CONSTANT 3208 | dw BUILD 3209 | dw COMMA 3210 | dw EXIT 3211 | 3212 | DO_CONSTANT: 3213 | plx ; Get return address 3214 | tdc ; Create space on stack 3215 | dec a 3216 | dec a 3217 | tcd 3218 | lda !1,x ; Transfer the value 3219 | sta <1 3220 | CONTINUE ; Done 3221 | 3222 | ; DO ( -- ) 3223 | 3224 | HEADER 2,"DO",IMMEDIATE 3225 | DO: jsr DO_COLON 3226 | dw DO_LITERAL,DO_DO 3227 | dw COMMA 3228 | dw ZERO 3229 | dw HERE 3230 | dw EXIT 3231 | 3232 | DO_DO: 3233 | lda <3 3234 | pha 3235 | lda <1 3236 | pha 3237 | tdc 3238 | inc a 3239 | inc a 3240 | inc a 3241 | inc a 3242 | tcd 3243 | CONTINUE 3244 | 3245 | ; ELSE ( -- ) 3246 | 3247 | HEADER 4,"ELSE",IMMEDIATE 3248 | ELSE: jsr DO_COLON 3249 | dw DO_LITERAL,BRANCH 3250 | dw COMMA 3251 | dw HERE 3252 | dw ZERO 3253 | dw COMMA 3254 | dw HERE 3255 | dw SWAP 3256 | dw STORE 3257 | dw EXIT 3258 | 3259 | BRANCH: 3260 | lda !0,y ; Load branch address into IP 3261 | tay 3262 | CONTINUE ; Done 3263 | 3264 | ; IF ( -- ) 3265 | 3266 | HEADER 2,"IF",IMMEDIATE 3267 | IF: jsr DO_COLON 3268 | dw DO_LITERAL,QUERY_BRANCH 3269 | dw COMMA 3270 | dw HERE 3271 | dw ZERO 3272 | dw COMMA 3273 | dw EXIT 3274 | 3275 | QUERY_BRANCH: 3276 | ldx <1 ; Pull the top of stack value 3277 | tdc 3278 | inc a ; Drop top item 3279 | inc a 3280 | tcd 3281 | txa 3282 | beq BRANCH ; Branch if top was zero 3283 | iny ; Otherwise skip address 3284 | iny 3285 | CONTINUE ; Done 3286 | 3287 | ; IMMEDIATE ( -- ) 3288 | 3289 | HEADER 9,"IMMEDIATE",IMMEDIATE 3290 | jsr DO_COLON 3291 | dw DO_LITERAL,IMMEDIATE 3292 | dw LATEST 3293 | dw FETCH 3294 | dw ONE_MINUS 3295 | dw C_STORE 3296 | dw EXIT 3297 | 3298 | ; LITERAL ( x -- ) 3299 | ; 3300 | ; Append the run-time semantics given below to the current definition. 3301 | 3302 | HEADER 7,"LITERAL",IMMEDIATE 3303 | LITERAL: jsr DO_COLON 3304 | dw DO_LITERAL,DO_LITERAL 3305 | dw COMMA 3306 | dw COMMA 3307 | dw EXIT 3308 | 3309 | DO_LITERAL: 3310 | tdc ; Make room on stack 3311 | dec a 3312 | dec a 3313 | tcd 3314 | lda !0,y ; Fetch constant from IP 3315 | sta <1 3316 | iny 3317 | iny 3318 | CONTINUE ; Done 3319 | 3320 | ; LOOP 3321 | 3322 | HEADER 4,"LOOP",IMMEDIATE 3323 | LOOP: jsr DO_COLON 3324 | dw DO_LITERAL,DO_LOOP 3325 | dw COMMA 3326 | dw COMMA 3327 | dw QUERY_DUP 3328 | dw QUERY_BRANCH,LOOP_1 3329 | dw HERE 3330 | dw SWAP 3331 | dw STORE 3332 | LOOP_1: dw EXIT 3333 | 3334 | ; (LOOP) 3335 | 3336 | ; HEADER 6,"(LOOP)",NORMAL 3337 | DO_LOOP 3338 | lda 1,s ; Add one to loop counter 3339 | inc a 3340 | sta 1,s 3341 | cmp 3,s ; Reached limit? 3342 | bcs DO_LOOP_END ; Yes 3343 | lda !0,y ; No, branch back to start 3344 | tay 3345 | CONTINUE ; Done 3346 | 3347 | DO_LOOP_END: iny ; Skip over address 3348 | iny 3349 | pla ; Drop loop variables 3350 | pla 3351 | CONTINUE ; Done 3352 | 3353 | ; POSTPONE 3354 | 3355 | ; BL WORD FIND 3356 | ; DUP 0= ABORT" ?" 3357 | ; 0< IF -- xt non immed: add code to current 3358 | ; def'n to compile xt later. 3359 | ; ['] LIT ,XT , add "LIT,xt,COMMAXT" 3360 | ; ['] ,XT ,XT to current definition 3361 | ; ELSE ,XT immed: compile into cur. def'n 3362 | ; THEN ; IMMEDIATE 3363 | 3364 | HEADER 8,"POSTPONE",IMMEDIATE 3365 | POSTPONE: jsr DO_COLON 3366 | dw BL 3367 | dw WORD 3368 | dw FIND 3369 | dw DUP 3370 | dw ZERO_EQUAL 3371 | dw DO_S_QUOTE 3372 | db 1,"?" 3373 | dw QUERY_ABORT 3374 | dw ZERO_LESS 3375 | dw QUERY_BRANCH,POSTPONE_1 3376 | dw DO_LITERAL,DO_LITERAL 3377 | dw COMMA 3378 | dw COMMA 3379 | dw BRANCH,POSTPONE_2 3380 | POSTPONE_1: dw COMMA 3381 | POSTPONE_2: dw EXIT 3382 | 3383 | ; RECURSE ( -- ) 3384 | 3385 | HEADER 7,"RECURSE",IMMEDIATE 3386 | RECURSE: jsr DO_COLON 3387 | dw LATEST 3388 | dw FETCH 3389 | dw NFA_TO_CFA 3390 | dw COMMA 3391 | dw EXIT 3392 | 3393 | ; S" 3394 | 3395 | LINK IMMEDIATE 3396 | db 2,"S",'"' 3397 | S_QUOTE: jsr DO_COLON 3398 | dw DO_LITERAL,DO_S_QUOTE 3399 | dw COMMA 3400 | dw DO_LITERAL,'"' 3401 | dw WORD 3402 | dw C_FETCH 3403 | dw ONE_PLUS 3404 | dw ALIGNED 3405 | dw ALLOT 3406 | dw EXIT 3407 | 3408 | ; (S") ( -- c-addr u ) 3409 | 3410 | DO_S_QUOTE: 3411 | jsr DO_COLON 3412 | dw R_FROM 3413 | dw COUNT 3414 | dw TWO_DUP 3415 | dw PLUS 3416 | dw ALIGNED 3417 | dw TO_R 3418 | dw EXIT 3419 | 3420 | ; THEN ( -- ) 3421 | 3422 | HEADER 4,"THEN",IMMEDIATE 3423 | THEN: jsr DO_COLON 3424 | dw HERE 3425 | dw SWAP 3426 | dw STORE 3427 | dw EXIT 3428 | 3429 | ; UNTIL ( -- ) 3430 | 3431 | HEADER 5,"UNTIL",IMMEDIATE 3432 | UNTIL: jsr DO_COLON 3433 | dw DO_LITERAL,QUERY_BRANCH 3434 | dw COMMA 3435 | dw COMMA 3436 | dw EXIT 3437 | 3438 | ; USER 3439 | 3440 | HEADER 4,"USER",NORMAL 3441 | USER: jsr DO_COLON 3442 | dw CREATE 3443 | dw DO_LITERAL,DO_USER 3444 | dw BUILD 3445 | dw COMMA 3446 | dw EXIT 3447 | 3448 | HEADER 6,"(USER)",NORMAL 3449 | DO_USER: 3450 | tdc 3451 | dec a ; Push on data stack 3452 | dec a 3453 | tcd 3454 | plx 3455 | clc 3456 | lda !1,x 3457 | adc #USER_AREA 3458 | sta <1 3459 | CONTINUE ; Done 3460 | 3461 | ; VARIABLE ( “name” -- ) 3462 | ; 3463 | ; Skip leading space delimiters. Parse name delimited by a space. Create a 3464 | ; definition for name with the execution semantics defined below. Reserve one 3465 | ; cell of data space at an aligned address. 3466 | 3467 | LINK NORMAL 3468 | db 8,"VARIABLE" 3469 | VARIABLE: jsr DO_COLON 3470 | dw CREATE 3471 | dw DO_LITERAL,DO_VARIABLE 3472 | dw BUILD 3473 | dw DO_LITERAL,1 3474 | dw CELLS 3475 | dw ALLOT 3476 | dw EXIT 3477 | 3478 | DO_VARIABLE: 3479 | tdc 3480 | dec a 3481 | dec a 3482 | tcd 3483 | pla 3484 | inc a 3485 | sta <1 3486 | CONTINUE 3487 | 3488 | ; WORDS ( -- ) 3489 | ; 3490 | ; LATEST @ BEGIN 3491 | ; DUP COUNT TYPE SPACE 3492 | ; NFA>LFA @ 3493 | ; DUP 0= UNTIL 3494 | ; DROP ; 3495 | 3496 | HEADER 5,"WORDS",NORMAL 3497 | jsr DO_COLON 3498 | dw LATEST 3499 | dw FETCH 3500 | WORDS_1: dw DUP 3501 | dw COUNT 3502 | dw TYPE 3503 | dw SPACE 3504 | dw NFA_TO_LFA 3505 | dw FETCH 3506 | dw DUP 3507 | dw ZERO_EQUAL 3508 | dw QUERY_BRANCH,WORDS_1 3509 | dw DROP 3510 | dw EXIT 3511 | 3512 | ; [ 3513 | ; 3514 | ; In this implementation it is defined as 3515 | ; 3516 | ; 0 STATE ! 3517 | 3518 | HEADER 1,"[",IMMEDIATE 3519 | LEFT_BRACKET: jsr DO_COLON 3520 | dw ZERO 3521 | dw STATE 3522 | dw STORE 3523 | dw EXIT 3524 | 3525 | ; \ ( -- ) 3526 | ; 3527 | ; Parse and discard the remainder of the parse area. \ is an immediate word. 3528 | ; 3529 | ; In this implementation it is defined as 3530 | ; 3531 | ; 1 WORD DROP 3532 | 3533 | HEADER 1,"\",IMMEDIATE 3534 | BACKSLASH: jsr DO_COLON 3535 | dw DO_LITERAL,1 3536 | dw WORD 3537 | dw DROP 3538 | dw EXIT 3539 | 3540 | ; ] 3541 | ; 3542 | ; In this implementation it is defined as 3543 | ; 3544 | ; -1 STATE ! 3545 | 3546 | HEADER 1,"]",NORMAL 3547 | RIGHT_BRACKET: jsr DO_COLON 3548 | dw DO_LITERAL,-1 3549 | dw STATE 3550 | dw STORE 3551 | dw EXIT 3552 | 3553 | ;=============================================================================== 3554 | ; I/O Operations 3555 | ;------------------------------------------------------------------------------- 3556 | 3557 | ; CR ( -- ) 3558 | ; 3559 | ; Cause subsequent output to appear at the beginning of the next line. 3560 | ; 3561 | ; In this implementation it is defined as 3562 | ; 3563 | ; 13 EMIT 10 EMIT 3564 | 3565 | HEADER 2,"CR",NORMAL 3566 | CR: jsr DO_COLON 3567 | dw DO_LITERAL,13 3568 | dw EMIT 3569 | dw DO_LITERAL,10 3570 | dw EMIT 3571 | dw EXIT 3572 | 3573 | ; EMIT ( x -- ) 3574 | ; 3575 | ; If x is a graphic character in the implementation-defined character set, 3576 | ; display x. The effect of EMIT for all other values of x is implementation 3577 | ; -defined. 3578 | 3579 | HEADER 4,"EMIT",NORMAL 3580 | extern UartTx 3581 | EMIT: 3582 | lda <1 ; Fetch character from stack 3583 | jsr UartTx ; .. and transmit 3584 | tdc 3585 | inc a ; Drop the character 3586 | inc a 3587 | tcd 3588 | CONTINUE ; Done 3589 | 3590 | ; KEY ( -- char ) 3591 | ; 3592 | ; Receive one character char, a member of the implementation-defined character 3593 | ; set. Keyboard events that do not correspond to such characters are discarded 3594 | ; until a valid character is received, and those events are subsequently 3595 | ; unavailable. 3596 | ; 3597 | ; All standard characters can be received. Characters received by KEY are not 3598 | ; displayed. 3599 | 3600 | HEADER 3,"KEY",NORMAL 3601 | extern UartRx 3602 | KEY: 3603 | jsr UartRx ; Receive a character 3604 | and #$00ff ; Ensure in ASCII range 3605 | tax 3606 | tdc 3607 | dec a ; And push to stack 3608 | dec a 3609 | tcd 3610 | stx <1 3611 | CONTINUE ; Done 3612 | 3613 | ; SPACE ( -- ) 3614 | ; 3615 | ; Display one space. 3616 | ; 3617 | ; In this implementation it is defined as 3618 | ; 3619 | ; BL EMIT 3620 | 3621 | HEADER 5,"SPACE",NORMAL 3622 | SPACE: jsr DO_COLON 3623 | dw BL 3624 | dw EMIT 3625 | dw EXIT 3626 | 3627 | ; SPACES ( n -- ) 3628 | ; 3629 | ; If n is greater than zero, display n spaces. 3630 | ; 3631 | ; In this implementation it is defined as 3632 | ; 3633 | ; BEGIN DUP 0> WHILE SPACE 1- REPEAT DROP 3634 | 3635 | HEADER 6,"SPACES",NORMAL 3636 | SPACES: jsr DO_COLON 3637 | SPACES_1: dw DUP 3638 | dw ZERO_GREATER 3639 | dw QUERY_BRANCH,SPACES_2 3640 | dw SPACE 3641 | dw ONE_MINUS 3642 | dw BRANCH,SPACES_1 3643 | SPACES_2: dw DROP 3644 | dw EXIT 3645 | 3646 | ; TYPE ( c-addr u -- ) 3647 | ; 3648 | ; If u is greater than zero, display the character string specified by c-addr 3649 | ; and u. 3650 | ; 3651 | ; In this implementation it is defined as 3652 | ; 3653 | ; ?DUP IF 3654 | ; OVER + SWAP DO I C@ EMIT LOOP 3655 | ; ELSE DROP THEN 3656 | 3657 | HEADER 4,"TYPE",NORMAL 3658 | TYPE: jsr DO_COLON 3659 | dw QUERY_DUP 3660 | dw QUERY_BRANCH,TYPE_2 3661 | dw OVER 3662 | dw PLUS 3663 | dw SWAP 3664 | dw DO_DO 3665 | TYPE_1: dw I 3666 | dw C_FETCH 3667 | dw EMIT 3668 | dw DO_LOOP,TYPE_1 3669 | dw BRANCH,TYPE_3 3670 | TYPE_2 dw DROP 3671 | TYPE_3 dw EXIT 3672 | 3673 | ;=============================================================================== 3674 | ; Formatted Output 3675 | ;------------------------------------------------------------------------------- 3676 | 3677 | ; # ( ud1 -- ud2 ) 3678 | ; 3679 | ; Divide ud1 by the number in BASE giving the quotient ud2 and the remainder n. 3680 | ; (n is the least-significant digit of ud1.) Convert n to external form and add 3681 | ; the resulting character to the beginning of the pictured numeric output string. 3682 | ; An ambiguous condition exists if # executes outside of a <# #> delimited 3683 | ; number conversion. 3684 | ; 3685 | ; BASE @ >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ROT DUP 9 > 7 AND + 30 + HOLD 3686 | 3687 | HEADER 1,"#",NORMAL 3688 | HASH: jsr DO_COLON 3689 | dw BASE 3690 | dw FETCH 3691 | dw TO_R 3692 | dw ZERO 3693 | dw R_FETCH 3694 | dw UM_SLASH_MOD 3695 | dw ROT 3696 | dw ROT 3697 | dw R_FROM 3698 | dw UM_SLASH_MOD 3699 | dw ROT 3700 | dw ROT 3701 | dw DUP 3702 | dw DO_LITERAL,9 3703 | dw GREATER 3704 | dw DO_LITERAL,7 3705 | dw AND 3706 | dw PLUS 3707 | dw DO_LITERAL,'0' 3708 | dw PLUS 3709 | dw HOLD 3710 | dw EXIT 3711 | 3712 | ; #> ( xd -- c-addr u ) 3713 | ; 3714 | ; Drop xd. Make the pictured numeric output string available as a character 3715 | ; string. c-addr and u specify the resulting character string. A program may 3716 | ; replace characters within the string. 3717 | ; 3718 | ; 2DROP HP @ PAD OVER - 3719 | 3720 | HEADER 2,"#>",NORMAL 3721 | HASH_GREATER: jsr DO_COLON 3722 | dw TWO_DROP 3723 | dw HP 3724 | dw FETCH 3725 | dw PAD 3726 | dw OVER 3727 | dw MINUS 3728 | dw EXIT 3729 | 3730 | ; #S ( ud1 -- ud2 ) 3731 | ; 3732 | ; Convert one digit of ud1 according to the rule for #. Continue conversion 3733 | ; until the quotient is zero. ud2 is zero. An ambiguous condition exists if #S 3734 | ; executes outside of a <# #> delimited number conversion. 3735 | ; 3736 | ; BEGIN # 2DUP OR 0= UNTIL 3737 | 3738 | HEADER 2,"#S",NORMAL 3739 | HASH_S: jsr DO_COLON 3740 | HASH_S_1: dw HASH 3741 | dw TWO_DUP 3742 | dw OR 3743 | dw ZERO_EQUAL 3744 | dw QUERY_BRANCH,HASH_S_1 3745 | dw EXIT 3746 | 3747 | ; . ( n -- ) 3748 | ; 3749 | ; Display n in free field format. 3750 | ; 3751 | ; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE 3752 | 3753 | HEADER 1,".",NORMAL 3754 | DOT: jsr DO_COLON 3755 | dw LESS_HASH 3756 | dw DUP 3757 | dw ABS 3758 | dw ZERO 3759 | dw HASH_S 3760 | dw ROT 3761 | dw SIGN 3762 | dw HASH_GREATER 3763 | dw TYPE 3764 | dw SPACE 3765 | dw EXIT 3766 | 3767 | ; <# ( -- ) 3768 | ; 3769 | ; Initialize the pictured numeric output conversion process. 3770 | ; 3771 | ; PAD HP ! 3772 | 3773 | HEADER 2,"<#",NORMAL 3774 | LESS_HASH: jsr DO_COLON 3775 | dw PAD 3776 | dw HP 3777 | dw STORE 3778 | dw EXIT 3779 | 3780 | ; HOLD ( char -- ) 3781 | 3782 | ; Add char to the beginning of the pictured numeric output string. An 3783 | ; ambiguous condition exists if HOLD executes outside of a <# #> delimited 3784 | ; number conversion. 3785 | ; 3786 | ; -1 HP +! HP @ C! 3787 | 3788 | HEADER 4,"HOLD",NORMAL 3789 | HOLD: jsr DO_COLON 3790 | dw DO_LITERAL,-1 3791 | dw HP 3792 | dw PLUS_STORE 3793 | dw HP 3794 | dw FETCH 3795 | dw C_STORE 3796 | dw EXIT 3797 | 3798 | ; PAD ( -- c-addr ) 3799 | ; 3800 | ; c-addr is the address of a transient region that can be used to hold data 3801 | ; for intermediate processing. 3802 | 3803 | HEADER 3,"PAD",NORMAL 3804 | PAD: jsr DO_CONSTANT 3805 | dw PAD_AREA 3806 | 3807 | ; SIGN ( n -- ) 3808 | ; 3809 | ; If n is negative, add a minus sign to the beginning of the pictured numeric 3810 | ; output string. An ambiguous condition exists if SIGN executes outside of a 3811 | ; <# #> delimited number conversion. 3812 | ; 3813 | ; [ HEX ] 0< IF 2D HOLD THEN 3814 | 3815 | HEADER 4,"SIGN",NORMAL 3816 | SIGN: jsr DO_COLON 3817 | dw ZERO_LESS 3818 | dw QUERY_BRANCH,SIGN_1 3819 | dw DO_LITERAL,'-' 3820 | dw HOLD 3821 | SIGN_1: dw EXIT 3822 | 3823 | ; U. ( u -- ) 3824 | ; 3825 | ; Display u in free field format. 3826 | ; 3827 | ; <# 0 #S #> TYPE SPACE 3828 | 3829 | HEADER 2,"U.",NORMAL 3830 | U_DOT: jsr DO_COLON 3831 | dw LESS_HASH 3832 | dw ZERO 3833 | dw HASH_S 3834 | dw HASH_GREATER 3835 | dw TYPE 3836 | dw SPACE 3837 | dw EXIT 3838 | 3839 | ;=============================================================================== 3840 | ; Programming Tools 3841 | ;------------------------------------------------------------------------------- 3842 | 3843 | ; .NYBBLE ( n -- ) 3844 | ; 3845 | ; Print the least significant nybble of the top value on the stack in hex. 3846 | 3847 | ; HEADER 7,".NYBBLE",NORMAL 3848 | DOT_NYBBLE: 3849 | lda <1 3850 | and #$000f 3851 | ora #$0030 3852 | cmp #$003a 3853 | bcc $+5 3854 | adc #$0006 3855 | jsr UartTx 3856 | jmp DROP 3857 | 3858 | ; .BYTE ( n -- ) 3859 | ; 3860 | ; Print least significant byte of top value on the stack in hex followed by 3861 | ; a space. 3862 | 3863 | HEADER 5,".BYTE",NORMAL 3864 | DOT_BYTE: jsr DO_COLON 3865 | dw DUP 3866 | dw DO_LITERAL,4 3867 | dw RSHIFT 3868 | dw DOT_NYBBLE 3869 | dw DOT_NYBBLE 3870 | dw SPACE 3871 | dw EXIT 3872 | 3873 | ; .WORD ( n -- ) 3874 | ; 3875 | ; Print the top value on the stack in hex followed by a space. 3876 | 3877 | HEADER 5,".WORD",NORMAL 3878 | DOT_WORD: jsr DO_COLON 3879 | dw DUP 3880 | dw DO_LITERAL,12 3881 | dw RSHIFT 3882 | dw DOT_NYBBLE 3883 | dw DUP 3884 | dw DO_LITERAL,8 3885 | dw RSHIFT 3886 | dw DOT_NYBBLE 3887 | dw DUP 3888 | dw DO_LITERAL,4 3889 | dw RSHIFT 3890 | dw DOT_NYBBLE 3891 | dw DOT_NYBBLE 3892 | dw SPACE 3893 | dw EXIT 3894 | 3895 | ; .DP 3896 | 3897 | HEADER 3,".DP",NORMAL 3898 | jsr DO_COLON 3899 | dw AT_DP 3900 | dw DOT_WORD 3901 | dw EXIT 3902 | 3903 | HEADER 3,".RP",NORMAL 3904 | jsr DO_COLON 3905 | dw AT_RP 3906 | dw DOT_WORD 3907 | dw EXIT 3908 | 3909 | ; .S ( -- ) 3910 | ; 3911 | ; Copy and display the values currently on the data stack. The format of the 3912 | ; display is implementation-dependent. 3913 | 3914 | HEADER 2,".S",NORMAL 3915 | jsr DO_COLON 3916 | dw DO_LITERAL,'{' 3917 | dw EMIT 3918 | dw SPACE 3919 | dw AT_DP 3920 | dw ONE_PLUS 3921 | dw DO_LITERAL,DSTACK_END 3922 | dw SWAP 3923 | dw QUERY_DO_DO,DOT_S_2 3924 | DOT_S_1: dw I 3925 | dw FETCH 3926 | dw DOT_WORD 3927 | dw DO_LITERAL,2 3928 | dw DO_PLUS_LOOP 3929 | dw DOT_S_1 3930 | DOT_S_2: dw DO_LITERAL,'}' 3931 | dw EMIT 3932 | dw SPACE 3933 | dw EXIT 3934 | 3935 | ; ? ( a-addr -- ) 3936 | ; 3937 | ; Display the value stored at a-addr. 3938 | 3939 | HEADER 1,"?",NORMAL 3940 | jsr DO_COLON 3941 | dw FETCH 3942 | dw DOT_WORD 3943 | dw EXIT 3944 | 3945 | HEADER 3,"@DP",NORMAL 3946 | AT_DP: 3947 | phd 3948 | tdc 3949 | dec a 3950 | dec a 3951 | tcd 3952 | pla 3953 | sta <1 3954 | CONTINUE 3955 | 3956 | HEADER 3,"@RP",NORMAL 3957 | AT_RP: 3958 | tdc 3959 | dec a 3960 | dec a 3961 | tcd 3962 | tsx 3963 | stx <1 3964 | CONTINUE 3965 | 3966 | 3967 | ;------------------------------------------------------------------------------- 3968 | 3969 | include "device.asm" 3970 | 3971 | TRAILER 3972 | NEXT_WORD: 3973 | 3974 | end -------------------------------------------------------------------------------- /ans-forth.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrew-jacobs/w65c816sxb-forth/9c8e4a14a3715489621c0e7bb42f1421c9d3fb75/ans-forth.bin -------------------------------------------------------------------------------- /ans-forth.map: -------------------------------------------------------------------------------- 1 | Section PAGE0: 2 | 00000000 _BEG_PAGE0 3 | 00000016 _END_PAGE0 4 | 5 | Section CODE: 6 | 00000300 _BEG_CODE 7 | 00000341 UartTx 8 | 00000362 UartRx 9 | 00000371 UartRxTest 10 | 0000037f RomSelect 11 | 00000395 RomCheck 12 | 0000039b _END_CODE 13 | 14 | Section DATA: 15 | 00000200 _BEG_DATA 16 | 000002b0 _END_DATA 17 | 18 | Section shadowvectors: 19 | 00007ee0 _BEG_SHADOWVECTORS 20 | 00007f00 _END_SHADOWVECTORS 21 | 22 | Section vectors: 23 | 0000ffe0 _BEG_VECTORS 24 | 00010000 _END_VECTORS 25 | 26 | Section forth: 27 | 00000400 _BEG_FORTH 28 | 00001e94 _END_FORTH 29 | 30 | ABSOLUTES: 31 | 00000400 Start 32 | 33 | -------------------------------------------------------------------------------- /build.bat: -------------------------------------------------------------------------------- 1 | nmake 2 | if errorlevel 1 pause -------------------------------------------------------------------------------- /clean.bat: -------------------------------------------------------------------------------- 1 | nmake clean 2 | if errorlevel 1 pause -------------------------------------------------------------------------------- /debug.bat: -------------------------------------------------------------------------------- 1 | nmake debug -------------------------------------------------------------------------------- /device.asm: -------------------------------------------------------------------------------- 1 | ;============================================================================== 2 | ; _ _ _ ____ _____ _ _ _ ___ _ __ 3 | ; / \ | \ | / ___| | ___|__ _ __| |_| |__ ( )( _ )/ |/ /_ 4 | ; / _ \ | \| \___ \ | |_ / _ \| '__| __| '_ \ |/ / _ \| | '_ \ 5 | ; / ___ \| |\ |___) | | _| (_) | | | |_| | | | | (_) | | (_) | 6 | ; /_/ \_\_| \_|____/ |_| \___/|_| \__|_| |_| \___/|_|\___/ 7 | ; 8 | ; Device Specific Words for the W65C816SXB 9 | ;------------------------------------------------------------------------------ 10 | ; Copyright (C)2015-2016 HandCoded Software Ltd. 11 | ; All rights reserved. 12 | ; 13 | ; This work is made available under the terms of the Creative Commons 14 | ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 15 | ; following URL to see the details. 16 | ; 17 | ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 18 | ; 19 | ;============================================================================== 20 | ; Notes: 21 | ; 22 | ;------------------------------------------------------------------------------ 23 | 24 | ; (TITLE) - ( -- ) 25 | ; 26 | 27 | ; HEADER 7,"(TITLE)",NORMAL 28 | DO_TITLE: jsr DO_COLON 29 | dw DO_S_QUOTE 30 | db 28,"W65C816SXB ANS-Forth [16.05]" 31 | dw EXIT 32 | 33 | ; BYE ( -- ) 34 | ; 35 | ; Return control to the host operating system, if any. 36 | 37 | HEADER 3,"BYE",NORMAL 38 | BYE: 39 | sei 40 | cld 41 | emulate 42 | jmp ($fffc) ; Reset the processor 43 | 44 | ; UNUSED ( -- u ) 45 | ; 46 | ; u is the amount of space remaining in the region addressed by HERE , in 47 | ; address units. 48 | 49 | HEADER 6,"UNUSED",NORMAL 50 | UNUSED: jsr DO_COLON 51 | dw DO_LITERAL,$7e00 52 | dw HERE 53 | dw MINUS 54 | dw EXIT 55 | 56 | ;------------------------------------------------------------------------------- 57 | 58 | HEADER 8,"ACIA$RXD",NORMAL 59 | jsr DO_CONSTANT 60 | dw $7f80 61 | 62 | HEADER 8,"ACIA$TXD",NORMAL 63 | jsr DO_CONSTANT 64 | dw $7f80 65 | 66 | HEADER 7,"ACIA$SR",NORMAL 67 | jsr DO_CONSTANT 68 | dw $7f81 69 | 70 | HEADER 8,"ACIA$CMD",NORMAL 71 | jsr DO_CONSTANT 72 | dw $7f82 73 | 74 | HEADER 8,"ACIA$CTL",NORMAL 75 | jsr DO_CONSTANT 76 | dw $7f83 77 | 78 | ;------------------------------------------------------------------------------- 79 | 80 | HEADER 7,"PIA$PIA",NORMAL 81 | jsr DO_CONSTANT 82 | dw $7fa0 83 | 84 | HEADER 8,"PIA$DDRA",NORMAL 85 | jsr DO_CONSTANT 86 | dw $7fa0 87 | 88 | HEADER 7,"PIA$CRA",NORMAL 89 | jsr DO_CONSTANT 90 | dw $7fa1 91 | 92 | HEADER 7,"PIA$PIB",NORMAL 93 | jsr DO_CONSTANT 94 | dw $7fa2 95 | 96 | HEADER 8,"PIA$DDRB",NORMAL 97 | jsr DO_CONSTANT 98 | dw $7fa2 99 | 100 | HEADER 7,"PIA$CRB",NORMAL 101 | jsr DO_CONSTANT 102 | dw $7fa3 103 | 104 | ;------------------------------------------------------------------------------- 105 | 106 | HEADER 8,"VIA1$ORB",NORMAL 107 | jsr DO_CONSTANT 108 | dw $7fc0 109 | 110 | HEADER 8,"VIA1$IRB",NORMAL 111 | jsr DO_CONSTANT 112 | dw $7fc0 113 | 114 | HEADER 8,"VIA1$ORA",NORMAL 115 | jsr DO_CONSTANT 116 | dw $7fc1 117 | 118 | HEADER 8,"VIA1$IRA",NORMAL 119 | jsr DO_CONSTANT 120 | dw $7fc1 121 | 122 | HEADER 9,"VIA1$DDRB",NORMAL 123 | jsr DO_CONSTANT 124 | dw $7fc2 125 | 126 | HEADER 9,"VIA1$DDRA",NORMAL 127 | jsr DO_CONSTANT 128 | dw $7fc3 129 | 130 | HEADER 9,"VIA1$T1CL",NORMAL 131 | jsr DO_CONSTANT 132 | dw $7fc4 133 | 134 | HEADER 9,"VIA1$T1CH",NORMAL 135 | jsr DO_CONSTANT 136 | dw $7fc5 137 | 138 | HEADER 9,"VIA1$T1LL",NORMAL 139 | jsr DO_CONSTANT 140 | dw $7fc6 141 | 142 | HEADER 9,"VIA1$T1LH",NORMAL 143 | jsr DO_CONSTANT 144 | dw $7fc7 145 | 146 | HEADER 9,"VIA1$T2CL",NORMAL 147 | jsr DO_CONSTANT 148 | dw $7fc8 149 | 150 | HEADER 9,"VIA1$T2CH",NORMAL 151 | jsr DO_CONSTANT 152 | dw $7fc9 153 | 154 | HEADER 7,"VIA1$SR",NORMAL 155 | jsr DO_CONSTANT 156 | dw $7fca 157 | 158 | HEADER 8,"VIA1$ACR",NORMAL 159 | jsr DO_CONSTANT 160 | dw $7fcb 161 | 162 | HEADER 8,"VIA1$PCR",NORMAL 163 | jsr DO_CONSTANT 164 | dw $7fcc 165 | 166 | HEADER 8,"VIA1$IFR",NORMAL 167 | jsr DO_CONSTANT 168 | dw $7fcd 169 | 170 | HEADER 8,"VIA1$IER",NORMAL 171 | jsr DO_CONSTANT 172 | dw $7fce 173 | 174 | HEADER 9,"VIA1$ORAN",NORMAL 175 | jsr DO_CONSTANT 176 | dw $7fcf 177 | 178 | HEADER 9,"VIA1$IRAN",NORMAL 179 | jsr DO_CONSTANT 180 | dw $7fcf 181 | 182 | ;------------------------------------------------------------------------------- 183 | 184 | 185 | HEADER 8,"VIA2$ORB",NORMAL 186 | jsr DO_CONSTANT 187 | dw $7fe0 188 | 189 | HEADER 8,"VIA2$IRB",NORMAL 190 | jsr DO_CONSTANT 191 | dw $7fe0 192 | 193 | HEADER 8,"VIA2$ORA",NORMAL 194 | jsr DO_CONSTANT 195 | dw $7fe1 196 | 197 | HEADER 8,"VIA2$IRA",NORMAL 198 | jsr DO_CONSTANT 199 | dw $7fe1 200 | 201 | HEADER 9,"VIA2$DDRB",NORMAL 202 | jsr DO_CONSTANT 203 | dw $7fe2 204 | 205 | HEADER 9,"VIA2$DDRA",NORMAL 206 | jsr DO_CONSTANT 207 | dw $7fe3 208 | 209 | HEADER 9,"VIA2$T1CL",NORMAL 210 | jsr DO_CONSTANT 211 | dw $7fe4 212 | 213 | HEADER 9,"VIA2$T1CH",NORMAL 214 | jsr DO_CONSTANT 215 | dw $7fe5 216 | 217 | HEADER 9,"VIA2$T1LL",NORMAL 218 | jsr DO_CONSTANT 219 | dw $7fe6 220 | 221 | HEADER 9,"VIA2$T1LH",NORMAL 222 | jsr DO_CONSTANT 223 | dw $7fe7 224 | 225 | HEADER 9,"VIA2$T2CL",NORMAL 226 | jsr DO_CONSTANT 227 | dw $7fe8 228 | 229 | HEADER 9,"VIA2$T2CH",NORMAL 230 | jsr DO_CONSTANT 231 | dw $7fe9 232 | 233 | HEADER 7,"VIA2$SR",NORMAL 234 | jsr DO_CONSTANT 235 | dw $7fea 236 | 237 | HEADER 8,"VIA2$ACR",NORMAL 238 | jsr DO_CONSTANT 239 | dw $7feb 240 | 241 | HEADER 8,"VIA2$PCR",NORMAL 242 | jsr DO_CONSTANT 243 | dw $7fec 244 | 245 | HEADER 8,"VIA2$IFR",NORMAL 246 | jsr DO_CONSTANT 247 | dw $7fed 248 | 249 | HEADER 8,"VIA2$IER",NORMAL 250 | jsr DO_CONSTANT 251 | dw $7fee 252 | 253 | HEADER 9,"VIA2$ORAN",NORMAL 254 | jsr DO_CONSTANT 255 | dw $7fef 256 | 257 | HEADER 9,"VIA2$IRAN",NORMAL 258 | jsr DO_CONSTANT 259 | dw $7fef 260 | -------------------------------------------------------------------------------- /documents/ANS Forth 94.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrew-jacobs/w65c816sxb-forth/9c8e4a14a3715489621c0e7bb42f1421c9d3fb75/documents/ANS Forth 94.pdf -------------------------------------------------------------------------------- /w65c816.inc: -------------------------------------------------------------------------------- 1 | ;============================================================================== 2 | ; __ ____ ____ ____ ___ _ __ 3 | ; \ \ / / /_| ___| / ___( _ )/ |/ /_ 4 | ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \ 5 | ; \ V V /| (_) |__) | |__| (_) | | (_) | 6 | ; \_/\_/ \___/____/ \____\___/|_|\___/ 7 | ; 8 | ; Western Design Center W65C816 device definitions 9 | ;------------------------------------------------------------------------------ 10 | ; Copyright (C)2015 HandCoded Software Ltd. 11 | ; All rights reserved. 12 | ; 13 | ; This work is made available under the terms of the Creative Commons 14 | ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 15 | ; following URL to see the details. 16 | ; 17 | ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 18 | ; 19 | ;=============================================================================== 20 | ; Notes: 21 | ; 22 | ; Various macros and definitions for the W65C816 microprocessor. 23 | ; 24 | ;=============================================================================== 25 | ; Revision History: 26 | ; 27 | ; 2015-12-18 AJ Initial version 28 | ;------------------------------------------------------------------------------- 29 | ; $Id$ 30 | ;------------------------------------------------------------------------------- 31 | 32 | ;============================================================================== 33 | ; Status Register Bits 34 | ;------------------------------------------------------------------------------ 35 | 36 | N_FLAG equ 1<<7 37 | V_FLAG equ 1<<6 38 | M_FLAG equ 1<<5 39 | X_FLAG equ 1<<4 40 | B_FLAG equ 1<<4 41 | D_FLAG equ 1<<3 42 | I_FLAG equ 1<<2 43 | Z_FLAG equ 1<<1 44 | C_FLAG equ 1<<0 45 | 46 | ;============================================================================== 47 | ; Macros 48 | ;------------------------------------------------------------------------------ 49 | 50 | ; Puts the processor in emulation mode. A, X and Y become 8-bits and the stack 51 | ; is fixed at $0100-$01ff. 52 | 53 | emulate macro 54 | sec 55 | xce 56 | endm 57 | 58 | ; Puts the processor in native mode. The size of the memory and index register 59 | ; operations is not controlled by the M & X bits in the status register. 60 | 61 | native macro 62 | clc 63 | xce 64 | endm 65 | 66 | ; Resets the M bit making the accumulator and memory accesses 16-bits wide. 67 | 68 | long_a macro 69 | rep #M_FLAG 70 | longa on 71 | endm 72 | 73 | ; Resets the X bit making the index registers 16-bits wide 74 | 75 | long_i macro 76 | rep #X_FLAG 77 | longi on 78 | endm 79 | 80 | ; Resets the M and X bits making the accumulator, memory accesses and index 81 | ; registers 16-bits wide. 82 | 83 | long_ai macro 84 | rep #M_FLAG|X_FLAG 85 | longa on 86 | longi on 87 | endm 88 | 89 | ; Sets the M bit making the accumulator and memory accesses 8-bits wide. 90 | 91 | short_a macro 92 | sep #M_FLAG 93 | longa off 94 | endm 95 | 96 | ; Sets the X bit making the index registers 8-bits wide. 97 | 98 | short_i macro 99 | sep #X_FLAG 100 | longi off 101 | endm 102 | 103 | ; Sets the M & X bits making the accumulator, memory accesses and index 104 | ; registers 8-bits wide. 105 | 106 | short_ai macro 107 | sep #M_FLAG|X_FLAG 108 | longa off 109 | longi off 110 | endm 111 | -------------------------------------------------------------------------------- /w65c816sxb.asm: -------------------------------------------------------------------------------- 1 | ;=============================================================================== 2 | ; __ ____ ____ ____ ___ _ __ ______ ______ 3 | ; \ \ / / /_| ___| / ___( _ )/ |/ /_/ ___\ \/ / __ ) 4 | ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \___ \\ /| _ \ 5 | ; \ V V /| (_) |__) | |__| (_) | | (_) |__) / \| |_) | 6 | ; \_/\_/ \___/____/ \____\___/|_|\___/____/_/\_\____/ 7 | ; 8 | ; Basic Vector Handling for the W65C816SXB Development Board 9 | ;------------------------------------------------------------------------------- 10 | ; Copyright (C)2015 HandCoded Software Ltd. 11 | ; All rights reserved. 12 | ; 13 | ; This work is made available under the terms of the Creative Commons 14 | ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 15 | ; following URL to see the details. 16 | ; 17 | ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 18 | ; 19 | ;=============================================================================== 20 | ; Notes: 21 | ; 22 | ; Timer2 in the VIA2 is used to time the ACIA transmissions and determine when 23 | ; the device is capable of sending another character. 24 | ; 25 | ;------------------------------------------------------------------------------- 26 | 27 | pw 132 28 | inclist on 29 | 30 | chip 65816 31 | 32 | include "w65c816.inc" 33 | include "w65c816sxb.inc" 34 | 35 | ;=============================================================================== 36 | ; Configuration 37 | ;------------------------------------------------------------------------------- 38 | 39 | USE_FIFO equ 0 ; Build using USB FIFO as UART 40 | 41 | BAUD_RATE equ 19200 ; ACIA baud rate 42 | 43 | ;------------------------------------------------------------------------------- 44 | 45 | TXD_COUNT equ OSC_FREQ/(BAUD_RATE/11) 46 | 47 | if TXD_COUNT&$ffff0000 48 | messg "TXD_DELAY does not fit in 16-bits" 49 | endif 50 | 51 | ;=============================================================================== 52 | ; Power On Reset 53 | ;------------------------------------------------------------------------------- 54 | 55 | code 56 | extern Start 57 | longi off 58 | longa off 59 | RESET: 60 | sei ; Stop interrupts 61 | ldx #$ff ; Reset the stack 62 | txs 63 | 64 | lda VIA1_IER ; Ensure no via interrupts 65 | sta VIA1_IER 66 | lda VIA2_IER 67 | sta VIA2_IER 68 | 69 | if USE_FIFO 70 | lda #$1c ; Configure VIA for USB FIFO 71 | sta VIA2_DDRB 72 | lda #$18 73 | sta VIA2_ORB 74 | else 75 | stz ACIA_CMD ; Configure ACIA 76 | stz ACIA_CTL 77 | stz ACIA_SR 78 | 79 | lda #%00011111 ; 8 bits, 1 stop bit, 19200 baud 80 | sta ACIA_CTL 81 | lda #%11001001 ; No parity, no interrupt 82 | sta ACIA_CMD 83 | lda ACIA_RXD ; Clear receive buffer 84 | 85 | lda #1<<5 ; Put VIA2 T2 into timed mode 86 | trb VIA2_ACR 87 | jsr TxDelay ; And prime the timer 88 | endif 89 | 90 | native ; Switch to native mode 91 | jmp Start ; Jump to the application start 92 | 93 | ;=============================================================================== 94 | ; Interrupt Handlers 95 | ;------------------------------------------------------------------------------- 96 | 97 | ; Handle IRQ and BRK interrupts in emulation mode. 98 | 99 | IRQBRK: 100 | bra $ ; Loop forever 101 | 102 | ; Handle NMI interrupts in emulation mode. 103 | 104 | NMIRQ: 105 | bra $ ; Loop forever 106 | 107 | ;------------------------------------------------------------------------------- 108 | 109 | ; Handle IRQ interrupts in native mode. 110 | 111 | IRQ: 112 | bra $ ; Loop forever 113 | 114 | ; Handle IRQ interrupts in native mode. 115 | 116 | BRK: 117 | bra $ ; Loop forever 118 | 119 | ; Handle IRQ interrupts in native mode. 120 | 121 | NMI: 122 | bra $ ; Loop forever 123 | 124 | ;------------------------------------------------------------------------------- 125 | 126 | ; COP and ABORT interrupts are not handled. 127 | 128 | COP: 129 | bra $ ; Loop forever 130 | 131 | ABORT: 132 | bra $ ; Loop forever 133 | 134 | ;=============================================================================== 135 | ; USB FIFO Interface 136 | ;------------------------------------------------------------------------------- 137 | 138 | if USE_FIFO 139 | 140 | ; Add the character in A to the FTDI USB FIFO transmit buffer. If the buffer 141 | ; is full wait for space to become available. 142 | 143 | public UartTx 144 | UartTx: 145 | phx 146 | php 147 | short_ai 148 | ldx #$00 ; Make data port all input 149 | stx VIA2_DDRA 150 | sta VIA2_ORA ; Save the output character 151 | lda #%01 152 | TxWait: bit VIA2_IRB ; Is there space for more data 153 | bne TxWait 154 | 155 | lda VIA2_IRB ; Strobe WR 156 | and #$fb 157 | tax 158 | ora #$04 159 | sta VIA2_ORB 160 | lda #$ff ; Make data port all output 161 | sta VIA2_DDRA 162 | nop 163 | nop 164 | stx VIA2_ORB ; End strobe 165 | lda VIA2_IRA 166 | ldx #$00 ; Make data port all output 167 | stx VIA2_DDRA 168 | plp 169 | plx 170 | rts 171 | 172 | ; Read a character from the FTDI USB FIFO and return it in A. If no data is 173 | ; available then wait for some to arrive. 174 | 175 | public UartRx 176 | UartRx 177 | phx ; Save callers X 178 | php ; Save register sizes 179 | short_ai ; Make registers 8-bit 180 | lda #$02 ; Wait until data in buffer 181 | RxWait: bit VIA2_IRB 182 | bne RxWait 183 | 184 | lda VIA2_IRB ; Strobe /RD low 185 | ora #$08 186 | tax 187 | and #$f7 188 | sta VIA2_ORB 189 | nop ; Wait for data to be available 190 | nop 191 | nop 192 | nop 193 | lda VIA2_IRA ; Read it 194 | stx VIA2_ORB ; And end the strobe 195 | plp ; Restore register sizes 196 | plx ; .. and callers X 197 | rts ; Done 198 | 199 | ; Check if the receive buffer in the FIFO contains any data and return C=1 if 200 | ; there is some. 201 | 202 | public UartRxText 203 | UartRxTest: 204 | pha ; Save callers A 205 | php ; Save register sizes 206 | short_a ; Make A 8-bits 207 | lda VIA2_IRB ; Load status bits 208 | plp ; Restore register sizes 209 | ror a ; Shift data available flag 210 | ror a ; .. into carry 211 | pla ; Restore A 212 | rts ; Done 213 | 214 | ;=============================================================================== 215 | ; ACIA Interface 216 | ;------------------------------------------------------------------------------- 217 | 218 | else 219 | 220 | ; Wait until the Timer2 in VIA2 indicates that the last transmission has been 221 | ; completed then send the character in A and restart the timer. 222 | 223 | public UartTx 224 | UartTx: 225 | pha ; Save the character 226 | php ; Save register sizes 227 | short_a ; Make A 8-bits 228 | pha 229 | lda #1<<5 230 | TxWait: bit VIA2_IFR ; Has the timer finished? 231 | beq TxWait 232 | jsr TxDelay ; Yes, re-reload the timer 233 | pla 234 | sta ACIA_TXD ; Transmit the character 235 | plp ; Restore register sizes 236 | pla ; And callers A 237 | rts ; Done 238 | 239 | TxDelay: 240 | lda #TXD_COUNT 243 | sta VIA2_T2CH 244 | rts 245 | 246 | ; Fetch the next character from the receive buffer waiting for some to arrive 247 | ; if the buffer is empty. 248 | 249 | public UartRx 250 | UartRx: 251 | php ; Save register sizes 252 | short_a ; Make A 8-bits 253 | RxWait: 254 | lda ACIA_SR ; Any data in RX buffer? 255 | and #$08 256 | beq RxWait ; No 257 | lda ACIA_RXD ; Yes, read it 258 | plp ; Restore register sizes 259 | rts ; Done 260 | 261 | ; Check if the receive buffer contains any data and return C=1 if there is 262 | ; some. 263 | 264 | public UartRxTest 265 | UartRxTest: 266 | pha ; Save callers A 267 | php 268 | short_a 269 | lda ACIA_SR ; Read the status register 270 | plp 271 | ror a ; Shift RDRF bit into carry 272 | ror a 273 | ror a 274 | ror a 275 | pla ; Restore A 276 | rts ; Done 277 | 278 | endif 279 | 280 | ;=============================================================================== 281 | ; ROM Bank Selection 282 | ;------------------------------------------------------------------------------- 283 | 284 | ; Select the flash ROM bank indicated by the two low order bits of A. The pins 285 | ; should be set to inputs when a hi bit is needed and a low output for a lo bit. 286 | 287 | public RomSelect 288 | RomSelect: 289 | php ; Ensure 8-bit A 290 | short_a 291 | ror a ; Shift out bit 0 292 | php ; .. and save 293 | ror a ; Shift out bit 1 294 | lda #0 ; Work out pattern 295 | bcs $+4 296 | ora #%11000000 297 | plp 298 | bcs $+4 299 | ora #%00001100 300 | sta VIA2_PCR ; And set 301 | plp 302 | rts ; Done 303 | 304 | ; Check if the select ROM bank contains WDC firmware. If it does return with 305 | ; the Z flag set. 306 | 307 | public RomCheck 308 | RomCheck: 309 | lda VIA2_PCR ; WDC ROM selected? 310 | and #%11001100 311 | rts 312 | 313 | ;=============================================================================== 314 | ; Reset Vectors 315 | ;------------------------------------------------------------------------------- 316 | 317 | ShadowVectors section offset $7ee0 318 | 319 | ds 4 ; Reserved 320 | dw COP ; $FFE4 - COP(816) 321 | dw BRK ; $FFE6 - BRK(816) 322 | dw ABORT ; $FFE8 - ABORT(816) 323 | dw NMI ; $FFEA - NMI(816) 324 | ds 2 ; Reserved 325 | dw IRQ ; $FFEE - IRQ(816) 326 | 327 | ds 4 328 | dw COP ; $FFF4 - COP(C02) 329 | ds 2 ; $Reserved 330 | dw ABORT ; $FFF8 - ABORT(C02) 331 | dw NMIRQ ; $FFFA - NMI(C02) 332 | dw RESET ; $FFFC - RESET(C02) 333 | dw IRQBRK ; $FFFE - IRQBRK(C02) 334 | 335 | ends 336 | 337 | ;------------------------------------------------------------------------------ 338 | 339 | Vectors section offset $ffe0 340 | 341 | ds 4 ; Reserved 342 | dw COP ; $FFE4 - COP(816) 343 | dw BRK ; $FFE6 - BRK(816) 344 | dw ABORT ; $FFE8 - ABORT(816) 345 | dw NMI ; $FFEA - NMI(816) 346 | ds 2 ; Reserved 347 | dw IRQ ; $FFEE - IRQ(816) 348 | 349 | ds 4 350 | dw COP ; $FFF4 - COP(C02) 351 | ds 2 ; $Reserved 352 | dw ABORT ; $FFF8 - ABORT(C02) 353 | dw NMIRQ ; $FFFA - NMI(C02) 354 | dw RESET ; $FFFC - RESET(C02) 355 | dw IRQBRK ; $FFFE - IRQBRK(C02) 356 | 357 | ends 358 | 359 | end -------------------------------------------------------------------------------- /w65c816sxb.inc: -------------------------------------------------------------------------------- 1 | ;============================================================================== 2 | ; __ ____ ____ ____ ___ _ __ ______ ______ 3 | ; \ \ / / /_| ___| / ___( _ )/ |/ /_/ ___\ \/ / __ ) 4 | ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \___ \\ /| _ \ 5 | ; \ V V /| (_) |__) | |__| (_) | | (_) |__) / \| |_) | 6 | ; \_/\_/ \___/____/ \____\___/|_|\___/____/_/\_\____/ 7 | ; 8 | ; Western Design Center W65C816SXB Development Board Hardware Definitions 9 | ;------------------------------------------------------------------------------ 10 | ; Copyright (C)2015 HandCoded Software Ltd. 11 | ; All rights reserved. 12 | ; 13 | ; This work is made available under the terms of the Creative Commons 14 | ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 15 | ; following URL to see the details. 16 | ; 17 | ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 18 | ; 19 | ;============================================================================== 20 | ; Notes: 21 | ; 22 | ; All of the current stock of W65C51 ACIAs have a silicon bug that causes the 23 | ; 'Transmit Data Register Empty' (TDRE) bit in the status register to be stuck 24 | ; high making it impossible to tell when the transmitter is ready for the next 25 | ; data byte. 26 | ; 27 | ;------------------------------------------------------------------------------ 28 | 29 | OSC_FREQ equ 8000000 ; SXB runs at 8MHz 30 | 31 | ;============================================================================== 32 | ; W65C51 ACIA 33 | ;------------------------------------------------------------------------------ 34 | 35 | ACIA_RXD equ $7f80 36 | ACIA_TXD equ $7f80 37 | ACIA_SR equ $7f81 38 | ACIA_CMD equ $7f82 39 | ACIA_CTL equ $7f83 40 | 41 | ;============================================================================== 42 | ; W65C21 PIA 43 | ;------------------------------------------------------------------------------ 44 | 45 | PIA_PIA equ $7fa0 46 | PIA_DDRA equ $7fa0 47 | PIA_CRA equ $7fa1 48 | PIA_PIB equ $7fa2 49 | PIA_DDRB equ $7fa2 50 | PIA_CRB equ $7fa3 51 | 52 | ;============================================================================== 53 | ; W65C22 VIA 54 | ;------------------------------------------------------------------------------ 55 | 56 | VIA1_ORB equ $7fc0 57 | VIA1_IRB equ $7fc0 58 | VIA1_ORA equ $7fc1 59 | VIA1_IRA equ $7fc1 60 | VIA1_DDRB equ $7fc2 61 | VIA1_DDRA equ $7fc3 62 | VIA1_T1CL equ $7fc4 63 | VIA1_T1CH equ $7fc5 64 | VIA1_T1LL equ $7fc6 65 | VIA1_T1LH equ $7fc7 66 | VIA1_T2CL equ $7fc8 67 | VIA1_T2CH equ $7fc9 68 | VIA1_SR equ $7fca 69 | VIA1_ACR equ $7fcb 70 | VIA1_PCR equ $7fcc 71 | VIA1_IFR equ $7fcd 72 | VIA1_IER equ $7fce 73 | VIA1_ORAN equ $7fcf 74 | VIA1_IRAN equ $7fcf 75 | 76 | ;------------------------------------------------------------------------------ 77 | 78 | VIA2_ORB equ $7fe0 79 | VIA2_IRB equ $7fe0 80 | VIA2_ORA equ $7fe1 81 | VIA2_IRA equ $7fe1 82 | VIA2_DDRB equ $7fe2 83 | VIA2_DDRA equ $7fe3 84 | VIA2_T1CL equ $7fe4 85 | VIA2_T1CH equ $7fe5 86 | VIA2_T1LL equ $7fe6 87 | VIA2_T1LH equ $7fe7 88 | VIA2_T2CL equ $7fe8 89 | VIA2_T2CH equ $7fe9 90 | VIA2_SR equ $7fea 91 | VIA2_ACR equ $7feb 92 | VIA2_PCR equ $7fec 93 | VIA2_IFR equ $7fed 94 | VIA2_IER equ $7fee 95 | VIA2_ORAN equ $7fef 96 | VIA2_IRAN equ $7fef 97 | -------------------------------------------------------------------------------- /w65c816sxb.lst: -------------------------------------------------------------------------------- 1 | Wed Oct 26 2016 20:30 Page 1 2 | 3 | 4 | *************************************** 5 | ** WDC 65C816 Macro Assembler ** 6 | ** ** 7 | ** Version 3.49.1- Feb 6 2006 ** 8 | *************************************** 9 | 10 | 1 ;=============================================================================== 11 | 2 ; __ ____ ____ ____ ___ _ __ ______ ______ 12 | 3 ; \ \ / / /_| ___| / ___( _ )/ |/ /_/ ___\ \/ / __ ) 13 | 4 ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \___ \\ /| _ \ 14 | 5 ; \ V V /| (_) |__) | |__| (_) | | (_) |__) / \| |_) | 15 | 6 ; \_/\_/ \___/____/ \____\___/|_|\___/____/_/\_\____/ 16 | 7 ; 17 | 8 ; Basic Vector Handling for the W65C816SXB Development Board 18 | 9 ;------------------------------------------------------------------------------- 19 | 10 ; Copyright (C)2015 HandCoded Software Ltd. 20 | 11 ; All rights reserved. 21 | 12 ; 22 | 13 ; This work is made available under the terms of the Creative Commons 23 | 14 ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 24 | 15 ; following URL to see the details. 25 | 16 ; 26 | 17 ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 27 | 18 ; 28 | 19 ;=============================================================================== 29 | 20 ; Notes: 30 | 21 ; 31 | 22 ; Timer2 in the VIA2 is used to time the ACIA transmissions and determine when 32 | 23 ; the device is capable of sending another character. 33 | 24 ; 34 | 25 ;------------------------------------------------------------------------------- 35 | 26 36 | 27 pw 132 37 | 28 inclist on 38 | 29 39 | 30 chip 65816 40 | 31 41 | 32 include "w65c816.inc" 42 | 1 ;============================================================================== 43 | 2 ; __ ____ ____ ____ ___ _ __ 44 | 3 ; \ \ / / /_| ___| / ___( _ )/ |/ /_ 45 | 4 ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \ 46 | 5 ; \ V V /| (_) |__) | |__| (_) | | (_) | 47 | 6 ; \_/\_/ \___/____/ \____\___/|_|\___/ 48 | 7 ; 49 | 8 ; Western Design Center W65C816 device definitions 50 | 9 ;------------------------------------------------------------------------------ 51 | 10 ; Copyright (C)2015 HandCoded Software Ltd. 52 | 11 ; All rights reserved. 53 | 12 ; 54 | 13 ; This work is made available under the terms of the Creative Commons 55 | 14 ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 56 | 15 ; following URL to see the details. 57 | 16 ; 58 | 17 ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 59 | 18 ; 60 | 19 ;=============================================================================== 61 | 20 ; Notes: 62 | Wed Oct 26 2016 20:30 Page 2 63 | 64 | 65 | 21 ; 66 | 22 ; Various macros and definitions for the W65C816 microprocessor. 67 | 23 ; 68 | 24 ;=============================================================================== 69 | 25 ; Revision History: 70 | 26 ; 71 | 27 ; 2015-12-18 AJ Initial version 72 | 28 ;------------------------------------------------------------------------------- 73 | 29 ; $Id$ 74 | 30 ;------------------------------------------------------------------------------- 75 | 31 76 | 32 ;============================================================================== 77 | 33 ; Status Register Bits 78 | 34 ;------------------------------------------------------------------------------ 79 | 35 80 | 36 00000080 N_FLAG equ 1<<7 81 | 37 00000040 V_FLAG equ 1<<6 82 | 38 00000020 M_FLAG equ 1<<5 83 | 39 00000010 X_FLAG equ 1<<4 84 | 40 00000010 B_FLAG equ 1<<4 85 | 41 00000008 D_FLAG equ 1<<3 86 | 42 00000004 I_FLAG equ 1<<2 87 | 43 00000002 Z_FLAG equ 1<<1 88 | 44 00000001 C_FLAG equ 1<<0 89 | 45 90 | 46 ;============================================================================== 91 | 47 ; Macros 92 | 48 ;------------------------------------------------------------------------------ 93 | 49 94 | 50 ; Puts the processor in emulation mode. A, X and Y become 8-bits and the stack 95 | 51 ; is fixed at $0100-$01ff. 96 | 52 97 | 53 emulate macro 98 | 54 sec 99 | 55 xce 100 | 56 endm 101 | 57 102 | 58 ; Puts the processor in native mode. The size of the memory and index register 103 | 59 ; operations is not controlled by the M & X bits in the status register. 104 | 60 105 | 61 native macro 106 | 62 clc 107 | 63 xce 108 | 64 endm 109 | 65 110 | 66 ; Resets the M bit making the accumulator and memory accesses 16-bits wide. 111 | 67 112 | 68 long_a macro 113 | 69 rep #M_FLAG 114 | 70 longa on 115 | 71 endm 116 | 72 117 | 73 ; Resets the X bit making the index registers 16-bits wide 118 | 74 119 | 75 long_i macro 120 | 76 rep #X_FLAG 121 | 77 longi on 122 | 78 endm 123 | Wed Oct 26 2016 20:30 Page 3 124 | 125 | 126 | 79 127 | 80 ; Resets the M and X bits making the accumulator, memory accesses and index 128 | 81 ; registers 16-bits wide. 129 | 82 130 | 83 long_ai macro 131 | 84 rep #M_FLAG|X_FLAG 132 | 85 longa on 133 | 86 longi on 134 | 87 endm 135 | 88 136 | 89 ; Sets the M bit making the accumulator and memory accesses 8-bits wide. 137 | 90 138 | 91 short_a macro 139 | 92 sep #M_FLAG 140 | 93 longa off 141 | 94 endm 142 | 95 143 | 96 ; Sets the X bit making the index registers 8-bits wide. 144 | 97 145 | 98 short_i macro 146 | 99 sep #X_FLAG 147 | 100 longi off 148 | 101 endm 149 | 102 150 | 103 ; Sets the M & X bits making the accumulator, memory accesses and index 151 | 104 ; registers 8-bits wide. 152 | 105 153 | 106 short_ai macro 154 | 107 sep #M_FLAG|X_FLAG 155 | 108 longa off 156 | 109 longi off 157 | 110 endm 158 | 33 include "w65c816sxb.inc" 159 | 1 ;============================================================================== 160 | 2 ; __ ____ ____ ____ ___ _ __ ______ ______ 161 | 3 ; \ \ / / /_| ___| / ___( _ )/ |/ /_/ ___\ \/ / __ ) 162 | 4 ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \___ \\ /| _ \ 163 | 5 ; \ V V /| (_) |__) | |__| (_) | | (_) |__) / \| |_) | 164 | 6 ; \_/\_/ \___/____/ \____\___/|_|\___/____/_/\_\____/ 165 | 7 ; 166 | 8 ; Western Design Center W65C816SXB Development Board Hardware Definitions 167 | 9 ;------------------------------------------------------------------------------ 168 | 10 ; Copyright (C)2015 HandCoded Software Ltd. 169 | 11 ; All rights reserved. 170 | 12 ; 171 | 13 ; This work is made available under the terms of the Creative Commons 172 | 14 ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the 173 | 15 ; following URL to see the details. 174 | 16 ; 175 | 17 ; http://creativecommons.org/licenses/by-nc-sa/4.0/ 176 | 18 ; 177 | 19 ;============================================================================== 178 | 20 ; Notes: 179 | 21 ; 180 | 22 ; All of the current stock of W65C51 ACIAs have a silicon bug that causes the 181 | 23 ; 'Transmit Data Register Empty' (TDRE) bit in the status register to be stuck 182 | 24 ; high making it impossible to tell when the transmitter is ready for the next 183 | 25 ; data byte. 184 | Wed Oct 26 2016 20:30 Page 4 185 | 186 | 187 | 26 ; 188 | 27 ;------------------------------------------------------------------------------ 189 | 28 190 | 29 007A1200 OSC_FREQ equ 8000000 ; SXB runs at 8MHz 191 | 30 192 | 31 ;============================================================================== 193 | 32 ; W65C51 ACIA 194 | 33 ;------------------------------------------------------------------------------ 195 | 34 196 | 35 00007F80 ACIA_RXD equ $7f80 197 | 36 00007F80 ACIA_TXD equ $7f80 198 | 37 00007F81 ACIA_SR equ $7f81 199 | 38 00007F82 ACIA_CMD equ $7f82 200 | 39 00007F83 ACIA_CTL equ $7f83 201 | 40 202 | 41 ;============================================================================== 203 | 42 ; W65C21 PIA 204 | 43 ;------------------------------------------------------------------------------ 205 | 44 206 | 45 00007FA0 PIA_PIA equ $7fa0 207 | 46 00007FA0 PIA_DDRA equ $7fa0 208 | 47 00007FA1 PIA_CRA equ $7fa1 209 | 48 00007FA2 PIA_PIB equ $7fa2 210 | 49 00007FA2 PIA_DDRB equ $7fa2 211 | 50 00007FA3 PIA_CRB equ $7fa3 212 | 51 213 | 52 ;============================================================================== 214 | 53 ; W65C22 VIA 215 | 54 ;------------------------------------------------------------------------------ 216 | 55 217 | 56 00007FC0 VIA1_ORB equ $7fc0 218 | 57 00007FC0 VIA1_IRB equ $7fc0 219 | 58 00007FC1 VIA1_ORA equ $7fc1 220 | 59 00007FC1 VIA1_IRA equ $7fc1 221 | 60 00007FC2 VIA1_DDRB equ $7fc2 222 | 61 00007FC3 VIA1_DDRA equ $7fc3 223 | 62 00007FC4 VIA1_T1CL equ $7fc4 224 | 63 00007FC5 VIA1_T1CH equ $7fc5 225 | 64 00007FC6 VIA1_T1LL equ $7fc6 226 | 65 00007FC7 VIA1_T1LH equ $7fc7 227 | 66 00007FC8 VIA1_T2CL equ $7fc8 228 | 67 00007FC9 VIA1_T2CH equ $7fc9 229 | 68 00007FCA VIA1_SR equ $7fca 230 | 69 00007FCB VIA1_ACR equ $7fcb 231 | 70 00007FCC VIA1_PCR equ $7fcc 232 | 71 00007FCD VIA1_IFR equ $7fcd 233 | 72 00007FCE VIA1_IER equ $7fce 234 | 73 00007FCF VIA1_ORAN equ $7fcf 235 | 74 00007FCF VIA1_IRAN equ $7fcf 236 | 75 237 | 76 ;------------------------------------------------------------------------------ 238 | 77 239 | 78 00007FE0 VIA2_ORB equ $7fe0 240 | 79 00007FE0 VIA2_IRB equ $7fe0 241 | 80 00007FE1 VIA2_ORA equ $7fe1 242 | 81 00007FE1 VIA2_IRA equ $7fe1 243 | 82 00007FE2 VIA2_DDRB equ $7fe2 244 | 83 00007FE3 VIA2_DDRA equ $7fe3 245 | Wed Oct 26 2016 20:30 Page 5 246 | 247 | 248 | 84 00007FE4 VIA2_T1CL equ $7fe4 249 | 85 00007FE5 VIA2_T1CH equ $7fe5 250 | 86 00007FE6 VIA2_T1LL equ $7fe6 251 | 87 00007FE7 VIA2_T1LH equ $7fe7 252 | 88 00007FE8 VIA2_T2CL equ $7fe8 253 | 89 00007FE9 VIA2_T2CH equ $7fe9 254 | 90 00007FEA VIA2_SR equ $7fea 255 | 91 00007FEB VIA2_ACR equ $7feb 256 | 92 00007FEC VIA2_PCR equ $7fec 257 | 93 00007FED VIA2_IFR equ $7fed 258 | 94 00007FEE VIA2_IER equ $7fee 259 | 95 00007FEF VIA2_ORAN equ $7fef 260 | 96 00007FEF VIA2_IRAN equ $7fef 261 | 34 262 | 35 ;=============================================================================== 263 | 36 ; Configuration 264 | 37 ;------------------------------------------------------------------------------- 265 | 38 266 | 39 00000000 USE_FIFO equ 0 ; Build using USB FIFO as UART 267 | 40 268 | 41 00004B00 BAUD_RATE equ 19200 ; ACIA baud rate 269 | 42 270 | 43 ;------------------------------------------------------------------------------- 271 | 44 272 | 45 000011E8 TXD_COUNT equ OSC_FREQ/(BAUD_RATE/11) 273 | 46 274 | 47 if TXD_COUNT&$ffff0000 275 | 48 messg "TXD_DELAY does not fit in 16-bits" 276 | 49 endif 277 | 50 278 | 51 ;=============================================================================== 279 | 52 ; Power On Reset 280 | 53 ;------------------------------------------------------------------------------- 281 | 54 282 | 55 code 283 | 56 extern Start 284 | 57 longi off 285 | 58 longa off 286 | 59 RESET: 287 | 60 00:0000: 78 sei ; Stop interrupts 288 | 61 00:0001: A2 FF ldx #$ff ; Reset the stack 289 | 62 00:0003: 9A txs 290 | 63 291 | 64 00:0004: AD CE 7F lda VIA1_IER ; Ensure no via interrupts 292 | 65 00:0007: 8D CE 7F sta VIA1_IER 293 | 66 00:000A: AD EE 7F lda VIA2_IER 294 | 67 00:000D: 8D EE 7F sta VIA2_IER 295 | 68 296 | 69 if USE_FIFO 297 | 70 lda #$1c ; Configure VIA for USB FIFO 298 | 71 sta VIA2_DDRB 299 | 72 lda #$18 300 | 73 sta VIA2_ORB 301 | 74 else 302 | 75 00:0010: 9C 82 7F stz ACIA_CMD ; Configure ACIA 303 | 76 00:0013: 9C 83 7F stz ACIA_CTL 304 | 77 00:0016: 9C 81 7F stz ACIA_SR 305 | 78 306 | Wed Oct 26 2016 20:30 Page 6 307 | 308 | 309 | 79 00:0019: A9 1F lda #%00011111 ; 8 bits, 1 stop bit, 19200 baud 310 | 80 00:001B: 8D 83 7F sta ACIA_CTL 311 | 81 00:001E: A9 C9 lda #%11001001 ; No parity, no interrupt 312 | 82 00:0020: 8D 82 7F sta ACIA_CMD 313 | 83 00:0023: AD 80 7F lda ACIA_RXD ; Clear receive buffer 314 | 84 315 | 85 00:0026: A9 20 lda #1<<5 ; Put VIA2 T2 into timed mode 316 | 86 00:0028: 1C EB 7F trb VIA2_ACR 317 | 87 00:002B: 20 xx xx jsr TxDelay ; And prime the timer 318 | 88 endif 319 | 89 320 | 90 native ; Switch to native mode 321 | + 90 00:002E: 18 clc 322 | + 90 00:002F: FB xce 323 | 91 00:0030: 4C xx xx jmp Start ; Jump to the application start 324 | 92 325 | 93 ;=============================================================================== 326 | 94 ; Interrupt Handlers 327 | 95 ;------------------------------------------------------------------------------- 328 | 96 329 | 97 ; Handle IRQ and BRK interrupts in emulation mode. 330 | 98 331 | 99 IRQBRK: 332 | 100 00:0033: 80 FE bra $ ; Loop forever 333 | 101 334 | 102 ; Handle NMI interrupts in emulation mode. 335 | 103 336 | 104 NMIRQ: 337 | 105 00:0035: 80 FE bra $ ; Loop forever 338 | 106 339 | 107 ;------------------------------------------------------------------------------- 340 | 108 341 | 109 ; Handle IRQ interrupts in native mode. 342 | 110 343 | 111 IRQ: 344 | 112 00:0037: 80 FE bra $ ; Loop forever 345 | 113 346 | 114 ; Handle IRQ interrupts in native mode. 347 | 115 348 | 116 BRK: 349 | 117 00:0039: 80 FE bra $ ; Loop forever 350 | 118 351 | 119 ; Handle IRQ interrupts in native mode. 352 | 120 353 | 121 NMI: 354 | 122 00:003B: 80 FE bra $ ; Loop forever 355 | 123 356 | 124 ;------------------------------------------------------------------------------- 357 | 125 358 | 126 ; COP and ABORT interrupts are not handled. 359 | 127 360 | 128 COP: 361 | 129 00:003D: 80 FE bra $ ; Loop forever 362 | 130 363 | 131 ABORT: 364 | 132 00:003F: 80 FE bra $ ; Loop forever 365 | 133 366 | 134 ;=============================================================================== 367 | Wed Oct 26 2016 20:30 Page 7 368 | 369 | 370 | 135 ; USB FIFO Interface 371 | 136 ;------------------------------------------------------------------------------- 372 | 137 373 | 138 if USE_FIFO 374 | 139 375 | 140 ; Add the character in A to the FTDI USB FIFO transmit buffer. If the buffer 376 | 141 ; is full wait for space to become available. 377 | 142 378 | 143 public UartTx 379 | 144 UartTx: 380 | 145 phx 381 | 146 php 382 | 147 short_ai 383 | 148 ldx #$00 ; Make data port all input 384 | 149 stx VIA2_DDRA 385 | 150 sta VIA2_ORA ; Save the output character 386 | 151 lda #%01 387 | 152 TxWait: bit VIA2_IRB ; Is there space for more data 388 | 153 bne TxWait 389 | 154 390 | 155 lda VIA2_IRB ; Strobe WR 391 | 156 and #$fb 392 | 157 tax 393 | 158 ora #$04 394 | 159 sta VIA2_ORB 395 | 160 lda #$ff ; Make data port all output 396 | 161 sta VIA2_DDRA 397 | 162 nop 398 | 163 nop 399 | 164 stx VIA2_ORB ; End strobe 400 | 165 lda VIA2_IRA 401 | 166 ldx #$00 ; Make data port all output 402 | 167 stx VIA2_DDRA 403 | 168 plp 404 | 169 plx 405 | 170 rts 406 | 171 407 | 172 ; Read a character from the FTDI USB FIFO and return it in A. If no data is 408 | 173 ; available then wait for some to arrive. 409 | 174 410 | 175 public UartRx 411 | 176 UartRx 412 | 177 phx ; Save callers X 413 | 178 php ; Save register sizes 414 | 179 short_ai ; Make registers 8-bit 415 | 180 lda #$02 ; Wait until data in buffer 416 | 181 RxWait: bit VIA2_IRB 417 | 182 bne RxWait 418 | 183 419 | 184 lda VIA2_IRB ; Strobe /RD low 420 | 185 ora #$08 421 | 186 tax 422 | 187 and #$f7 423 | 188 sta VIA2_ORB 424 | 189 nop ; Wait for data to be available 425 | 190 nop 426 | 191 nop 427 | 192 nop 428 | Wed Oct 26 2016 20:30 Page 8 429 | 430 | 431 | 193 lda VIA2_IRA ; Read it 432 | 194 stx VIA2_ORB ; And end the strobe 433 | 195 plp ; Restore register sizes 434 | 196 plx ; .. and callers X 435 | 197 rts ; Done 436 | 198 437 | 199 ; Check if the receive buffer in the FIFO contains any data and return C=1 if 438 | 200 ; there is some. 439 | 201 440 | 202 public UartRxText 441 | 203 UartRxTest: 442 | 204 pha ; Save callers A 443 | 205 php ; Save register sizes 444 | 206 short_a ; Make A 8-bits 445 | 207 lda VIA2_IRB ; Load status bits 446 | 208 plp ; Restore register sizes 447 | 209 ror a ; Shift data available flag 448 | 210 ror a ; .. into carry 449 | 211 pla ; Restore A 450 | 212 rts ; Done 451 | 213 452 | 214 ;=============================================================================== 453 | 215 ; ACIA Interface 454 | 216 ;------------------------------------------------------------------------------- 455 | 217 456 | 218 else 457 | 219 458 | 220 ; Wait until the Timer2 in VIA2 indicates that the last transmission has been 459 | 221 ; completed then send the character in A and restart the timer. 460 | 222 461 | 223 public UartTx 462 | 224 UartTx: 463 | 225 00:0041: 48 pha ; Save the character 464 | 226 00:0042: 08 php ; Save register sizes 465 | 227 short_a ; Make A 8-bits 466 | + 227 00:0043: E2 20 sep #M_FLAG 467 | + 227 longa off 468 | 228 00:0045: 48 pha 469 | 229 00:0046: A9 20 lda #1<<5 470 | 230 00:0048: 2C ED 7F TxWait: bit VIA2_IFR ; Has the timer finished? 471 | 231 00:004B: F0 FB beq TxWait 472 | 232 00:004D: 20 xx xx jsr TxDelay ; Yes, re-reload the timer 473 | 233 00:0050: 68 pla 474 | 234 00:0051: 8D 80 7F sta ACIA_TXD ; Transmit the character 475 | 235 00:0054: 28 plp ; Restore register sizes 476 | 236 00:0055: 68 pla ; And callers A 477 | 237 00:0056: 60 rts ; Done 478 | 238 479 | 239 TxDelay: 480 | 240 00:0057: A9 E8 lda #TXD_COUNT 483 | 243 00:005E: 8D E9 7F sta VIA2_T2CH 484 | 244 00:0061: 60 rts 485 | 245 486 | 246 ; Fetch the next character from the receive buffer waiting for some to arrive 487 | 247 ; if the buffer is empty. 488 | 248 489 | Wed Oct 26 2016 20:30 Page 9 490 | 491 | 492 | 249 public UartRx 493 | 250 UartRx: 494 | 251 00:0062: 08 php ; Save register sizes 495 | 252 short_a ; Make A 8-bits 496 | + 252 00:0063: E2 20 sep #M_FLAG 497 | + 252 longa off 498 | 253 RxWait: 499 | 254 00:0065: AD 81 7F lda ACIA_SR ; Any data in RX buffer? 500 | 255 00:0068: 29 08 and #$08 501 | 256 00:006A: F0 F9 beq RxWait ; No 502 | 257 00:006C: AD 80 7F lda ACIA_RXD ; Yes, read it 503 | 258 00:006F: 28 plp ; Restore register sizes 504 | 259 00:0070: 60 rts ; Done 505 | 260 506 | 261 ; Check if the receive buffer contains any data and return C=1 if there is 507 | 262 ; some. 508 | 263 509 | 264 public UartRxTest 510 | 265 UartRxTest: 511 | 266 00:0071: 48 pha ; Save callers A 512 | 267 00:0072: 08 php 513 | 268 short_a 514 | + 268 00:0073: E2 20 sep #M_FLAG 515 | + 268 longa off 516 | 269 00:0075: AD 81 7F lda ACIA_SR ; Read the status register 517 | 270 00:0078: 28 plp 518 | 271 00:0079: 6A ror a ; Shift RDRF bit into carry 519 | 272 00:007A: 6A ror a 520 | 273 00:007B: 6A ror a 521 | 274 00:007C: 6A ror a 522 | 275 00:007D: 68 pla ; Restore A 523 | 276 00:007E: 60 rts ; Done 524 | 277 525 | 278 endif 526 | 279 527 | 280 ;=============================================================================== 528 | 281 ; ROM Bank Selection 529 | 282 ;------------------------------------------------------------------------------- 530 | 283 531 | 284 ; Select the flash ROM bank indicated by the two low order bits of A. The pins 532 | 285 ; should be set to inputs when a hi bit is needed and a low output for a lo bit. 533 | 286 534 | 287 public RomSelect 535 | 288 RomSelect: 536 | 289 00:007F: 08 php ; Ensure 8-bit A 537 | 290 short_a 538 | + 290 00:0080: E2 20 sep #M_FLAG 539 | + 290 longa off 540 | 291 00:0082: 6A ror a ; Shift out bit 0 541 | 292 00:0083: 08 php ; .. and save 542 | 293 00:0084: 6A ror a ; Shift out bit 1 543 | 294 00:0085: A9 00 lda #0 ; Work out pattern 544 | 295 00:0087: B0 02 bcs $+4 545 | 296 00:0089: 09 C0 ora #%11000000 546 | 297 00:008B: 28 plp 547 | 298 00:008C: B0 02 bcs $+4 548 | 299 00:008E: 09 0C ora #%00001100 549 | 300 00:0090: 8D EC 7F sta VIA2_PCR ; And set 550 | Wed Oct 26 2016 20:30 Page 10 551 | 552 | 553 | 301 00:0093: 28 plp 554 | 302 00:0094: 60 rts ; Done 555 | 303 556 | 304 ; Check if the select ROM bank contains WDC firmware. If it does return with 557 | 305 ; the Z flag set. 558 | 306 559 | 307 public RomCheck 560 | 308 RomCheck: 561 | 309 00:0095: AD EC 7F lda VIA2_PCR ; WDC ROM selected? 562 | 310 00:0098: 29 CC and #%11001100 563 | 311 00:009A: 60 rts 564 | 312 565 | 313 ;=============================================================================== 566 | 314 ; Reset Vectors 567 | 315 ;------------------------------------------------------------------------------- 568 | 316 569 | 317 ShadowVectors section offset $7ee0 570 | 318 571 | 319 00:7EE0: ds 4 ; Reserved 572 | 320 00:7EE4: xx xx dw COP ; $FFE4 - COP(816) 573 | 321 00:7EE6: xx xx dw BRK ; $FFE6 - BRK(816) 574 | 322 00:7EE8: xx xx dw ABORT ; $FFE8 - ABORT(816) 575 | 323 00:7EEA: xx xx dw NMI ; $FFEA - NMI(816) 576 | 324 00:7EEC: ds 2 ; Reserved 577 | 325 00:7EEE: xx xx dw IRQ ; $FFEE - IRQ(816) 578 | 326 579 | 327 00:7EF0: ds 4 580 | 328 00:7EF4: xx xx dw COP ; $FFF4 - COP(C02) 581 | 329 00:7EF6: ds 2 ; $Reserved 582 | 330 00:7EF8: xx xx dw ABORT ; $FFF8 - ABORT(C02) 583 | 331 00:7EFA: xx xx dw NMIRQ ; $FFFA - NMI(C02) 584 | 332 00:7EFC: xx xx dw RESET ; $FFFC - RESET(C02) 585 | 333 00:7EFE: xx xx dw IRQBRK ; $FFFE - IRQBRK(C02) 586 | 334 587 | 335 00:7F00: ends 588 | 336 589 | 337 ;------------------------------------------------------------------------------ 590 | 338 591 | 339 Vectors section offset $ffe0 592 | 340 593 | 341 00:FFE0: ds 4 ; Reserved 594 | 342 00:FFE4: xx xx dw COP ; $FFE4 - COP(816) 595 | 343 00:FFE6: xx xx dw BRK ; $FFE6 - BRK(816) 596 | 344 00:FFE8: xx xx dw ABORT ; $FFE8 - ABORT(816) 597 | 345 00:FFEA: xx xx dw NMI ; $FFEA - NMI(816) 598 | 346 00:FFEC: ds 2 ; Reserved 599 | 347 00:FFEE: xx xx dw IRQ ; $FFEE - IRQ(816) 600 | 348 601 | 349 00:FFF0: ds 4 602 | 350 00:FFF4: xx xx dw COP ; $FFF4 - COP(C02) 603 | 351 00:FFF6: ds 2 ; $Reserved 604 | 352 00:FFF8: xx xx dw ABORT ; $FFF8 - ABORT(C02) 605 | 353 00:FFFA: xx xx dw NMIRQ ; $FFFA - NMI(C02) 606 | 354 00:FFFC: xx xx dw RESET ; $FFFC - RESET(C02) 607 | 355 00:FFFE: xx xx dw IRQBRK ; $FFFE - IRQBRK(C02) 608 | 356 609 | 357 01:0000: ends 610 | 358 611 | Wed Oct 26 2016 20:30 Page 11 612 | 613 | 614 | 359 end 615 | 616 | 617 | Lines assembled: 575 618 | Errors: 0 619 | --------------------------------------------------------------------------------