├── Makefile ├── README.md ├── edit.a65 ├── forth ├── core.fs ├── dump.fs ├── fib.fs ├── life.fs ├── life.slow.fs ├── mandelbrot.fs ├── mandelbrot2.fs ├── nqueens.fs ├── rect.fs ├── sieve.fs └── twice.fs ├── iorom.a65 ├── sd.a65 ├── secnd1.a65 ├── secnd10.a65 ├── secnd2.a65 ├── secnd3.a65 ├── secnd4.a65 ├── secnd5.a65 ├── secnd6.a65 ├── secnd7.a65 ├── secnd8.a65 ├── secnd9.a65 └── vforth.a65 /Makefile: -------------------------------------------------------------------------------- 1 | XA=xa 2 | MKHEX=mkhex 3 | MKROM=mkrom 4 | 5 | %.x65: %.a65 6 | $(XA) -M -l `basename $< .a65`.lab -o $@ $< 7 | 8 | %.hex: %.x65 9 | $(MKHEX) $< > $@ 10 | 11 | %.rom: %.hex 12 | $(MKROM) $< 13 | 14 | %.xab: %.rom 15 | split -b 16384 $< `basename $< .rom`".x" 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # secnd 2 | FORTH implementation for 65C02 3 | Paul Dourish, December 2017 4 | 5 | When I was 17, I wrote an implementation of FORTH in 6502 assembly 6 | language in a notebook during my summer vacation, and later got 7 | it working for my BBC Micro. The computer, the floppy disks, and the 8 | notebook are, sadly, long gone. But lately I built a 65C02-based 9 | single-board computer as a hobby and so, naturally, I need to have a 10 | FORTH system for it too. 11 | 12 | The old one was somewhat arbitrary, keeping to the rough parameters 13 | of the one book I'd read on FORTH but not following any particular 14 | conventions about implementation. (I do still have the book, at least.) 15 | This newer FORTH hews closer to the standard models for the 16 | interfunctioning of interpreter and compiler, the operation of 17 | IMMEDIATE words, and so on. Where in doubt, it follows ANS Forth 18 | although I'm being far from religious about it. 19 | 20 | Chuck Moore's FORTH was an abbreviation of "fourth", limited by 21 | the conventions of the filesystem on which it was written. This being 22 | my second Forth implementation, "SECND" is an abbreviation of 23 | "second" as an homage. 24 | 25 | v01 is a very first, minimal implementation with a text interpreter 26 | and just a few words. 27 | 28 | v02 has a more fleshed out vocabulary, variables, and R-stack 29 | manipulations. 30 | 31 | v03 includes the initial compiler, plus strings, looping, and 32 | conditionals. 33 | 34 | v05 has recursion, double-length arithmetic, and signed arithmetic. 35 | 36 | v06 is mainly focused on clean-up, efficiencies, bug fixes, and 37 | migrating internal operations towards usual Forth models. 38 | 39 | v07 added support for SD cards and the FAT16 filesystem, plus the block 40 | system and screen editor. 41 | 42 | v08 finally implemented create/does>, cleaned up lots of rough edges, 43 | improved performance, and worked on both the compiler and interpreter 44 | mechanisms to bring them more into line with standard FORTH practice. 45 | 46 | v09 was the working version, for a good two years. It had some more 47 | work on arithmetic routines, tightened the code to save space, expanded 48 | the FAT16 code, and was turned to run in ROM as well as RAM. It 49 | also added a jump table so that I can call ROM routines easily from 50 | other programs. 51 | 52 | v10 includes support for the new video output and keyoard input that 53 | have been built into the computer, rather than operating through 54 | the serial port. 55 | 56 | Finally, I'm really just using github as a convenient repository 57 | and backup. The code may work for others but I've not done any of 58 | the work of cleaning and clarifying that would be involved in 59 | making it available for others to use. As you can see from these 60 | various versions, my development strategy is not particularly tuned 61 | to git's facilities. 62 | 63 | SECND was developed using the xa cross-assembler, so that's the 64 | syntax being used here. 65 | 66 | More information at https://www.dourish.com/projects/secnd.html. 67 | 68 | -------------------------------------------------------------------------------- /edit.a65: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; SCREEN EDITOR 3 | ;;; 4 | ;;; Basic screen editor for text, using EMACS-like commands. 5 | ;;; Text is laid out in 20 rows of 64 characters, mapped into 6 | ;;; memory with nulls filling empty space. 7 | ;;; 8 | ;;; I stupidly managed to delete the text of my own code, and so 9 | ;;; this is currently being retreived from a disassembled version 10 | ;;; of an executable snapshot. 11 | ;;; 12 | 13 | 14 | SCRATCH=$0010 ; shared with monitor and FORTH 15 | temp=SCRATCH 16 | row=SCRATCH+1 17 | col=SCRATCH+2 18 | rowbase=SCRATCH+3 ; and 4 19 | count=SCRATCH+5 20 | upper=SCRATCH+6 ; and 7 21 | lower=SCRATCH+8 ; and 9 22 | jmpvec=SCRATCH+10 ; and 11 23 | 24 | NROWS=20 25 | MAXROW=NROWS-1 26 | NCOLS=64 27 | MAXCOL=NCOLS-1 28 | TEXTBASE=$5FE0 29 | TEXTSIZE=NROWS*NCOLS 30 | 31 | ACIA_DATA = $8800 32 | ACIA_STATUS = $8801 33 | ACIA_COMMAND = $8802 34 | ACIA_CONTROL = $8803 35 | 36 | 37 | * = $0300 38 | 39 | jmp begin 40 | 41 | 42 | ;;; table of entry points for the commands invoked by each 43 | ;;; control-key. 44 | table 45 | .word tostart ; a 46 | .word back ; b 47 | .word undefined ; c 48 | .word delfwd ; d 49 | .word toend ; e 50 | .word forw ; f 51 | .word undefined ; g 52 | .word delback ; h 53 | .word undefined ; i 54 | .word undefined ; j 55 | .word delline ; k 56 | .word repaint ; l 57 | .word newline ; m 58 | .word next ; n 59 | .word openline ; o 60 | .word prev ; p 61 | .word undefined ; q 62 | .word undefined ; r 63 | .word undefined ; s 64 | .word testcode ; t 65 | .word undefined ; u 66 | .word undefined ; v 67 | .word undefined ; w 68 | .word exit ; x 69 | .word undefined ; y 70 | .word undefined ; z 71 | 72 | 73 | begin 74 | ;; basic setup 75 | lda $FF 76 | txs 77 | cld 78 | sei 79 | 80 | ;; set up ACIA 81 | lda #$0B 82 | sta ACIA_COMMAND 83 | lda #$1F 84 | sta ACIA_CONTROL 85 | 86 | lda #$00 ; initialize rowbase 87 | sta rowbase 88 | lda #$60 89 | sta rowbase+1 90 | 91 | .( 92 | ;; this stuff is zeroing out the text block 93 | lda #NROWS 94 | sta count 95 | rowloop 96 | lda #$00 97 | ldy #MAXCOL ; #$3F 98 | zeroloop 99 | sta (rowbase),y 100 | dey 101 | bne zeroloop 102 | sta (rowbase) 103 | 104 | .( 105 | clc 106 | lda rowbase 107 | adc #NCOLS 108 | sta rowbase 109 | bcc doneadd 110 | inc rowbase+1 111 | doneadd 112 | .) 113 | lda count 114 | dec 115 | sta count 116 | bne rowloop 117 | .) 118 | 119 | ;; reset variables and screen for startup 120 | lda #TEXTBASE 123 | sta rowbase+1 124 | stz row 125 | stz col 126 | jsr cls 127 | jsr home 128 | 129 | 130 | ;;; This is the main editor dispatch loop. Fetch a character; if it's 131 | ;;; in the command-code range, then look it up in the table; otherwise, 132 | ;;; insert it. Everything is done with JMPs and every command JMPs back 133 | ;;; to here. Escape is handled with a separate messy routine rather 134 | ;;; that a second table. 135 | editloop 136 | 137 | jsr readchar 138 | cmp #$1B ; if it's less than 27, it's a control code 139 | beq escape ; exactly 27 is escape 140 | bcs notcmd ; over 27 is not a command 141 | dec ; subtract 1 (to turn it into a 0-ranged value) 142 | asl ; shift to multiply by two 143 | tax ; that's an offset, so put it in X 144 | ; lda table,x ; look up the table value at X 145 | ; sta jmpvec ; and store it in jmpvec 146 | ; lda table+1,x 147 | ; sta jmpvec+1 148 | ; jmp (jmpvec) ; jump to the address 149 | jmp (table,x) 150 | 151 | bra editloop ; shouldn't need this but included for safety 152 | 153 | notcmd 154 | jsr insert 155 | bra editloop 156 | 157 | escape 158 | jsr readchar 159 | cmp #"f" 160 | beq escf 161 | cmp #"b" 162 | beq escb 163 | cmp #"[" 164 | beq arrow 165 | jmp editloop 166 | escf 167 | jmp fowdword 168 | escb 169 | jmp backword 170 | arrow 171 | jsr readchar 172 | cmp #"A" 173 | beq arrowup 174 | cmp #"B" 175 | beq arrowdown 176 | cmp #"C" 177 | beq arrowright 178 | cmp #"D" 179 | beq arrowleft 180 | jmp editloop 181 | arrowup 182 | jmp prev 183 | arrowdown 184 | jmp next 185 | arrowright 186 | jmp forw 187 | arrowleft 188 | jmp back 189 | 190 | ;;; move forward a word. BUG only really uses spaces as delimiters; 191 | ;;; should really use any non-alpha character. 192 | fowdword 193 | .( 194 | ;; if we are on a space, then find a word 195 | ldy col 196 | findword 197 | lda (rowbase),y 198 | beq endofline 199 | cmp #$20 200 | bne findend 201 | iny 202 | cpy #MAXCOL 203 | beq endofline 204 | bra findword 205 | findend 206 | ;; now find the end of the word 207 | lda (rowbase),y 208 | beq endofline 209 | cmp #$20 210 | beq found 211 | iny 212 | cpy #MAXCOL 213 | bne findend 214 | found 215 | endofline 216 | sty col 217 | jsr moveto 218 | jmp editloop 219 | .) 220 | 221 | backword 222 | .( 223 | ;; if we are on a space, then find a word 224 | ldy col 225 | beq finished 226 | findword 227 | lda (rowbase),y 228 | beq nextch 229 | cmp #$20 230 | bne findstart 231 | nextch 232 | dey 233 | beq startofline 234 | bra findword 235 | findstart 236 | ;; now find the end of the word 237 | lda (rowbase),y 238 | beq startofline 239 | cmp #$20 240 | beq found 241 | dey 242 | bne findstart 243 | found 244 | startofline 245 | sty col 246 | jsr moveto 247 | finished 248 | jmp editloop 249 | .) 250 | 251 | 252 | ;; for small integers (<100), convert to decimal and output 253 | todecimal 254 | .( 255 | ldy #$30 256 | sty temp ; temp 257 | convloop 258 | cmp #$0A 259 | bmi donedigit 260 | sec 261 | sbc #$0A 262 | inc temp 263 | bne convloop 264 | donedigit 265 | tay 266 | lda temp 267 | jsr puta 268 | tya 269 | clc 270 | adc #$30 271 | jsr puta 272 | rts 273 | .) 274 | 275 | puta 276 | .( 277 | pha 278 | rdyloop 279 | lda ACIA_STATUS 280 | and #$10 281 | beq rdyloop 282 | pla 283 | sta ACIA_DATA 284 | rts 285 | .) 286 | 287 | cls 288 | lda #$1B ; esc 289 | jsr puta 290 | lda #$5B ; "[" 291 | jsr puta 292 | lda #$32 ; "2" 293 | jsr puta 294 | lda #$4A ; "J" 295 | jsr puta 296 | rts 297 | 298 | home 299 | lda #$1B ; esc 300 | jsr puta 301 | lda #$5B ; [ 302 | jsr puta 303 | lda #$48 ; H 304 | jsr puta 305 | rts 306 | 307 | clrtoend 308 | lda #$1B ; ESC 309 | jsr puta 310 | lda #$5B ; [ 311 | jsr puta 312 | lda #$30 ; 0 313 | jsr puta 314 | lda #$4A ; H 315 | jsr puta 316 | rts 317 | 318 | moveto 319 | lda #$1B ; ESC 320 | jsr puta 321 | lda #$5B ; [ 322 | jsr puta 323 | lda row ; row 324 | inc 325 | jsr todecimal 326 | lda #$3B ; semic 327 | jsr puta 328 | lda col ; col 329 | inc 330 | jsr todecimal 331 | lda #$48 ; H 332 | jsr puta 333 | rts 334 | 335 | next 336 | .( 337 | lda row 338 | cmp #MAXROW 339 | beq donothing 340 | inc row 341 | .( 342 | clc 343 | lda rowbase 344 | adc #NCOLS 345 | sta rowbase 346 | bcc doneadd 347 | inc rowbase+1 348 | doneadd 349 | .) 350 | jsr moveto 351 | donothing 352 | jmp editloop 353 | .) 354 | 355 | prev 356 | .( 357 | lda row 358 | beq donothing 359 | dec row 360 | sec 361 | lda rowbase 362 | sbc #NCOLS ; #$40 363 | sta rowbase 364 | lda rowbase+1 365 | sbc #$00 366 | sta rowbase+1 367 | jsr moveto 368 | donothing 369 | jmp editloop 370 | .) 371 | 372 | back 373 | .( 374 | lda col 375 | beq donothing 376 | dec col 377 | jsr moveto 378 | donothing 379 | jmp editloop 380 | .) 381 | 382 | forw 383 | .( 384 | lda col 385 | cmp #MAXCOL ; #$3F 386 | beq donothing 387 | inc col 388 | jsr moveto 389 | donothing 390 | jmp editloop 391 | .) 392 | 393 | tostart 394 | stz col 395 | jsr moveto 396 | jmp editloop 397 | 398 | toend 399 | .( 400 | ldy #$00 401 | endloop 402 | lda (rowbase),y 403 | beq atend 404 | iny 405 | cpy #MAXCOL ;#$3F 406 | beq atend 407 | bra endloop 408 | atend 409 | sty col 410 | jsr moveto 411 | jmp editloop 412 | .) 413 | 414 | delfwd 415 | .( 416 | ldy col 417 | delloop 418 | iny 419 | lda (rowbase),y 420 | dey 421 | sta (rowbase),y 422 | jsr puta 423 | beq done 424 | iny 425 | bra delloop 426 | done 427 | lda #$20 428 | jsr puta 429 | jsr moveto 430 | jmp editloop 431 | .) 432 | 433 | delback 434 | .( 435 | lda col 436 | beq donothing 437 | dec col 438 | jsr moveto 439 | jmp delfwd 440 | donothing 441 | jmp editloop 442 | .) 443 | 444 | insert 445 | pha 446 | ldy col 447 | lda (rowbase),y 448 | bne notatend 449 | inschar 450 | pla 451 | sta (rowbase),y 452 | jsr puta 453 | inc col 454 | jsr moveto 455 | rts 456 | 457 | notatend 458 | phy 459 | inc col 460 | jsr moveto 461 | dec col 462 | ply 463 | ;; move the rest of the line right by one character 464 | lda (rowbase),y 465 | insloop 466 | iny 467 | pha 468 | lda (rowbase),y 469 | tax 470 | pla 471 | sta (rowbase),y 472 | jsr puta 473 | txa 474 | bne insloop 475 | iny 476 | sta (rowbase),y 477 | jsr moveto 478 | ldy col 479 | bra inschar 480 | lda row 481 | cmp #MAXROW 482 | bne newline 483 | jmp editloop 484 | 485 | newline 486 | ldy col ; are we at the end of a line? 487 | lda (rowbase),y 488 | beq atend ; if yes 489 | jmp breakline ; if no 490 | 491 | atend 492 | .( 493 | clc ; reset rowbase to the new line 494 | lda rowbase 495 | adc #NCOLS 496 | sta rowbase 497 | bcc doneadd 498 | inc rowbase+1 499 | doneadd 500 | .) 501 | lda (rowbase) ; is this next line empty? 502 | bne movelines ; no, so move lines to insert a new one 503 | inc row ; yes, so move to it 504 | stz col 505 | jsr moveto 506 | jmp editloop 507 | 508 | movelines 509 | ;; move the rest of the text down by one line 510 | jsr rippledown 511 | 512 | ;; clear data out of this line 513 | ldy #MAXCOL 514 | lda #0 515 | .( 516 | clearloop 517 | sta (rowbase),y 518 | dey 519 | bne clearloop 520 | sta (rowbase) 521 | .) 522 | 523 | ;; now that the data is in the right place, repaint the screen 524 | ;; first, clear everything below the current row 525 | jsr clrtoend 526 | inc row ; we haven't done that yet 527 | jsr moveto 528 | 529 | ;; stash the row count 530 | lda row 531 | pha 532 | 533 | ;; now, paint rows that remain 534 | clc 535 | lda rowbase 536 | adc #NCOLS 537 | sta lower 538 | lda rowbase+1 539 | adc #$00 540 | sta lower+1 541 | stz col 542 | 543 | paintnext 544 | lda row 545 | inc 546 | cmp #MAXROW 547 | beq donerepaint 548 | sta row 549 | stz col 550 | jsr moveto 551 | jsr paintrow 552 | clc 553 | lda lower 554 | adc #NCOLS 555 | sta lower 556 | bcc paintnext 557 | inc lower+1 558 | bra paintnext 559 | 560 | donerepaint 561 | pla 562 | sta row 563 | jsr moveto 564 | 565 | finish 566 | jmp editloop 567 | 568 | breakline ;; TO BE IMPLEMENTED 569 | jmp editloop 570 | 571 | 572 | ;; output the text for one row, pointed to by lower. do it 573 | ;; directly for faster output without the subroutine call. 574 | paintrow 575 | .( 576 | phy 577 | ldy #0 578 | rdyloop 579 | lda ACIA_STATUS 580 | and #$10 581 | beq rdyloop 582 | lda (lower),y 583 | beq done 584 | sta ACIA_DATA 585 | iny 586 | cpy #MAXCOL 587 | beq done 588 | bra rdyloop 589 | done 590 | ply 591 | rts 592 | .) 593 | 594 | ;;; clear below and print from current row to the bottom of 595 | ;;; of the screen. (uses rowbase to point to line) 596 | paintdown 597 | .( 598 | lda rowbase 599 | sta lower 600 | lda rowbase+1 601 | sta lower+1 602 | lda row 603 | pha ; stash the row count 604 | lda col 605 | pha ; stash the column count 606 | stz col 607 | paintloop 608 | jsr moveto 609 | jsr clrtoend 610 | jsr paintrow 611 | lda row 612 | inc 613 | cmp #MAXROW 614 | beq endpaint 615 | sta row 616 | clc 617 | lda lower 618 | adc #NCOLS 619 | sta lower 620 | lda lower+1 621 | adc #0 622 | sta lower+1 623 | bra paintloop 624 | endpaint 625 | pla 626 | sta col 627 | pla 628 | sta row 629 | jsr moveto 630 | rts 631 | .) 632 | 633 | 634 | ;;; repaint the whole screen, saving and then restoring cursor position 635 | ;;; 636 | repaint 637 | lda row 638 | pha 639 | lda col 640 | pha 641 | lda rowbase 642 | pha 643 | lda rowbase+1 644 | pha 645 | stz row 646 | stz col 647 | lda #TEXTBASE 650 | sta rowbase+1 651 | jsr cls 652 | jsr home 653 | jsr paintdown 654 | pla 655 | sta rowbase+1 656 | pla 657 | sta rowbase 658 | pla 659 | sta col 660 | pla 661 | sta row 662 | jsr moveto 663 | jmp editloop 664 | 665 | 666 | ;;; open a new line 667 | openline 668 | .( 669 | ldy col 670 | bne midline 671 | jsr rippledown 672 | ldy #0 673 | lda #0 674 | clearloop 675 | sta (rowbase),y 676 | iny 677 | cpy #MAXCOL 678 | bne clearloop 679 | jsr paintdown 680 | jmp editloop 681 | 682 | midline 683 | ;; still to be implemented 684 | jmp editloop 685 | .) 686 | 687 | ;;; move lines down to open up a space. starts from the last line and 688 | ;;; works its way down to the current row (rowbase). 689 | rippledown 690 | .( 691 | ;; find the end of the text area by adding textsize to textbase 692 | clc 693 | lda #TEXTBASE 697 | adc #>TEXTSIZE 698 | sta upper+1 699 | 700 | ;; subtract one line length to get the last line in area 701 | sec 702 | lda upper 703 | sbc #NCOLS 704 | sta upper 705 | lda upper+1 706 | sbc #$00 707 | sta upper+1 708 | 709 | ;; is that the row we're on now? 710 | lda upper 711 | cmp rowbase 712 | bne continue 713 | lda upper+1 714 | cmp rowbase+1 715 | bne continue 716 | jmp finish ; yes so we are done 717 | 718 | continue 719 | ;; substract one more line length and store in lower 720 | sec 721 | lda upper 722 | sbc #$40 723 | sta lower 724 | lda upper+1 725 | sbc #$00 726 | sta lower+1 727 | 728 | ;; at this point, we have two pointers, lower and upper, 729 | ;; which point to two adjacent lines at the end of the buffer. 730 | ;; we want to reapeatedly copy the contents of lower into 731 | ;; upper. We do this backwards from the end of the buffer 732 | ;; so that we are preserving text as it ripples down. 733 | linecopy 734 | ldy #MAXCOL 735 | charcopy 736 | lda (lower),y 737 | sta (upper),y 738 | dey 739 | bne charcopy 740 | lda (lower) ; copy the last character 741 | sta (upper) 742 | 743 | sec ; lower line now becomes upper line 744 | lda lower ; and lower moves down by one line 745 | sta upper 746 | sbc #NCOLS 747 | sta lower 748 | lda lower+1 749 | sta upper+1 750 | sbc #$00 751 | sta lower+1 752 | 753 | lda upper ; stop when upper hits the new line we're at 754 | cmp rowbase 755 | bne linecopy 756 | lda upper+1 757 | cmp rowbase+1 758 | bne linecopy 759 | .) 760 | rts 761 | 762 | ;;; move lines up when one line is deleted. starts from rowbase (row 763 | ;;; being deleted) up to the end 764 | rippleup 765 | .( 766 | clc 767 | lda rowbase 768 | sta lower ; set lower to be same as rowbase 769 | adc #NCOLS ; and upper to be one row later 770 | sta upper 771 | lda rowbase+1 772 | sta lower+1 773 | adc #0 774 | sta upper+1 775 | 776 | clc ; calculate limit for copying 777 | lda #TEXTBASE 781 | adc #>TEXTSIZE 782 | sta jmpvec+1 783 | 784 | copyrow 785 | ldy #0 786 | charloop 787 | lda (upper),y 788 | sta (lower),y 789 | cpy #MAXCOL 790 | beq endofline 791 | iny 792 | bra charloop 793 | endofline 794 | 795 | clc ; move upper to lower, and increment upper 796 | lda upper ; by one row 797 | sta lower 798 | adc #NCOLS 799 | sta upper 800 | lda upper+1 801 | sta lower+1 802 | adc #0 803 | sta upper+1 804 | 805 | lda upper 806 | cmp jmpvec 807 | bne copyrow 808 | lda upper+1 809 | cmp jmpvec+1 810 | bne copyrow 811 | 812 | ;; now clear out that last line (now lower) 813 | ldy #0 814 | lda #0 815 | loop 816 | sta (lower),y 817 | cpy #MAXCOL 818 | beq done 819 | iny 820 | bra loop 821 | done 822 | .) 823 | rts 824 | 825 | 826 | ;;; delete line (^K) -- clears the line when there is text, and close 827 | ;;; up the line if it's empty. 828 | delline 829 | ldy col ; are we at the start of the line? 830 | bne midline ; no 831 | 832 | lda (rowbase),y ; is the line empty? 833 | beq closeline ; yes, so close it up 834 | 835 | ;; delete contents of this line (and erase with spaces) 836 | ldy #0 837 | .( 838 | clearloop 839 | lda (rowbase),y 840 | beq endofline 841 | lda #0 842 | sta (rowbase),y 843 | lda #32 844 | jsr puta 845 | cpy #MAXCOL 846 | beq endofline 847 | iny 848 | bra clearloop 849 | endofline 850 | jsr moveto 851 | jmp editloop 852 | .) 853 | 854 | closeline 855 | jsr rippleup 856 | jsr paintdown 857 | jmp editloop 858 | 859 | midline 860 | ;; still to be implemented 861 | jmp editloop 862 | 863 | 864 | ;; move to the bottom of the screen and quit via rts 865 | exit 866 | lda #$15 867 | sta row 868 | lda #$00 869 | sta col 870 | jsr moveto 871 | rts 872 | 873 | testcode 874 | jsr clrtoend 875 | jmp editloop 876 | 877 | readchar 878 | lda ACIA_STATUS 879 | and #$08 880 | beq readchar 881 | lda ACIA_DATA 882 | rts 883 | 884 | undefined 885 | lda #$07 ; BEL (but it doesn't do anything) 886 | jsr puta 887 | jmp editloop 888 | 889 | -------------------------------------------------------------------------------- /forth/core.fs: -------------------------------------------------------------------------------- 1 | 32 constant bl 2 | 3 | : space bl emit ; 4 | : spaces 0 do space loop ; 5 | : clear 74 50 91 27 emit emit emit emit ; 6 | : home 72 91 27 emit emit emit ; 7 | : page clear home ; 8 | 9 | : numemit 10 | dup 10 < if 11 | 48 + emit 12 | else 13 | 10 /mod 14 | 48 + emit 48 + emit 15 | then ; 16 | 17 | : at-xy \ ESC [ line ; column H ; 18 | 27 emit 91 emit swap numemit 59 emit numemit 72 emit ; 19 | 20 | ( ports and direction registers on the 6522 VIA ) 21 | 32768 constant portb 22 | 32769 constant porta 23 | 32770 constant ddrb 24 | 32771 constant ddra 25 | 26 | 1024 constant b/buf 27 | 1024 constant b/scr 28 | 29 | : >body 2+ ; 30 | : buffer: create allot ; \ is this one right? 31 | : copy swap block swap buffer b/buf cmove update ; 32 | : cell+ 2+ ; 33 | : char+ 1+ ; 34 | : chars ; 35 | : align ; 36 | : d>s swap drop ; 37 | : 0< 0 < ; 38 | : 0> 0 > ; 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /forth/dump.fs: -------------------------------------------------------------------------------- 1 | 2 | : hexchar s" 0123456789ABCDEF " drop + 1 type ; 3 | 4 | : hexbyte dup 240 and 4 rshift hexchar 15 and hexchar ; 5 | 6 | : charordot ( c -- ) 7 | dup dup 32 < swap 127 = or if drop 46 emit else emit then ; 8 | 9 | : charform ( u -- ) 10 | dup 16 + swap do i c@ charordot loop ; 11 | 12 | : hex16 ( u -- ) 13 | dup 255 8 lshift and 8 rshift hexbyte 255 and hexbyte ; 14 | 15 | : lefthex ( u -- ) 16 | dup 8 + swap do i c@ hexbyte space loop ; 17 | 18 | : righthex ( u -- ) 19 | dup 16 + swap 8 + do i c@ hexbyte space loop ; 20 | 21 | : hexform dup lefthex space righthex ; 22 | 23 | : address ( u -- ) 24 | hex16 2 spaces ; 25 | 26 | : line dup address dup hexform 3 spaces charform cr ; 27 | 28 | : dump ( addr count -- ) 29 | cr 1 pick + swap do i line 16 +loop ; 30 | 31 | -------------------------------------------------------------------------------- /forth/fib.fs: -------------------------------------------------------------------------------- 1 | : fib1 ( n1 -- n2 ) 2 | dup 2 < if drop 1 exit then 3 | dup 1- recurse 4 | swap 2- recurse + ; 5 | 6 | \ how deep do the stacks need to be? 7 | : fib1-bench 1000 0 do i fib1 drop loop ; 8 | 9 | : fib2 ( n1 -- n2 ) 10 | 0 1 rot 0 do over + swap loop drop ; 11 | 12 | : fib2-bench 1000 0 do i fib2 drop loop ; 13 | 14 | -------------------------------------------------------------------------------- /forth/life.fs: -------------------------------------------------------------------------------- 1 | 2 | \ conway's life in Forth 3 | \ Written to avoid as many arithmetic operations as possible 4 | \ and using purely textual output 5 | 6 | 7 | 24 constant width 8 | 24 constant height 9 | 10 | variable board1 width height * allot 11 | variable board2 width height * allot 12 | 13 | variable fromboard 14 | variable toboard 15 | 16 | : by24 4 lshift dup 1 rshift + ; 17 | 18 | : swap-boards 19 | toboard @ 20 | fromboard @ toboard ! 21 | fromboard ! ; 22 | 23 | : xytocount ( x y -- n ) 24 | by24 + ; 25 | 26 | : setzero ( board x y ) 27 | xytocount + 0 swap c! ; 28 | 29 | : setone ( board x y ) 30 | xytocount + 1 swap c! ; 31 | 32 | : flookup ( board x y -- value ) 33 | by24 + + c@ ; 34 | 35 | : addglider ( board -- ) 36 | dup 2 4 setone 37 | dup 3 4 setone 38 | dup 4 4 setone 39 | dup 4 3 setone 40 | 3 2 setone ; 41 | 42 | : twogliders ( board -- ) 43 | dup 2 4 setone 44 | dup 3 4 setone 45 | dup 4 4 setone 46 | dup 4 3 setone 47 | dup 3 2 setone 48 | 49 | dup 12 14 setone 50 | dup 13 14 setone 51 | dup 14 14 setone 52 | dup 14 13 setone 53 | 13 12 setone ; 54 | 55 | 56 | : neighbors ( n -- count ) 57 | dup fromboard @ + c@ swap 58 | 1+ dup fromboard @ + c@ swap 59 | 1+ dup fromboard @ + c@ swap 60 | width + dup fromboard @ + c@ swap 61 | width + dup fromboard @ + c@ swap 62 | 1- dup fromboard @ + c@ swap 63 | 1- dup fromboard @ + c@ swap 64 | width - fromboard @ + c@ 65 | + + + + + + + ; 66 | 67 | : checkvalid ( n -- f ) 68 | width mod width 1- 1- < ; 69 | 70 | : process-board 71 | height 2 - width 2 - * 0 do 72 | i checkvalid if 73 | i width + 1+ 74 | \ dup i . . cr 75 | dup fromboard @ + c@ if 76 | i neighbors 77 | \ live cell, and dest offset is on the stack 78 | dup 2 < if 79 | drop \ drop the neighbor count 80 | toboard @ + 0 swap c! \ dies of loneliness 81 | else 82 | 3 > if 83 | toboard @ + 0 swap c! \ dies of overcrowding 84 | else 85 | toboard @ + 1 swap c! \ continues 86 | then 87 | then 88 | else 89 | \ dead cell, and dest offset is on the stack 90 | i neighbors 3 = if 91 | toboard @ + 1 swap c! \ born 92 | else 93 | toboard @ + 0 swap c! \ continues 94 | then 95 | then 96 | then 97 | loop ; 98 | 99 | 100 | : print ( board -- ) 101 | height 0 do 102 | width 0 do 103 | dup i j flookup 0= if 104 | 46 emit 105 | else 106 | 42 emit 107 | then 108 | loop 109 | cr 110 | loop 111 | drop ; 112 | 113 | : life-reset 114 | board1 width height * 0 fill 115 | board2 width height * 0 fill 116 | board1 fromboard ! 117 | board2 toboard ! 118 | board1 twogliders ; 119 | 120 | life-reset 121 | 122 | : gen process-board page toboard @ print swap-boards ; 123 | 124 | : 20cycle 125 | 20 0 do gen loop ; 126 | 127 | : 20key 128 | 20 0 do gen ." press a key (q to quit) " key 113 = if leave then loop ; 129 | 130 | -------------------------------------------------------------------------------- /forth/life.slow.fs: -------------------------------------------------------------------------------- 1 | 2 | 24 constant width 3 | 24 constant height 4 | 5 | variable board1 width height * allot 6 | variable board2 width height * allot 7 | 8 | variable fromboard 9 | variable toboard 10 | 11 | : by24 4 lshift dup 1 rshift + ; 12 | 13 | : swap-boards 14 | toboard @ 15 | fromboard @ toboard ! 16 | fromboard ! ; 17 | 18 | : north-coords ( x1 y1 -- x2 y2 ) 19 | 1- ; 20 | 21 | : south-coords 22 | 1+ ; 23 | 24 | : east-coords 25 | swap 1+ swap ; 26 | 27 | : west-coords 28 | swap 1- swap ; 29 | 30 | : ne-coords 31 | north-coords east-coords ; 32 | 33 | : sw-coords 34 | south-coords west-coords ; 35 | 36 | : se-coords 37 | south-coords east-coords ; 38 | 39 | : nw-coords 40 | north-coords west-coords ; 41 | 42 | : xytocount ( x y -- n ) 43 | width * + ; 44 | 45 | : lookup ( board x y -- value ) 46 | xytocount + c@ ; 47 | 48 | : setzero ( board x y ) 49 | xytocount + 0 swap c! ; 50 | 51 | : setone ( board x y ) 52 | xytocount + 1 swap c! ; 53 | 54 | : flookup ( board x y -- value ) 55 | by24 + + c@ ; 56 | 57 | : count-north 58 | north-coords lookup ; 59 | : count-south 60 | south-coords lookup ; 61 | : count-west 62 | west-coords lookup ; 63 | : count-east 64 | east-coords lookup ; 65 | 66 | : count-ne 67 | ne-coords lookup ; 68 | 69 | : count-se 70 | se-coords lookup ; 71 | 72 | : count-sw 73 | sw-coords lookup ; 74 | 75 | : count-nw 76 | nw-coords lookup ; 77 | 78 | 79 | : neighbors ( board x y -- count ) 80 | 2dup 4 pick rot rot count-north 81 | 3 pick 3 pick 3 pick count-south 82 | 4 pick 4 pick 4 pick count-east 83 | 5 pick 5 pick 5 pick count-west 84 | 6 pick 6 pick 6 pick count-nw 85 | 7 pick 7 pick 7 pick count-ne 86 | 8 pick 8 pick 8 pick count-sw 87 | 9 pick 9 pick 9 pick count-se 88 | + + + + + + + 89 | swap drop swap drop swap drop ; 90 | 91 | : fneighbors ( x y -- count) 92 | 1- swap 1- swap \ calculate NW point 93 | by24 + \ convert coords to an offset 94 | dup fromboard @ + c@ swap \ fetch data, place under dup'd location 95 | 1+ dup fromboard @ + c@ swap \ same with N point 96 | 1+ dup fromboard @ + c@ swap \ then NE point 97 | width + dup fromboard @ + c@ swap \ then E point 98 | width + dup fromboard @ + c@ swap \ then SE point 99 | 1- dup fromboard @ + c@ swap \ then S point 100 | 1- dup fromboard @ + c@ swap \ then SW point 101 | width - fromboard @ + c@ \ finally, W point 102 | + + + + + + + ; 103 | 104 | 105 | : addglider ( board -- ) 106 | dup 2 4 setone 107 | dup 3 4 setone 108 | dup 4 4 setone 109 | dup 4 3 setone 110 | 3 2 setone ; 111 | 112 | : fprocess 113 | height 1- 1 do 114 | width 1- 1 do 115 | fromboard @ i j flookup 1 = if 116 | \ live cell 117 | i j fneighbors 118 | dup 2 < if 119 | toboard @ i j setzero \ dies of loneliness 120 | drop 121 | else 122 | 3 > if 123 | toboard @ i j setzero \ dies of overcrowding 124 | else 125 | toboard @ i j setone \ continues 126 | then 127 | then 128 | else 129 | \ dead cell 130 | i j fneighbors 3 = if 131 | toboard @ i j setone \ born 132 | else 133 | toboard @ i j setzero \ continues 134 | then 135 | then 136 | loop 137 | loop ; 138 | 139 | 140 | : process-board 141 | height 1- 1 do 142 | width 1- 1 do 143 | fromboard @ i j lookup 1 = if 144 | \ live cell 145 | fromboard @ i j neighbors 146 | dup 2 < if 147 | toboard @ i j setzero \ dies of loneliness 148 | drop 149 | else 150 | 3 > if 151 | toboard @ i j setzero \ dies of overcrowding 152 | else 153 | toboard @ i j setone \ continues 154 | then 155 | then 156 | else 157 | \ dead cell 158 | fromboard @ i j neighbors 3 = if 159 | toboard @ i j setone \ born 160 | else 161 | toboard @ i j setzero \ continues 162 | then 163 | then 164 | loop 165 | loop ; 166 | 167 | 168 | 169 | : print ( board -- ) 170 | height 0 do 171 | width 0 do 172 | dup i j lookup 0= if 173 | 46 emit 174 | else 175 | 42 emit 176 | then 177 | loop 178 | cr 179 | loop 180 | drop ; 181 | 182 | : life-reset 183 | board1 width height * 0 fill 184 | board2 width height * 0 fill 185 | board1 fromboard ! 186 | board2 toboard ! 187 | board1 addglider ; 188 | 189 | life-reset 190 | 191 | : fgen fprocess page toboard @ print swap-boards ; 192 | 193 | : gen process-board page toboard @ print swap-boards ; 194 | 195 | : 20gens 20 0 do gen ." press a key " key drop loop ; 196 | 197 | : 15gens 15 0 do gen loop ; 198 | 199 | : 20fgen 20 0 do gen ." press a key (q to quit) " key 113 = if leave then loop ; 200 | 201 | -------------------------------------------------------------------------------- /forth/mandelbrot.fs: -------------------------------------------------------------------------------- 1 | \ Setup constants to remove magic numbers to allow 2 | \ for greater zoom with different scale factors. 3 | 20 CONSTANT MAXITER 4 | -39 CONSTANT MINVAL 5 | 40 CONSTANT MAXVAL 6 | 20 5 lshift CONSTANT RESCALE 7 | RESCALE 4 * CONSTANT S_ESCAPE 8 | 9 | \ These variables hold values during the escape calculation. 10 | VARIABLE CREAL 11 | VARIABLE CIMAG 12 | VARIABLE ZREAL 13 | VARIABLE ZIMAG 14 | VARIABLE COUNT 15 | 16 | \ Compute squares, but rescale to remove extra scaling factor. 17 | : ZR_SQ ZREAL @ DUP RESCALE */ ; 18 | : ZI_SQ ZIMAG @ DUP RESCALE */ ; 19 | 20 | \ Translate escape count to ascii greyscale. 21 | : .CHAR 22 | S" ..,'~!^:;[/<&?oxOX# " 23 | DROP + 1 24 | TYPE ; 25 | 26 | \ Numbers above 4 will always escape, so compare to a scaled value. 27 | : ESCAPES? 28 | S_ESCAPE > ; 29 | 30 | \ Increment count and compare to max iterations. 31 | : COUNT_AND_TEST? 32 | COUNT @ 1+ DUP COUNT ! 33 | MAXITER > ; 34 | 35 | \ stores the row column values from the stack for the escape calculation. 36 | : INIT_VARS 37 | 5 lshift DUP CREAL ! ZREAL ! 38 | 5 lshift DUP CIMAG ! ZIMAG ! 39 | 1 COUNT ! ; 40 | 41 | \ Performs a single iteration of the escape calculation. 42 | : DOESCAPE 43 | ZR_SQ ZI_SQ 2DUP + 44 | ESCAPES? IF 45 | 2DROP 46 | TRUE 47 | ELSE 48 | - CREAL @ + \ leave result on stack 49 | ZREAL @ ZIMAG @ RESCALE */ 1 lshift 50 | CIMAG @ + ZIMAG ! 51 | ZREAL ! \ Store stack item into ZREAL 52 | COUNT_AND_TEST? 53 | THEN ; 54 | 55 | \ Iterates on a single cell to compute its escape factor. 56 | : DOCELL 57 | INIT_VARS 58 | BEGIN 59 | DOESCAPE 60 | UNTIL 61 | COUNT @ 62 | .CHAR ; 63 | 64 | \ For each cell in a row. 65 | : DOROW 66 | MAXVAL MINVAL DO 67 | DUP I 68 | DOCELL 69 | LOOP 70 | DROP ; 71 | 72 | \ For each row in the set. 73 | : MANDELBROT 74 | CR 75 | MAXVAL MINVAL DO 76 | I DOROW CR 77 | LOOP ; 78 | 79 | \ Run the computation. 80 | MANDELBROT -------------------------------------------------------------------------------- /forth/mandelbrot2.fs: -------------------------------------------------------------------------------- 1 | \ setup constants to remove magic numbers to allow 2 | \ for greater zoom with different scale factors. 3 | 20 constant maxiter 4 | -39 constant minval 5 | 40 constant maxval 6 | 20 5 lshift constant rescale 7 | rescale 4 * constant s_escape 8 | 9 | \ these variables hold values during the escape calculation. 10 | variable creal 11 | variable cimag 12 | variable zreal 13 | variable zimag 14 | variable count 15 | 16 | \ compute squares, but rescale to remove extra scaling factor. 17 | : zr_sq zreal @ dup rescale */ ; 18 | : zi_sq zimag @ dup rescale */ ; 19 | 20 | \ translate escape count to ascii greyscale. 21 | : .char 22 | s" ..,'~!^:;[/<&?oxox# " 23 | drop + 1 24 | type ; 25 | 26 | \ numbers above 4 will always escape, so compare to a scaled value. 27 | : escapes? 28 | s_escape > ; 29 | 30 | \ increment count and compare to max iterations. 31 | : count_and_test? 32 | count @ 1+ dup count ! 33 | maxiter > ; 34 | 35 | \ stores the row column values from the stack for the escape calculation. 36 | : init_vars 37 | 5 lshift dup creal ! zreal ! 38 | 5 lshift dup cimag ! zimag ! 39 | 1 count ! ; 40 | 41 | \ performs a single iteration of the escape calculation. 42 | : doescape 43 | zr_sq zi_sq 2dup + 44 | escapes? if 45 | 2drop 46 | true 47 | else 48 | - creal @ + \ leave result on stack 49 | zreal @ zimag @ rescale */ 1 lshift 50 | cimag @ + zimag ! 51 | zreal ! \ store stack item into zreal 52 | count_and_test? 53 | then ; 54 | 55 | \ iterates on a single cell to compute its escape factor. 56 | : docell 57 | init_vars 58 | begin 59 | doescape 60 | until 61 | count @ 62 | .char ; 63 | 64 | \ for each cell in a row. 65 | : dorow 66 | maxval minval do 67 | dup i 68 | docell 69 | loop 70 | drop ; 71 | 72 | \ for each row in the set. 73 | : mandelbrot 74 | cr 75 | maxval minval do 76 | i dorow cr 77 | loop ; 78 | 79 | \ run the computation. 80 | mandelbrot -------------------------------------------------------------------------------- /forth/nqueens.fs: -------------------------------------------------------------------------------- 1 | variable solutions 2 | variable nodes 3 | 4 | : bits ( n -- mask ) 1 swap lshift 1- ; 5 | : lowBit ( mask -- bit ) dup negate and ; 6 | : lowBit- ( mask -- bits ) dup 1- and ; 7 | 8 | : next3 ( dl dr f files -- dl dr f dl' dr' f' ) 9 | invert >r 10 | 2 pick r@ and 2* 1+ 11 | 2 pick r@ and 2/ 12 | 2 pick r> and ; 13 | 14 | : try ( dl dr f -- ) 15 | dup if 16 | 1 nodes +! 17 | dup 2over and and 18 | begin ?dup while 19 | dup >r lowBit next3 recurse r> lowBit- 20 | repeat 21 | else 1 solutions +! then 22 | drop 2drop ; 23 | 24 | : queens ( n -- ) 25 | 0 solutions ! 0 nodes ! 26 | -1 -1 rot bits try 27 | solutions @ . ." solutions, " nodes @ . ." nodes" ; 28 | 29 | 8 queens \ 92 solutions, 1965 nodes 30 | -------------------------------------------------------------------------------- /forth/rect.fs: -------------------------------------------------------------------------------- 1 | : rect ( x y width height -- ) 2 | 2swap 2dup 3 | 4 pick + swap 5 pick + 2swap 4 | dup 4 pick 1+ swap do 5 | 1 pick i at-xy 42 emit 6 | 2 pick i at-xy 42 emit 7 | loop 8 | 2 pick 1+ 2 pick do 9 | dup i swap at-xy 42 emit 10 | i 4 pick at-xy 42 emit 11 | loop 12 | 2drop 2drop 2drop 13 | ; 14 | -------------------------------------------------------------------------------- /forth/sieve.fs: -------------------------------------------------------------------------------- 1 | 8191 constant size 2 | variable flags size allot \ make array with size bytes 3 | 4 | : primes 5 | flags size 1+ 1 fill 6 | 0 7 | size 0 do 8 | flags i + c@ if 9 | i dup + 3 + dup i + 10 | begin 11 | dup size > invert while 12 | 0 over flags + c! 13 | over + 14 | repeat 15 | drop 16 | . 1+ 17 | then 18 | loop ." total: " . ; 19 | 20 | : qprimes 21 | flags size 1+ 1 fill 22 | 0 23 | size 0 do 24 | flags i + c@ if 25 | i dup + 3 + dup i + 26 | begin 27 | dup size > invert while 28 | 0 over flags + c! 29 | over + 30 | repeat 31 | drop drop 1+ 32 | then 33 | loop ." total: " . ; 34 | 35 | -------------------------------------------------------------------------------- /forth/twice.fs: -------------------------------------------------------------------------------- 1 | : twice dup + ; 2 | -------------------------------------------------------------------------------- /iorom.a65: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; I/O support for the Mite -- video, keyboard, serial 3 | ;;; 4 | ;;; These are shared routines for use primarily by FORTH but also by 5 | ;;; anything else; some functions will be included in the main jump 6 | ;;; table. FORTH is too large to include these in the top 16K but I 7 | ;;; have a full 28K available, so there is plenty of space for these 8 | ;;; elsewhere. I'm putting them at $9000 which is the base of the ROM. 9 | ;;; 10 | ;;; Video is an RA8875 board controlled via SPI, bit-banged through 11 | ;;; a VIA at $8010. 12 | ;;; 13 | ;;; Keyboard input comes from an ATtiny26 decoder connected to the 14 | ;;; system VIA at $8000. 15 | ;;; 16 | ;;; Serial is the system 6551 ACIA at $8800. 17 | ;;; 18 | ;;; Paul Dourish, July 2021 19 | ;;; 20 | 21 | 22 | ;;; If the ROM symbol isn't defined, this may just be being included 23 | ;;; in a file to run out of RAM and so don't reset the origin. 24 | 25 | #ifdef ROM 26 | * = $9000 27 | #include "../mitemon/decl.a65" 28 | #endif 29 | 30 | ;;; definitions here borrowed from elsewhere. They should really be 31 | ;;; included from a standard place. 32 | #ifndef SCRATCH 33 | #define SCRATCH $0010 34 | ;SCRATCH = $0010 ; through to $001F (adopted from monitor) 35 | #endif 36 | #ifndef VROW 37 | VROW = $000A 38 | VCOL = $000B 39 | #endif 40 | 41 | ;;; VIA registers 42 | ;;; 43 | UVIA_PORTB = $8010 44 | UVIA_PORTA = $8011 45 | UVIA_DDRB = $8012 46 | UVIA_DDRA = $8013 47 | SPI_PORT = UVIA_PORTB 48 | 49 | 50 | ;; Command/Data codes for SPI 51 | DATAWRITE=$00 52 | DATAREAD=$40 53 | CMDWRITE=$80 54 | CMDREAD =$C0 55 | 56 | ;;; 57 | ;;; Include standard startup code 58 | ;;; 59 | 60 | ;;; also include all the RA8875-specific definitions 61 | #include "../mitemon/apps/spivdefs.a65" 62 | 63 | #include "../mitemon/apps/delay.a65" 64 | 65 | 66 | ;;; 67 | ;;; Low-level SPI code 68 | ;;; 69 | ;;; 70 | 71 | ;;; 72 | ;;; Wiring details: 73 | ;;; CLK is PB0, ie 1 74 | ;;; MOSI is PB1, ie 2 75 | ;;; CS is PB2, ie 4 76 | ;;; MISO is PB7, which maps onto S flag on BIT (test with BPL and BMI) 77 | ;;; MISO, MOSI, and CS all have pull-up resisters, so they are high in 78 | ;;; the idle/unused state, except when pulled low by active circuitry. 79 | ;;; 80 | ;;; For the moment, this is the same setup as the SD card reader. 81 | ;;; Since I want to be able to set things up for keyboard input on 82 | ;;; on the same port, I'm likely to want to move some of the lines 83 | ;;; around later. However, for now, I wannt to use validated code. 84 | ;;; 85 | ;;; Other bits: 86 | ;;; BACKLIGHT PB3, ie 8 87 | ;;; BUSY PB4, ie 16 88 | ;;; RESET PB5, ie 32 89 | ;;; 90 | ;;; Device is SPI Mode 0. This means: 91 | ;;; clock idles low 92 | ;;; clock active high 93 | ;;; data read on rising edge 94 | 95 | SPI_CLK = 1 96 | SPI_MOSI = 2 97 | SPI_CS = 4 98 | LIGHT = 8 99 | SPI_MISO = 128 100 | BUSYMASK = 16 101 | RESET = 32 102 | 103 | ;;; set up data direction for SPI_PORT -- bits 0, 1, 2, 3, and 5 are 104 | ;;; outputs and bits 4, 6 (NC), and 7 are inputs. 105 | vidconf6522 106 | lda #$2f 107 | sta UVIA_DDRB 108 | lda #SPI_MOSI|RESET|SPI_CS 109 | sta SPI_PORT 110 | rts 111 | 112 | 113 | ;;; Send a byte via SPI. This faster version of the original code 114 | ;;; unrolls the loop and relies on shifts rather than branches to 115 | ;;; determine the bit to send. This is written on the assumption 116 | ;;; that the CLK signal idles low. 117 | ;;; 118 | vsendbyte 119 | .( 120 | phx 121 | phy 122 | ldy #SPI_MOSI|RESET ; constant -- clk 0, mosi 1. 123 | ldx #RESET ; another constant -- clk 0, mosi 0, reset high 124 | 125 | asl ; top bit of a into carry 126 | bcs bit7_1 127 | stx SPI_PORT ; set ck 0, mosi 0 128 | inc SPI_PORT ; then clk 1 129 | bra bit6 130 | 131 | bit7_1 132 | sty SPI_PORT ; updates both ck and mosi 133 | inc SPI_PORT ; set clock 134 | 135 | bit6 136 | asl 137 | bcs bit6_1 138 | 139 | stx SPI_PORT ; set ck 0, mosi 0 140 | inc SPI_PORT ; then clk 1 141 | bra bit5 142 | 143 | bit6_1 144 | sty SPI_PORT ; updates both ck and mosi 145 | inc SPI_PORT ; set clock 146 | 147 | bit5 148 | asl 149 | bcs bit5_1 150 | 151 | stx SPI_PORT ; set ck 0, mosi 0 152 | inc SPI_PORT ; then clk 1 153 | bra bit4 154 | 155 | bit5_1 156 | sty SPI_PORT ; updates both ck and mosi 157 | inc SPI_PORT ; set clock 158 | 159 | bit4 160 | asl 161 | bcs bit4_1 162 | 163 | stx SPI_PORT ; set ck 0, mosi 0 164 | inc SPI_PORT ; then clk 1 165 | bra bit3 166 | 167 | bit4_1 168 | sty SPI_PORT ; updates both ck and mosi 169 | inc SPI_PORT ; set clock 170 | 171 | bit3 172 | asl 173 | bcs bit3_1 174 | 175 | stx SPI_PORT ; set ck 0, mosi 0 176 | inc SPI_PORT ; then clk 1 177 | bra bit2 178 | 179 | bit3_1 180 | sty SPI_PORT ; updates both ck and mosi 181 | inc SPI_PORT ; set clock 182 | 183 | bit2 184 | asl 185 | bcs bit2_1 186 | 187 | stx SPI_PORT ; set ck 0, mosi 0 188 | inc SPI_PORT ; then clk 1 189 | bra bit1 190 | 191 | bit2_1 192 | sty SPI_PORT ; updates both ck and mosi 193 | inc SPI_PORT ; set clock 194 | 195 | bit1 196 | asl 197 | bcs bit1_1 198 | 199 | stx SPI_PORT ; set ck 0, mosi 0 200 | inc SPI_PORT ; then clk 1 201 | bra bit0 202 | 203 | bit1_1 204 | sty SPI_PORT ; updates both ck and mosi 205 | inc SPI_PORT ; set clock 206 | 207 | bit0 208 | asl 209 | bcs bit0_1 210 | 211 | stx SPI_PORT ; set ck 0, mosi 0 212 | inc SPI_PORT ; then clk 1 213 | bra sent 214 | 215 | bit0_1 216 | sty SPI_PORT ; updates both ck and mosi 217 | inc SPI_PORT ; set clock 218 | 219 | sent 220 | sty SPI_PORT ; leave clk low, MOSI high 221 | ply 222 | plx 223 | rts 224 | .) 225 | 226 | 227 | 228 | ;;; read a byte via SPI from SPI_PORT, returned in accumulator. 229 | ;;; Assume the CLK idles low. 230 | vrecv8bits 231 | .( 232 | phy 233 | ldy #RESET 234 | 235 | bit7 236 | sty SPI_PORT ; clk low, mosi low, reset high 237 | inc SPI_PORT ; sets clock but also reads data into N 238 | bpl bit7_0 239 | 240 | sec 241 | rol 242 | bra bit6 243 | 244 | bit7_0 245 | asl 246 | 247 | bit6 248 | sty SPI_PORT 249 | inc SPI_PORT ; sets clock but also reads data into N 250 | bpl bit6_0 251 | 252 | sec 253 | rol 254 | bra bit5 255 | 256 | bit6_0 257 | asl 258 | 259 | bit5 260 | sty SPI_PORT 261 | inc SPI_PORT ; sets clock but also reads data into N 262 | bpl bit5_0 263 | 264 | sec 265 | rol 266 | bra bit4 267 | 268 | bit5_0 269 | asl 270 | 271 | bit4 272 | sty SPI_PORT 273 | inc SPI_PORT ; sets clock but also reads data into N 274 | bpl bit4_0 275 | 276 | sec 277 | rol 278 | bra bit3 279 | 280 | bit4_0 281 | asl 282 | 283 | bit3 284 | sty SPI_PORT 285 | inc SPI_PORT ; sets clock but also reads data into N 286 | bpl bit3_0 287 | 288 | sec 289 | rol 290 | bra bit2 291 | 292 | bit3_0 293 | asl 294 | 295 | bit2 296 | sty SPI_PORT 297 | inc SPI_PORT ; sets clock but also reads data into N 298 | bpl bit2_0 299 | 300 | sec 301 | rol 302 | bra bit1 303 | 304 | bit2_0 305 | asl 306 | 307 | bit1 308 | sty SPI_PORT 309 | inc SPI_PORT ; sets clock but also reads data into N 310 | bpl bit1_0 311 | 312 | sec 313 | rol 314 | bra bit0 315 | 316 | bit1_0 317 | asl 318 | 319 | bit0 320 | sty SPI_PORT 321 | inc SPI_PORT ; sets clock but also reads data into N 322 | bpl bit0_0 323 | 324 | sec 325 | rol 326 | bra endread 327 | 328 | bit0_0 329 | asl 330 | 331 | endread 332 | dec SPI_PORT 333 | ply 334 | rts 335 | .) 336 | 337 | 338 | ;;; 339 | ;;; Read and set RA8875 registers 340 | ;;; 341 | ;;; 342 | 343 | wrcommand 344 | pha ; cache value 345 | 346 | lda #RESET ; everything low except RESET 347 | sta SPI_PORT 348 | 349 | lda #CMDWRITE ; send CMDWRITE 350 | jsr vsendbyte 351 | pla ; retreive value 352 | jsr vsendbyte ; send it 353 | 354 | lda #SPI_MOSI|SPI_CS|RESET 355 | sta SPI_PORT 356 | rts 357 | 358 | ;rdcommand 359 | ; lda #SPI_CS ; set CS low 360 | ; trb SPI_PORT 361 | ; 362 | ; ;; send CMDREAD 363 | ; lda #CMDREAD ; send CMDREAD 364 | ; jsr sendbyte 365 | ; jsr getresponse ; receive data into A 366 | ; 367 | ; pha ; cache it temporarily 368 | ; lda #SPI_CS ; set CS high 369 | ; tsb SPI_PORT 370 | ; pla ; retrieve data 371 | ; rts 372 | 373 | sendvdata 374 | wrdata 375 | pha 376 | ; ;; set CS low 377 | ; lda #SPI_CS 378 | ; trb SPI_PORT 379 | lda #RESET ; everything low except RESET 380 | ;; send DATAWRITE 381 | lda #DATAWRITE 382 | jsr vsendbyte 383 | pla 384 | ;; send A 385 | jsr vsendbyte 386 | ; ;; set MOSI high 387 | ; lda #SPI_MOSI 388 | ; tsb SPI_PORT 389 | ; ;; set CS high 390 | ; lda #SPI_CS 391 | ; tsb SPI_PORT 392 | lda #SPI_MOSI|SPI_CS|RESET ; CS, MOSI, RESET high 393 | sta SPI_PORT 394 | rts 395 | 396 | rddata 397 | ; lda #SPI_CS ; set CS low 398 | ; trb SPI_PORT 399 | lda #RESET 400 | sta SPI_PORT ; RESET high, everything else low 401 | 402 | lda #DATAREAD ; send DATAREAD 403 | jsr vsendbyte 404 | 405 | ; lda #SPI_MOSI ; keep MOSI low while awaiting response 406 | ; trb SPI_PORT 407 | lda #RESET 408 | sta SPI_PORT ; RESET high, everything else low 409 | 410 | jsr vrecv8bits ; get response into A 411 | pha ; cache it for a moment 412 | 413 | ; lda #SPI_MOSI ; set MOSI high 414 | ; tsb SPI_PORT 415 | ; lda #SPI_CS ; set CS high 416 | ; tsb SPI_PORT 417 | lda #SPI_MOSI|SPI_CS|RESET 418 | sta SPI_PORT 419 | 420 | pla ; retreive data 421 | rts 422 | 423 | ;; write value in Y to register in A 424 | writevreg 425 | writereg 426 | jsr wrcommand 427 | tya 428 | jsr wrdata 429 | rts 430 | 431 | readvreg 432 | readreg 433 | jsr wrcommand 434 | jsr rddata 435 | rts 436 | 437 | 438 | 439 | ;;; 440 | ;;; Control RA8875 functions 441 | ;;; 442 | ;;; 443 | 444 | ;;; Initialize video processor 445 | ;;; 446 | vidinit 447 | ;; initial setup -- CLOCK high, MOSI high, RESET high, CS high 448 | lda #SPI_CLK|SPI_MOSI|RESET|SPI_CS 449 | sta SPI_PORT 450 | 451 | ;; for reset -- hold RESET, CLK, and MOSI all low 452 | ;; that's basically everything except MISO, right? 453 | lda #SPI_MISO 454 | sta SPI_PORT 455 | ;; short pause 456 | jsr delay100ms 457 | ;; set RESET, CLK, MOSI and CS all high 458 | lda #RESET|SPI_CLK|SPI_MOSI|SPI_CS 459 | sta SPI_PORT 460 | jsr delay100ms 461 | 462 | ;; now set chip select low (and leave it there) 463 | lda #RESET|SPI_CLK|SPI_MOSI 464 | sta SPI_PORT 465 | 466 | 467 | ;; check things are okay -- read status register and confirm value 468 | lda #0 469 | jsr wrcommand 470 | jsr rddata 471 | cmp #$75 472 | beq endvidinit 473 | fail 474 | ; jsr putax 475 | ; lda #failstr 478 | ; sta PRINTVEC+1 479 | ; jsr printvecstr 480 | endvidinit 481 | rts 482 | 483 | ;;; Initialize registers to default settings 484 | ;;; 485 | reginit 486 | lda #PLLC1 487 | ldy #PLLC1_PLLDIV1+11 488 | jsr writereg 489 | jsr delay1ms 490 | 491 | lda #PLLC2 492 | ldy #PLLC2_DIV4 493 | jsr writereg 494 | jsr delay1ms 495 | 496 | lda #SYSR 497 | ldy #SYSR_16BPP|SYSR_MCU8 498 | jsr writereg 499 | jsr delay1ms 500 | 501 | lda #PCSR 502 | ldy #PCSR_PDATL|PCSR_2CLK 503 | jsr writereg 504 | jsr delay1ms 505 | 506 | lda #HDWR 507 | ldy #99 508 | jsr writereg 509 | jsr delay1ms 510 | 511 | lda #HNDFTR 512 | ldy #HNDFTR_DE_HIGH 513 | jsr writereg 514 | jsr delay1ms 515 | 516 | lda #HNDR 517 | ldy #3 518 | jsr writereg 519 | jsr delay1ms 520 | 521 | lda #HSTR 522 | ldy #3 523 | jsr writereg 524 | jsr delay1ms 525 | 526 | lda #HPWR 527 | ldy #HPWR_LOW+11 528 | jsr writereg 529 | jsr delay1ms 530 | 531 | ;; vertical settings registers 532 | lda #VDHR0 533 | ldy #<479 534 | jsr writereg 535 | jsr delay1ms 536 | 537 | lda #VDHR1 538 | ldy #>479 539 | jsr writereg 540 | jsr delay1ms 541 | 542 | lda #VNDR0 543 | ldy #31 544 | jsr writereg 545 | jsr delay1ms 546 | 547 | lda #VNDR1 548 | ldy #0 549 | jsr writereg 550 | jsr delay1ms 551 | 552 | lda #VSTR0 553 | ldy #22 554 | jsr writereg 555 | jsr delay1ms 556 | 557 | lda #VSTR1 558 | ldy #0 559 | jsr writereg 560 | jsr delay1ms 561 | 562 | lda #VPWR 563 | ldy #VPWR_LOW+1 564 | jsr writereg 565 | jsr delay1ms 566 | 567 | 568 | ;; active window X 569 | 570 | lda #HSAW0 571 | ldy #0 572 | jsr writereg 573 | jsr delay1ms 574 | 575 | lda #HSAW1 576 | ldy #0 577 | jsr writereg 578 | jsr delay1ms 579 | 580 | lda #HEAW0 581 | ldy #<799 582 | jsr writereg 583 | jsr delay1ms 584 | 585 | lda #HEAW1 586 | ldy #>799 587 | jsr writereg 588 | jsr delay1ms 589 | 590 | ;; active window Y 591 | lda #VSAW0 592 | ldy #0 593 | jsr writereg 594 | jsr delay1ms 595 | 596 | lda #VSAW1 597 | ldy #0 598 | jsr writereg 599 | jsr delay1ms 600 | 601 | lda #VEAW0 602 | ldy #<479 603 | jsr writereg 604 | jsr delay1ms 605 | 606 | lda #VEAW1 607 | ldy #>479 608 | jsr writereg 609 | jsr delay1ms 610 | 611 | lda #MCLR 612 | ldy #MCLR_START|MCLR_FULL 613 | jsr writereg 614 | 615 | jsr delay1s 616 | 617 | rts 618 | 619 | ;;; Turn on display and backlight 620 | ;;; 621 | displayon 622 | 623 | ;tft.displayOn(true); 624 | lda #PWRR 625 | ldy #PWRR_NORMAL|PWRR_DISPON 626 | jsr writereg 627 | 628 | ; tft.GPIOX(true); // Enable TFT - display enable tied to GPIOX 629 | lda #GPIOX 630 | ldy #1 631 | jsr writereg 632 | 633 | ; tft.PWM1config(true, RA8875_PWM_CLK_DIV1024); // PWM output for backlight 634 | lda #P1CR 635 | ldy #P1CR_ENABLE|PWM_CLK_DIV1024 636 | jsr writereg 637 | 638 | ;tft.PWM1out(255); 639 | lda #P1DCR 640 | ldy #255 641 | jsr writereg 642 | 643 | rts 644 | 645 | ;;; set text colors (actually, either mode) -- fg white, bg black 646 | ;;; 647 | defaultcolors 648 | 649 | ;; set foreground to white 650 | lda #$63 651 | ldy #$1f 652 | jsr writereg 653 | 654 | lda #$64 655 | ldy #$3f 656 | jsr writereg 657 | 658 | lda #$65 659 | lda #$1f 660 | jsr writereg 661 | 662 | ldy#0 663 | lda #$60 664 | jsr writereg 665 | lda #$61 666 | jsr writereg 667 | lda #$62 668 | jsr writereg 669 | 670 | ;; Clear transparency flag 671 | lda #$22 672 | jsr wrcommand 673 | jsr rddata 674 | and #%10111111 ; clear bit 6 675 | jsr wrdata 676 | 677 | rts 678 | 679 | 680 | ;;; Video initialization -- set up the comm port, reset the video 681 | ;;; board, set up registers, etc. 682 | ;;; 683 | initvideo 684 | jsr vidconf6522 ; set up the port 685 | jsr vidinit ; reset the video board 686 | jsr reginit ; initial register setup 687 | jsr displayon ; turn on the display 688 | jsr dotext ; set text mode 689 | jsr docursor ; turn on cursor 690 | stz VROW 691 | stz VCOL 692 | rts 693 | 694 | 695 | ;;; 696 | ;;; Implement primary functions 697 | ;;; 698 | ;;; 699 | 700 | 701 | DLSTART=$80 702 | DLSTOP=$00 703 | DRAWSQUARE=$10 704 | FILL=$20 705 | 706 | 707 | ;;; set text mode, text font, text color, and text direction 708 | ;;; 709 | dotext 710 | ;; send command 0x40 (MWCR0 register) 711 | lda #$40 712 | jsr wrcommand 713 | 714 | ;; read response 715 | jsr rddata 716 | ;; set bit 7 717 | ora #$80 718 | ;; write it back as data 719 | jsr wrdata 720 | 721 | ;; font selection 722 | lda #$21 723 | jsr wrcommand 724 | jsr rddata 725 | and #%0101111 ; clear bits 7 and 5 726 | jsr wrdata 727 | 728 | jsr defaultcolors 729 | 730 | rts 731 | 732 | 733 | ;;; turn on hardware cursor 734 | ;;; 735 | docursor 736 | lda #MWCR0 737 | jsr wrcommand 738 | jsr rddata 739 | ora #MWCR0_CURSOR 740 | jsr wrdata 741 | 742 | lda #MWCR0 743 | jsr wrcommand 744 | jsr rddata 745 | ora #MWCR0_BLINK 746 | jsr wrdata 747 | 748 | lda #BTCR 749 | jsr wrcommand 750 | lda #32 ; just keep tweaking until I like the result 751 | jsr wrdata 752 | 753 | rts 754 | 755 | 756 | ;;; print a character using the video routines. keep track of column and 757 | ;;; row in case we need to scroll. 758 | ;;; 759 | ;;; CAREFUL -- there are multiple exit points from this. make sure that 760 | ;;; they always restore the stack appropriately. 761 | ;;; 762 | puta 763 | vputa 764 | cmp #$0d ; carriage return 765 | beq vcr 766 | cmp #$0a ; line feed 767 | beq vlf 768 | cmp #$08 ; backspace 769 | beq vbs 770 | 771 | ;; with the special cases out of the way, just display 772 | ;; the character. 773 | pha 774 | phy 775 | tay 776 | lda #MRWC 777 | jsr wrcommand 778 | tya 779 | jsr wrdata 780 | ply 781 | inc VCOL 782 | lda VCOL ; have we run off the end of the line? 783 | cmp #100 784 | bne endchar ; no, so continue 785 | stz VCOL ; yes -- update column 786 | inc VROW 787 | lda VROW ; were we on the last row 788 | cmp #30 789 | beq scroll ; yes, so scroll screen up 790 | endchar 791 | pla 792 | rts 793 | 794 | ;;; carriage return for video card 795 | vcr 796 | pha 797 | phy 798 | stz VCOL 799 | ldy #0 ; set $2a and $2b, horizontal position, to 0 800 | lda #$2b 801 | jsr writereg 802 | lda #$2a 803 | jsr writereg 804 | ply 805 | pla 806 | rts 807 | 808 | ;;; line feed for video card -- possibly scroll 809 | vlf 810 | pha 811 | inc VROW 812 | lda VROW 813 | cmp #30 814 | bne noscroll 815 | scroll 816 | jsr doscrollup 817 | lda #20 818 | sta VROW 819 | bra endnewline 820 | noscroll 821 | phy ; save Y 822 | lda #$2d ; read MSB of vertical position 823 | jsr readreg 824 | tay ; cache it in Y 825 | lda #$2c ; read LSB of vertial position 826 | jsr readreg 827 | clc 828 | adc #16 ; add 16 829 | pha ; temporaily store on stack 830 | tya ; get MSB again 831 | adc #0 ; process the carry 832 | tay ; write to Y 833 | lda #$2d ; write value of Y to $2d (MSB) 834 | jsr writereg 835 | ply ; retreive LSB cached on stack 836 | lda #$2c ; write to LSB register 837 | jsr writereg 838 | ply ; restore Y 839 | endnewline 840 | stz VCOL 841 | pla ; restore A 842 | rts 843 | 844 | ;;; backspace for video card 845 | ;;; 846 | vbs 847 | pha 848 | ;; if we're in the first column, backspace does nothing. 849 | lda VCOL 850 | beq skipbs 851 | 852 | phy ; save Y temporarily 853 | dec VCOL ; moving back to previous column 854 | ;; use VCOL to calculate correct position (VCOL * 8). use SCRATCH+14 855 | ;; and SCRATCH+15 856 | stz SCRATCH+15 857 | lda VCOL 858 | asl 859 | rol SCRATCH+15 860 | asl 861 | rol SCRATCH+15 862 | asl 863 | rol SCRATCH+15 864 | sta SCRATCH+14 ; cache it because we'll need it again in a moment 865 | 866 | ;; reset the text cursor position 867 | tay 868 | lda #$2a 869 | jsr writereg 870 | ldy SCRATCH+15 871 | lda #$2b 872 | jsr writereg 873 | 874 | ;; print a space to erase the character 875 | lda #MRWC 876 | jsr wrcommand 877 | lda #32 ; space 878 | jsr wrdata 879 | 880 | ;; reset text position again 881 | ;; reset the text cursor position 882 | ldy SCRATCH+14 883 | lda #$2a 884 | jsr writereg 885 | ldy SCRATCH+15 886 | lda #$2b 887 | jsr writereg 888 | 889 | ply ; restore Y 890 | 891 | skipbs 892 | pla ; restore A 893 | rts 894 | 895 | 896 | crlf 897 | vcrlf 898 | jsr vcr 899 | jsr vlf 900 | rts 901 | 902 | 903 | ;;; scrollup is basically the text scrolling function that i need 904 | ;;; for "terminal" type interaction. Four steps -- first, some setup 905 | ;;; that I do here so that the block transfer and then erase happen 906 | ;;; as quickly together as possible. Then, do the block transfer to 907 | ;;; move the bottom two thirds of the screen to the top. Next, paint 908 | ;;; a black background in the bottom third. Finally, reset the color 909 | ;;; and move the text position to the newly opened area. 910 | ;;; 911 | doscrollup 912 | phy ; preserve Y 913 | 914 | ;; set up for move. I do this out of line so that the actual transfer 915 | ;; happens as quickly as it can. Look up the current foreground 916 | ;; color, cache it on the stack, and set the foreground to black. 917 | ;; look up current color values and save them 918 | lda #$63 919 | jsr readreg 920 | pha 921 | 922 | lda #$64 923 | jsr readreg 924 | pha 925 | 926 | lda #$65 927 | jsr readreg 928 | pha 929 | 930 | ;; now set color to black, ready for painting the block after the move 931 | ldy #0 932 | lda #$63 933 | jsr writereg 934 | lda #$64 935 | jsr writereg 936 | lda #$65 937 | jsr writereg 938 | 939 | ;; setup completed. next, do the block move. 940 | ;; set up source address 941 | ;; NOTE address includes layer specification. I'm setting this 942 | ;; to zero, which means Layer 1. I'm not even sure right now which 943 | ;; layer I'm using! 944 | ldy #0 ; starting at 0, 160 945 | lda #$54 ; LSB of X coordinate 946 | jsr writereg 947 | lda #$55 ; MSB of X coordinate 948 | jsr writereg 949 | ldy #$A0 950 | lda #$56 ; LSB of Y coordinate 951 | jsr writereg 952 | ldy #0 953 | lda #$57 ; MSB of Y coordinate 954 | 955 | 956 | ;; set up destination address 957 | ldy #0 ; copying to 0,0 958 | lda #$58 ; LSB of X coordinate 959 | jsr writereg 960 | lda #$59 ; MSB of X coordinate 961 | jsr writereg 962 | lda #$5A ; LSB of Y coordinate 963 | jsr writereg 964 | lda #$5B ; MSB of Y coordinate 965 | 966 | ;; set BTE width and hight 967 | ldy #$20 ; width is 800 ($320) 968 | lda #$5C ; LSB of width 969 | jsr writereg 970 | ldy #$03 971 | lda #$5D ; MSD of width 972 | jsr writereg 973 | 974 | 975 | ldy #$40 ; height is 340 ($140) 976 | lda #$5E ; LSB of X coordinate 977 | jsr writereg 978 | ldy #$01 979 | lda #$5F ; MSD of X coordinate 980 | jsr writereg 981 | 982 | ;; set BTE function 983 | ;; function is "move in a positive direction". The "positive direction" 984 | ;; means that we start at the beginning and move toward the end; since 985 | ;; the source and destination regions overlap, that's what we need. 986 | ;; ROP is "destionation = source" (ie, straight copy). 987 | ;; ROP is %1100 = $C, ROP is %0010 = $02 988 | ;; result is $C2 989 | ldy #$C2 990 | lda #$51 991 | jsr writereg 992 | 993 | ;; enable BTE function 994 | ldy #$80 995 | lda #$50 996 | jsr writereg 997 | 998 | ;; wait for block transfer to complete. Read register $50 until 999 | ;; the top bit is clear. 1000 | .( 1001 | busyloop 1002 | lda #$50 1003 | jsr readreg 1004 | bmi busyloop 1005 | .) 1006 | 1007 | ;; now, empty bottom third of the screen. region is from 1008 | ;; ($0, $140) to ($31F, $11F) 1009 | 1010 | ;; set up parameters -- startx, starty, endx, endy 1011 | lda #$91 1012 | ldy #0 1013 | jsr writereg 1014 | ldy #0 1015 | lda #$92 1016 | jsr writereg 1017 | ldy #$40 1018 | lda #$93 1019 | jsr writereg 1020 | ldy #1 1021 | lda #$94 1022 | jsr writereg 1023 | 1024 | lda #$95 1025 | ldy #$1F ; lower byte for 799 1026 | jsr writereg 1027 | lda #$96 1028 | ldy #03 ; upper byte for 799 1029 | jsr writereg 1030 | 1031 | lda #$97 1032 | ldy #$df ; lower byte for 479 1033 | jsr writereg 1034 | lda #$98 1035 | ldy #$01 ; upper byte for 479 1036 | jsr writereg 1037 | 1038 | ;; do the block draw 1039 | lda #DCR 1040 | jsr wrcommand 1041 | 1042 | lda #DLSTOP|DRAWSQUARE 1043 | jsr wrdata 1044 | lda #DLSTART|FILL|DRAWSQUARE 1045 | jsr wrdata 1046 | 1047 | ;; wait until complete 1048 | .( 1049 | busyloop 1050 | lda #$90 1051 | jsr readreg 1052 | bmi busyloop 1053 | .) 1054 | 1055 | ;; reset color. I should check if there's a way to draw a 1056 | ;; rectangle using the current *background* color 'cos that 1057 | ;; would be a lot easier! 1058 | pla 1059 | tay 1060 | lda #$65 1061 | jsr writereg 1062 | pla 1063 | tay 1064 | lda #$64 1065 | jsr writereg 1066 | pla 1067 | tay 1068 | lda #$63 1069 | jsr writereg 1070 | 1071 | ;; move text cursor 1072 | ldy #0 ; set $2a and $2b, horizontal position, to 0 1073 | lda #$2a 1074 | jsr writereg 1075 | lda #$2b 1076 | jsr writereg 1077 | ldy #$40 1078 | lda #$2c 1079 | jsr writereg 1080 | ldy #1 1081 | lda #$2d 1082 | jsr writereg 1083 | 1084 | ply ; restore Y 1085 | rts 1086 | 1087 | 1088 | ;;; color lookup table 1089 | ;;; RA8875 uses five bits for blue, six for green, and five for red. 1090 | ;;; Rather than extract them from 16-bit values, I've just precomputed 1091 | ;;; some colors here and can use index into this table as a color value. 1092 | ;;; color 0 = black, color 8 = white, and the others are a random selection. 1093 | colors 1094 | .byte $00, $00, $00 ; black 1095 | .byte $1F, $00, $00 ; red 1096 | .byte $00, $3F, $00 ; green 1097 | .byte $00, $00, $1F ; blue 1098 | .byte $00, $3F, $1F ; cyan 1099 | .byte $1F, $00, $1F ; magenta 1100 | .byte $1F, $3F, $00 ; yellow 1101 | .byte $1F, $3F, $1F ; white 1102 | .byte $0F, $1F, $0F ; grey 1103 | .byte $1D, $18, $15 ; pink? 1104 | 1105 | 1106 | ;;; 1107 | ;;; Keyboard support -- reading from the ATtiny26 microcontroller 1108 | ;;; connected to the system VIA. 1109 | ;;; 1110 | 1111 | initkeyboard 1112 | stz $8003 ; set DDR register for VIA PORTA 1113 | lda #10 ; don't know that I still need this? 1114 | sta $800c ; don't know that I still need this? 1115 | rts 1116 | 1117 | readchar 1118 | kbdget 1119 | lda $800d ; load interrupt register 1120 | and #2 ; check interrupt flag for keyboard 1121 | beq kbdget ; loop if there's nothing there yet 1122 | lda $8001 ; load the character 1123 | pha ; cache it on the stack for a moment 1124 | lda #12 ; set CS2 handshake line to zero 1125 | sta $800c ; set it 1126 | nop ; wait for microcontroller 1127 | nop 1128 | nop 1129 | nop 1130 | lda #14 ; set CS2 handshake line high again 1131 | sta $800c ; set it 1132 | pla ; retreive data from stack 1133 | rts 1134 | 1135 | 1136 | ;;; 1137 | ;;; Serial support 1138 | ;;; 1139 | 1140 | initserial 1141 | ;; configure the ACIA 1142 | lda #%00001011 ; no parity, no echo, no interrupt 1143 | sta ACIA_COMMAND 1144 | lda #%00011111 ; 1 stop bit, 8 data bits, 19200 baud 1145 | sta ACIA_CONTROL 1146 | rts 1147 | 1148 | ;; get a character from the serial port 1149 | ;; 1150 | getserial 1151 | lda ACIA_STATUS 1152 | and #$08 1153 | beq getserial 1154 | lda ACIA_DATA 1155 | rts 1156 | 1157 | ;;; send a character to the serial port 1158 | ;;; 1159 | putserial 1160 | .( 1161 | pha 1162 | lda #$10 1163 | wait_txd_empty 1164 | bit ACIA_STATUS 1165 | beq wait_txd_empty 1166 | pla 1167 | sta ACIA_DATA 1168 | .) 1169 | rts 1170 | 1171 | 1172 | ;;; print immediate -- hack the stack to find the string to print 1173 | ;;; right after the JSR instruction, and when complete, jump over the 1174 | ;;; string to resume execution. 1175 | ;;; 1176 | DPL = SCRATCH+14 1177 | DPH = SCRATCH+15 1178 | primm: 1179 | pla ; get low part of (string address-1) 1180 | sta DPL 1181 | pla ; get high part of (string address-1) 1182 | sta DPH 1183 | bra primm3 1184 | primm2: 1185 | jsr puta ; output a string char 1186 | primm3: 1187 | inc DPL ; advance the string pointer 1188 | bne primm4 1189 | inc DPH 1190 | primm4: 1191 | lda (DPL) ; get string char 1192 | bne primm2 ; output and continue if not NUL 1193 | lda DPH 1194 | pha 1195 | lda DPL 1196 | pha 1197 | rts ; proceed at code following the NUL 1198 | -------------------------------------------------------------------------------- /sd.a65: -------------------------------------------------------------------------------- 1 | portb=$8002 2 | 3 | ;; CLK is PB0, ie 1 4 | ;; MOSI is PB1, ie 2 5 | ;; CS is PB2, ie 4 6 | ;; MISO is PB7, which maps onto S flag on BIT (test with BPL and BMI) 7 | 8 | ;; set mosi 9 | ;; set cs 10 | lda #%00000110 11 | sta portb 12 | 13 | ;; toggle CLK at least 74 times 14 | ;; 15 | ldy #80 ; decimal 80 16 | .( 17 | initloop 18 | inc portb 19 | dec portb 20 | dey 21 | bne initloop 22 | .) 23 | 24 | ;; set cs 0 25 | ;; send cmd0 -- 01+6*0+24*0+10010101 26 | lda #%01000000 27 | jsr sendbyte 28 | lda #0 29 | jsr sendbyte 30 | jsr sendbyte 31 | jsr sendbyte 32 | lda #%10010101 33 | jsr sendbyte 34 | 35 | ;; keep MOSI high 36 | ;; set CS low 37 | lda #2 38 | sta portb 39 | 40 | ;; keep toggling CLK and listen on MISO for it going low 41 | listenloop 42 | inc portb 43 | bit portb 44 | ;; branch when it goes low 45 | bpl recvloop 46 | dec portb 47 | bra listenloop 48 | 49 | recvloop 50 | dec portb 51 | ;; we have received a zero. grab seven more bits and rotate them 52 | ;; into result. 53 | lda #0 54 | ldy #7 55 | nextbit 56 | inc portb 57 | bit portb 58 | bmi recvone 59 | recvzero 60 | clc 61 | bra recvbit 62 | recvone 63 | sec 64 | recvbit 65 | rol 66 | dec portb 67 | dey 68 | bne nextbit 69 | 70 | 71 | 72 | 73 | 74 | ;; should come back within 16 cycles 75 | 76 | 77 | 78 | 79 | 80 | 81 | sendbyte 82 | ldy #8 83 | sendloop 84 | pha 85 | clc 86 | asl 87 | bcc sendzero 88 | sendone 89 | lda portb 90 | ora #2 91 | sta portb 92 | bra send 93 | sendzero 94 | lda portb 95 | and #%11111101 96 | sta portb 97 | send 98 | inc portb 99 | dec portb 100 | pla 101 | dey 102 | bne sendloop 103 | rts 104 | 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /secnd1.a65: -------------------------------------------------------------------------------- 1 | 2 | ;;; 3 | ;;; SECND - A FORTH FOR 6502 4 | ;;; 5 | ;;; Since "FORTH" is actually an abbreviation of "FOURTH", "SECND" 6 | ;;; is an abbreviation of "SECOND", it being my second FORTH 7 | ;;; implementation. The last one was over 30 years ago, but let's 8 | ;;; not worry about that now. This time, I'm sticking closer to 9 | ;;; standards, albeit outdated ones; the starting point for this 10 | ;;; is FigFORTH although it may get ANSIfied along the way. 11 | ;;; 12 | ;;; I'm building this for my single-board 6502 computer, the Mite. 13 | ;;; For now at least, this is written to be loaded in RAM. 14 | ;;; 15 | ;;; Paul Dourish, December 2017 16 | ;;; 17 | 18 | 19 | * = $0300 20 | 21 | ;;; 22 | ;;; Variables/space setup 23 | ;;; 24 | 25 | SCRATCH = $0010 ; through to $001F (adopted from monitor) 26 | 27 | ;;; 28 | ;;; space available from monitor is 0050-007F 29 | ;;; 00800 through 00FF is operand stack 30 | 31 | ;;; IP is the instruction pointer 32 | ;;; DT (dictionary top) pointer to start (actually, end) of dictionary 33 | ;;; RP is return stack pointer 34 | ;;; TMP and TMP1 hold temporary values (need two bytes) 35 | ;;; 36 | IP=$0050 ; and 0051 37 | RP=$0052 ; and 0053 38 | DT=$0054 ; and 0054 39 | TMP=$0056 ; and 0057 40 | TMP1=$0057 ; and 0058 41 | TPTR=$005A 42 | TCNT=$005B 43 | DPTR=$005C ; and 005D 44 | INPUT= $7F00 ; input space 45 | WORD=$7EC0 ; temporary space for parsing words (max 63 chars) 46 | 47 | jmp coldstart ; jump past code defined in stack routines 48 | 49 | #include "../mitemon/decl.a65" 50 | #include "../mitemon/stack.a65" 51 | 52 | 53 | ;;; 54 | ;;; initialization and configuration 55 | ;;; 56 | coldstart 57 | ;; initialize stack... 58 | jsr initstack 59 | 60 | ;; initialize variables... 61 | 62 | ;; IP is the Forth instruction pointer 63 | stz IP 64 | stz IP+1 65 | 66 | ;; Initialize the return stack. I'm just putting that on page 2, 67 | ;; growing upwards, until I have a better idea. 68 | stz RP 69 | lda #$02 70 | sta RP+1 71 | 72 | ;; Initialize DT to the last entry on the dictionary (below) 73 | lda #d13entry 76 | sta DT+1 77 | 78 | ;; jump to test code 79 | ;jmp gotest 80 | 81 | ;; jump to text interpreter 82 | jmp startinterp 83 | 84 | 85 | 86 | ;;; 87 | ;;; DICTIONARY 88 | ;;; 89 | ;;; Each entry in the dictionary comprises: 90 | ;;; - one byte that is both tags (three upper bits) and word length 91 | ;;; five lower bits) 92 | ;;; - the characters making up the word definition name 93 | ;;; - pointer to next entry 94 | ;;; - the "code word" (address of code handling this instruction, which 95 | ;;; will often be DOLIST for compiled words) 96 | ;;; - the parameter space (often the list of addresses for executing 97 | ;;; this word, and often ending with EXIT) 98 | ;;; 99 | 100 | d0entry 101 | .byte 4 102 | .byte "exit" 103 | d0link 104 | .word $0000 105 | d0code 106 | .word exit 107 | 108 | d1entry 109 | .byte 1 110 | .byte "+" 111 | d1link 112 | .word d0entry 113 | d1code 114 | .word doplus 115 | 116 | d2entry 117 | .byte 1 118 | .byte "*" 119 | d2link 120 | .word d1entry 121 | d2code 122 | .word dotimes 123 | 124 | d3entry 125 | .byte 4 126 | .byte "test" 127 | d3link 128 | .word d2entry 129 | d3code 130 | .word dolist 131 | d3param 132 | .word d2code 133 | .word d1code 134 | .word d0code 135 | 136 | d4entry 137 | .byte 4 138 | .byte "meta" 139 | d4link 140 | .word d3entry 141 | d4code 142 | .word dolist 143 | d4param 144 | .word d3code 145 | .word d3code 146 | .word d0code 147 | 148 | d5entry 149 | .byte 5 150 | .byte "dolit" 151 | d5link 152 | .word d4entry 153 | d5code 154 | .word dolit 155 | 156 | d6entry 157 | .byte 1 158 | .byte "." 159 | d6link 160 | .word d5entry 161 | d6code 162 | .word doprint 163 | 164 | d7entry 165 | .byte 5 166 | .byte "twice" 167 | d7link 168 | .word d6entry 169 | d7code 170 | .word dolist 171 | d7param 172 | .word d5code ; code for dolit 173 | .word 0002 174 | .word d2code 175 | .word d0code 176 | 177 | d8entry 178 | .byte 5 179 | .byte "meta2" 180 | d8link 181 | .word d7entry 182 | d8code 183 | .word dolist 184 | d8param 185 | .word d7code 186 | .word d6code 187 | .word d0code 188 | 189 | d9entry 190 | .byte 3 191 | .byte "dup" 192 | d9link 193 | .word d8entry 194 | d9code 195 | .word dodup 196 | 197 | d10entry 198 | .byte 4 199 | .byte "swap" 200 | d10link 201 | .word d9entry 202 | d10code 203 | .word doswap 204 | 205 | d11entry 206 | .byte 4 207 | .byte "drop" 208 | d11link 209 | .word d10entry 210 | d11code 211 | .word dodrop 212 | 213 | d12entry 214 | .byte 1 215 | .byte "/" 216 | d12link 217 | .word d11entry 218 | d12code 219 | .word dodiv 220 | 221 | d13entry 222 | .byte 3 223 | .byte "mod" 224 | d13link 225 | .word d12entry 226 | d13code 227 | .word domod 228 | 229 | ;;; 230 | ;;; The words below are my experiment on calling things and getting 231 | ;;; back to the interpreter. Dummy is the word we'll enter in order to 232 | ;;; execute something; the point of it is to make sure that after we've 233 | ;;; executed what we want, we run "doquitword", which should take us 234 | ;;; back into the interpreter loop 235 | ;;; 236 | 237 | 238 | doquitword 239 | .byte 0 240 | doquitlink 241 | .word $0000 242 | doquitcode 243 | .word interploop 244 | 245 | dummy 246 | .byte 0 247 | dummylink 248 | .word $0000 249 | dummycode 250 | .word dolist ; won't actually run this, start with NEXT instead 251 | dummyparam 252 | .word $0000 ; will write in the actual code link word here 253 | .word doquitcode 254 | 255 | 256 | 257 | 258 | 259 | ;;; 260 | ;;; INNER INTERPRETER 261 | ;;; 262 | ;;; The three routines below -- NEXT, DOLIST, and EXIT -- are the core 263 | ;;; of the inner interpreter, which executes stored words. 264 | ;;; 265 | ;;; NEXT moves from one instruction to the next inside a defined word. 266 | ;;; This code is included at the end of each assembly language routine 267 | ;;; (or rather, we jump to it). 268 | ;;; 269 | ;;; DOLIST begins the execution of a compiled word. It stores the IP 270 | ;;; on the return stack, resets the IP to the new word, and then calls 271 | ;;; NEXT to start on it. 272 | ;;; 273 | ;;; EXIT is compiled in as the last address of each compiled word. It 274 | ;;; undoes what DOLIST has done, and moves back to the earlier execution 275 | ;;; context. 276 | ;;; 277 | ;;; Note that none of these are subroutines -- everything is connected 278 | ;;; as direct jumps (actually, indirect jumps!) with the RSTACK used 279 | ;;; to keep track of what's going on. 280 | 281 | 282 | 283 | ;;; DOLIST is the executing code for a colon-defined word. 284 | dolist 285 | ;; first, push the current instruction pointer onto the 286 | ;; return stack 287 | ;; NB-- this was previously done via jsr rpush but I unrolled it 288 | ;; here to save some loads/stores and a JSR. Old code is left in 289 | ;; comments as documentation. 290 | lda IP 291 | ;sta stackaccess 292 | sta (RP) 293 | inc RP 294 | lda IP+1 295 | ;sta stackaccess+1 296 | sta (RP) 297 | inc RP 298 | ;jsr rpush ; push onto the return stack 299 | 300 | ;; next, grab the address stored at the location signaled by 301 | ;; the instruction pointer (ie, doubly-indirect through IP) and 302 | ;; store it in TMP 303 | lda (IP) 304 | sta TMP 305 | ldy #1 306 | lda (IP),y 307 | ;sta TMP+1 (short-circuiting) 308 | ;; then copy it into IP 309 | ;lda TMP+1 (short-circuiting) 310 | sta IP+1 311 | lda TMP 312 | sta IP 313 | 314 | ;; IP now points to the CODE word of the defined word we want 315 | ;; to execute. So, call NEXT to increment IP and execute 316 | ;jmp next ; commented out because we can just fall through 317 | 318 | ;;; ** PUT NOTHING HERE... depending on fall-through from DOLIST to NEXT! 319 | 320 | ;;; NEXT moves to the next instruction in the sequence defined in 321 | ;;; a colon-defined word. Increments the instruction pointer, loads 322 | ;;; what it points to into a defined place, and then does the jump. 323 | next 324 | .( 325 | inc IP ; lower byte first 326 | bne continue ; skip upper byte if we haven't rolled over 327 | inc IP+1 328 | continue 329 | .) 330 | .( 331 | inc IP ; now same again, because we need to inc by 2 332 | bne continue 333 | inc IP+1 334 | continue 335 | .) 336 | ldy #0 ; IP now points to the location storing the next 337 | lda (IP),y ; word we need to execute. fetch that location, 338 | sta TMP ; and store it in TMP. 339 | iny 340 | lda (IP),y 341 | sta TMP+1 342 | 343 | lda (TMP),y ; TMP contains a pointer to a code word. Load 344 | sta TMP1+1 ; the code address stored there into TMP1. 345 | dey 346 | lda (TMP) 347 | sta TMP1 348 | 349 | jmp (TMP1) ; execute the code for this instruction/word 350 | 351 | 352 | 353 | ;;; EXIT is the routine that is called at the end of each colon-defined 354 | ;;; word (it's compiled in as the last address to be called). It undoes 355 | ;;; DOLIST... it removes an address from the return stack, puts it back 356 | ;;; as the instruction pointer, and calls next. 357 | exit 358 | ;; formerly, jsr rpull, now unrolled. 359 | dec RP ; take two bytes off the return stack 360 | dec RP 361 | ldy #1 ; now take the value that was on the return stack 362 | lda (RP),y ; and place it in the instruction pointer 363 | sta IP+1 364 | lda (RP) 365 | sta IP 366 | jmp next ; go execute the next instruction 367 | 368 | 369 | ;;; 370 | ;;; PRIMITIVES 371 | ;;; 372 | 373 | doplus 374 | jsr add16 375 | jmp next 376 | 377 | dominus 378 | jsr sub16 379 | jmp next 380 | 381 | dotimes 382 | jsr mult16 383 | jmp next 384 | 385 | dodiv 386 | jsr div16 387 | jmp next 388 | 389 | domod 390 | jsr mod16 391 | jmp next 392 | 393 | doprint 394 | jsr print16dec 395 | jmp next 396 | 397 | docr 398 | jsr crlf 399 | jmp next 400 | 401 | dodup 402 | jsr dup16 403 | jmp next 404 | 405 | dodrop 406 | jsr pop16 407 | jmp next 408 | 409 | doswap 410 | jsr swap16 411 | jmp next 412 | 413 | 414 | ;;; DOLIT is a little funky. DOLIT is a word, but it operates on the word 415 | ;;; list of the word from which it is called. So we look on the return stack, 416 | ;;; increment the value by two to advance to the next word, read the 417 | ;;; data at that location, put it on the stack, and then return, letting 418 | ;;; let NEXT advance the IP further. 419 | dolit 420 | .( 421 | inc IP ; increment IP to next cell (which stores the value) 422 | bne continue 423 | inc IP+1 424 | continue 425 | .) 426 | .( 427 | inc IP 428 | bne continue 429 | inc IP+1 430 | continue 431 | .) 432 | ldy #0 ; load the value there 433 | lda (IP),y 434 | sta stackaccess ; and store in stackaccess 435 | iny ; (now the second byte) 436 | lda (IP),y 437 | sta stackaccess+1 438 | jsr push16 ; add to the data stack 439 | jmp next 440 | 441 | 442 | 443 | ;;; 444 | ;;; TEXT INTERPRETER 445 | ;;; 446 | ;;; For the moment, this is a basically a stopgap. The real FORTH 447 | ;;; text interpreter has many individual components that manifest 448 | ;;; themselves as words in the dictionary, and we'll get there. 449 | ;;; (The fact that the text interpreter is called QUIT in true Forth 450 | ;;; is the ultimate testement to Chuck Moore's twisted nature.) 451 | ;;; This is just something to get us going. Again, much borrowed here 452 | ;;; from the code of the monitor. 453 | ;;; 454 | 455 | 456 | 457 | ;;; initialize the interpreter 458 | ;;; 459 | startinterp 460 | 461 | ;; set up buffer (nothing to do) 462 | 463 | ;; set up buffer pointer (current pointer within text buffer) 464 | stz TPTR 465 | 466 | ;; set up buffer counter (number of characters input) 467 | stz TCNT 468 | 469 | ;; print greeting 470 | ldy #0 471 | .( 472 | next_char 473 | wait_txd_empty 474 | lda ACIA_STATUS 475 | and #$10 476 | beq wait_txd_empty 477 | lda greeting,y 478 | beq interploop 479 | sta ACIA_DATA 480 | iny 481 | jmp next_char 482 | .) 483 | 484 | 485 | interploop 486 | 487 | ;; if no more input, ->nomoreinput 488 | 489 | lda TPTR ; current pointer 490 | cmp TCNT ; is that as much text as was read? 491 | beq nomoreinput ; if yes, print prompt and get more 492 | 493 | tay ; put TPTR into Y 494 | interpword 495 | ;; begin loop 496 | 497 | .( 498 | ;; look for next word 499 | lda INPUT,y 500 | cmp #$20 ; space 501 | beq nextchar 502 | cmp #$09 ; tab 503 | beq nextchar 504 | bne readword ; not white space, so go and read a word 505 | 506 | ;; continue skipping past space 507 | nextchar 508 | iny 509 | cpy TCNT 510 | beq nomoreinput 511 | jmp interpword 512 | .) 513 | 514 | ;; no more input -- we have exhausted the text buffer. refill. 515 | nomoreinput 516 | jsr okcrlf ; signal completion 517 | refill 518 | jsr readline ; read another line of text 519 | stz TPTR ; reset the pointer 520 | bra interploop ; resume processing 521 | 522 | ;; we have detected the start of a non-space sequence. read a word 523 | ;; into a counted string at WORD. 524 | readword 525 | .( 526 | stz WORD 527 | phx 528 | ldx #1 ; X starts at 1 because 0 is the count 529 | nextchar 530 | lda INPUT,y 531 | beq doneword ; done if we hit NULL 532 | cmp #$20 533 | beq doneword ; done if we hit space 534 | cmp #$09 535 | beq doneword ; done if we hit tab 536 | sta WORD,x ; X starts at 1 because 0 is the count 537 | stx WORD 538 | iny 539 | cpy TCNT ; run off the end of the buffer? 540 | beq doneword 541 | inx 542 | bra nextchar 543 | doneword 544 | plx 545 | sty TPTR ; update the pointer (and free up Y) 546 | .) 547 | 548 | ;; check for match 549 | 550 | matchword 551 | ;; set up search by initializing dictionary pointer 552 | lda DT 553 | sta DPTR 554 | lda DT+1 555 | sta DPTR+1 556 | 557 | nextentry 558 | ;; have we run out of dictionary entries? (when DPTR is $0000) 559 | lda DPTR 560 | bne compareentry 561 | lda DPTR+1 562 | beq nomatch 563 | 564 | compareentry 565 | ;; compare words. counted strings can be compared directly, will compare 566 | ;; counts first. But we need to mask out the tags in the count. 567 | 568 | ldy #0 569 | lda (DPTR),y 570 | and #%00011111 ; mask off the tags 571 | cmp WORD,y ; compare word lengths 572 | bne trynext ; no match 573 | 574 | ;; now compare words. do this from the end (for easier testing) 575 | ldy WORD 576 | .( 577 | nextchar 578 | lda (DPTR),y 579 | cmp WORD,y 580 | bne trynext 581 | dey 582 | bne nextchar 583 | .) 584 | ;; successful match! 585 | bra gotmatch 586 | 587 | ;; loop to next entry 588 | trynext 589 | lda (DPTR) ; get word length... 590 | tay ; store in Y, and add one... 591 | iny ; for the pointer to the next entry 592 | lda (DPTR),y ; update DPTR to point to next entry 593 | sta TMP 594 | iny 595 | lda (DPTR),y 596 | sta DPTR+1 597 | lda TMP 598 | sta DPTR 599 | bra nextentry 600 | 601 | ;; we found a match for a word to execute. Set up the context 602 | ;; and call NEXT to get started. 603 | gotmatch 604 | 605 | ;; DPTR stores the start of the entry for the word to execute. 606 | ;; So its code word is at (DPTR) + wordlength + 1 (len) + 2 (link) 607 | lda (DPTR) ; word length 608 | and #%00011111 ; mask off tag bits 609 | inc ; +1 for the length byte 610 | inc 611 | inc ; + 2 more for the link word 612 | clc 613 | adc DPTR ; add to address and store in dummy word entry 614 | sta dummyparam 615 | lda DPTR+1 616 | adc #$0 617 | sta dummyparam+1 618 | 619 | ;; put the dummy parameter address into IP (actually, the code 620 | ;; address because NEXT will inc it). 621 | lda #dummycode 624 | sta IP+1 625 | 626 | ;; jump to NEXT to start running it 627 | jmp next 628 | 629 | ;; we didn't find a match in the dictionary, so see if we can parse 630 | ;; it as a number. 631 | nomatch 632 | ;; before we do the conversion, check that all the letters are digits 633 | 634 | ldy WORD 635 | numcheck 636 | lda WORD,y 637 | cmp #$30 638 | bcc nointerpret ; BCC = branch if less than 639 | cmp #$40 640 | bcs nointerpret ; BCS = branch if greater or equal 641 | dey 642 | bne numcheck 643 | 644 | ;; convert number and put it on the stack 645 | ;; my routines for this us a null-terminated string, so add a null 646 | ldy WORD 647 | iny 648 | lda #0 649 | sta WORD,y ; add a null 650 | lda #WORD 653 | sta stackaccess+1 654 | .( 655 | inc stackaccess ; bump it by one to avoid the count 656 | bne done 657 | inc stackaccess+1 658 | done 659 | .) 660 | jsr push16 661 | jsr readdec16 ; convert it, leave it on the stack 662 | jmp interploop 663 | 664 | ;; if we get here, we couldn't find a match, nor could we read it as 665 | ;; a number. there's no interpretation, so issue an error, flush 666 | ;; the input, and loop 667 | nointerpret 668 | 669 | ;; print an error, in three stages. first, a space; then, the 670 | ;; undefined word; finally, the error message. 671 | 672 | .( 673 | wait_txd_empty3 674 | lda ACIA_STATUS 675 | and #$10 676 | beq wait_txd_empty3 677 | lda #$20 678 | sta ACIA_DATA 679 | .) 680 | 681 | ldy #1 682 | .( 683 | next_char 684 | wait_txd_empty3 685 | lda ACIA_STATUS 686 | and #$10 687 | beq wait_txd_empty3 688 | lda WORD,y 689 | sta ACIA_DATA 690 | iny 691 | cpy WORD 692 | bcc next_char 693 | beq next_char 694 | .) 695 | 696 | ldy #0 697 | .( 698 | next_char 699 | wait_txd_empty 700 | lda ACIA_STATUS 701 | and #$10 702 | beq wait_txd_empty 703 | lda cantinterpret,y 704 | beq nextstr 705 | sta ACIA_DATA 706 | iny 707 | bra next_char 708 | nextstr 709 | .) 710 | 711 | ;; flush input. 712 | lda TCNT 713 | sta TPTR ; wait... off by one? 714 | jmp refill 715 | 716 | 717 | 718 | readline 719 | ldy #0 720 | stz TCNT ; reset the counter 721 | readchar 722 | .( 723 | wait_rxd_full 724 | lda ACIA_STATUS 725 | and #$08 726 | beq wait_rxd_full 727 | .) 728 | lda ACIA_DATA 729 | cmp #$08 ; check for backspace 730 | beq backspace 731 | cmp #$0D ; check for newline 732 | beq doneline 733 | sta INPUT,y ; track the input 734 | iny 735 | jsr puta ; echo the typed character 736 | jmp readchar ; loop to repeat 737 | backspace 738 | cpy #0 ; beginning of line? 739 | beq readchar 740 | dey ; if not, go back one character 741 | jsr puta ; move cursor back 742 | jmp readchar 743 | 744 | ;; this is where we land if the line input has finished 745 | ;; 746 | doneline 747 | lda #0 748 | sta INPUT,y ; add a null terminator 749 | sty TCNT ; update character count 750 | rts 751 | 752 | 753 | 754 | 755 | 756 | ;;; 757 | ;;; test harness 758 | 759 | gotest 760 | ;;; initialize the stack. 5 on top, then 4, then 2, 2, 2. 761 | lda #$02 762 | sta stackaccess 763 | stz stackaccess+1 764 | jsr push16 765 | jsr push16 766 | jsr push16 767 | lda #04 768 | sta stackaccess 769 | jsr push16 770 | lda #05 771 | sta stackaccess 772 | jsr push16 773 | 774 | ;;; load the instruction pointer 775 | ;;; pretend we are executing the first "line" of "meta" 776 | ; lda #d4code 779 | ; sta IP+1 780 | ;;; pretend we are executing the first "line" of "meta2" 781 | lda #d8code 784 | sta IP+1 785 | 786 | ;;; go -- fetch the address indirectly through the IP 787 | lda (IP) 788 | sta TMP 789 | ldy #1 790 | lda (IP),y 791 | sta TMP+1 792 | 793 | ;; before we jump, reset the IP 794 | ; lda #d4param 797 | ; sta IP+1 798 | lda #d8param 801 | sta IP+1 802 | 803 | jmp (TMP) 804 | 805 | ;;; stop 806 | 807 | 808 | 809 | ;;; 810 | ;;; support routines 811 | ;;; 812 | 813 | rpush 814 | lda stackaccess 815 | sta (RP) 816 | inc RP 817 | lda stackaccess+1 818 | sta (RP) 819 | inc RP ; BUG presumes that RP doesn't roll over page boundary 820 | rts 821 | 822 | 823 | rpull 824 | dec RP 825 | dec RP 826 | ldy #1 827 | lda (RP),y 828 | sta stackaccess+1 829 | lda (RP) 830 | sta stackaccess 831 | rts 832 | 833 | 834 | 835 | ;;; 836 | ;;; I/O SUPPORT ROUTINES 837 | ;;; These have been "borrowed" from mitemon 838 | ;;; 839 | 840 | putax 841 | .( 842 | phy 843 | 844 | pha 845 | wait_txd_empty 846 | lda ACIA_STATUS 847 | and #$10 848 | beq wait_txd_empty 849 | pla 850 | pha ; put a copy back 851 | clc 852 | and #$f0 853 | ror 854 | ror 855 | ror 856 | ror 857 | tay 858 | lda hextable,y 859 | sta ACIA_DATA 860 | wait_txd_empty2 861 | lda ACIA_STATUS 862 | and #$10 863 | beq wait_txd_empty2 864 | pla 865 | clc 866 | and #$0f 867 | tay 868 | lda hextable,y 869 | sta ACIA_DATA 870 | .) 871 | ply 872 | rts 873 | 874 | 875 | puta 876 | .( 877 | pha 878 | wait_txd_empty 879 | lda ACIA_STATUS 880 | and #$10 881 | beq wait_txd_empty 882 | pla 883 | sta ACIA_DATA 884 | .) 885 | rts 886 | 887 | okcrlf 888 | ldy #0 889 | .( 890 | next_char 891 | wait_txd_empty 892 | lda ACIA_STATUS 893 | and #$10 894 | beq wait_txd_empty 895 | lda ok,y 896 | beq done 897 | sta ACIA_DATA 898 | iny 899 | jmp next_char 900 | done 901 | rts 902 | .) 903 | 904 | 905 | crlf 906 | pha 907 | .( 908 | wait_txd_empty 909 | lda ACIA_STATUS 910 | and #$10 911 | beq wait_txd_empty 912 | .) 913 | lda #$0d 914 | sta ACIA_DATA 915 | .( 916 | wait_txd_empty 917 | lda ACIA_STATUS 918 | and #$10 919 | beq wait_txd_empty 920 | .) 921 | lda #$0a 922 | sta ACIA_DATA 923 | pla 924 | rts 925 | 926 | 927 | hextable: .byte "0123456789ABCDEF" 928 | greeting .byte "SECND Forth v01 (Paul Dourish, 2017-12)", $00 929 | ok: .byte " OK", $0d, $0a, $00 930 | cantinterpret: .byte ": not defined", $0d, $0a, $00 931 | match: .byte " match!", $00 932 | -------------------------------------------------------------------------------- /secnd2.a65: -------------------------------------------------------------------------------- 1 | 2 | ;;; 3 | ;;; SECND - A FORTH FOR 6502 4 | ;;; 5 | ;;; Since "FORTH" is actually an abbreviation of "FOURTH", "SECND" 6 | ;;; is an abbreviation of "SECOND", it being my second FORTH 7 | ;;; implementation. The last one was over 30 years ago, but let's 8 | ;;; not worry about that now. This time, I'm sticking closer to 9 | ;;; standards, albeit outdated ones; the starting point for this 10 | ;;; is FigFORTH although it may get ANSIfied along the way. 11 | ;;; 12 | ;;; I'm building this for my single-board 6502 computer, the Mite. 13 | ;;; For now at least, this is written to be loaded in RAM. 14 | ;;; 15 | ;;; Paul Dourish, December 2017 16 | ;;; 17 | ;;; Version history: 18 | ;;; v01 first basic version of interpreter up and running 19 | ;;; v02 adding R-stack operators, variables, arrays, allot. 20 | 21 | 22 | * = $0300 23 | 24 | ;;; 25 | ;;; Variables/space setup 26 | ;;; 27 | 28 | SCRATCH = $0010 ; through to $001F (adopted from monitor) 29 | 30 | ;;; MEMORY MAP 31 | ;;; 32 | ;;; 0000 through 004F is reserved for the monitor (reusing SCRATCH) 33 | ;;; 0050 through 007F is available for variables (below) 34 | ;;; 0080 through 00FF is operand stack 35 | ;;; 0100 through 01FF is the hardware stack as usual 36 | ;;; 0200 through 02FF is the return stack (more space than needed) 37 | ;;; 0300 through 0FFF is the interpreter and compiler code (this file) 38 | ;;; 1000 through 77FF is user dictionary space 39 | ;;; 7800 through 7EBF is CURRENTLY UNASSIGNED 40 | ;;; 7EC0 through 7EFF is temporary string processing space 41 | ;;; 7F00 through 7FFF is the input buffer (TIB) 42 | 43 | ;;; 44 | ;;; KEY SYSTEM VARIABLES 45 | ;;; 46 | ;;; IP is the instruction pointer 47 | ;;; DT (dictionary top) pointer to start (actually, end) of dictionary 48 | ;;; RP is return stack pointer 49 | ;;; XT holds execution token of currently executing word 50 | ;;; CODEVEC holds the location of the code for the next instruction 51 | ;;; DP holds pointer to the next available dictionary space 52 | ;;; TPTR holds the offset of the most recently processed input character 53 | ;;; TCNT holds the number of characters held in the buffer 54 | ;;; DPTR is an internal variable for traversing the dictionary 55 | ;;; INPUT points to the input buffer 56 | ;;; WORD points to the temporary string processing space 57 | ;;; 58 | ;;; 59 | IP=$0050 ; and 0051 60 | RP=$0052 ; and 0053 61 | DT=$0054 ; and 0055 62 | XT=$0056 ; and 0057 63 | CODEVEC=$0058 ; and 0059 64 | TPTR=$005A 65 | TCNT=$005B 66 | DPTR=$005C ; and 005D 67 | DP=$005E ; and 005F 68 | INPUT= $7F00 ; input space 69 | WORD=$7EC0 ; temporary space for parsing words (max 63 chars) 70 | 71 | jmp coldstart ; jump past code defined in stack routines 72 | 73 | #include "../mitemon/decl.a65" 74 | #include "../mitemon/stack.a65" 75 | 76 | 77 | ;;; 78 | ;;; initialization and configuration 79 | ;;; 80 | coldstart 81 | ;; initialize stack... 82 | jsr initstack 83 | 84 | ;; initialize variables... 85 | 86 | ;; IP is the Forth instruction pointer 87 | stz IP 88 | stz IP+1 89 | 90 | ;; Initialize the return stack. I'm just putting that on page 2, 91 | ;; growing upwards, until I have a better idea. 92 | stz RP 93 | lda #$02 94 | sta RP+1 95 | 96 | ;; Initialize DT to the last entry on the dictionary (below) 97 | lda #d32entry 100 | sta DT+1 101 | 102 | ;; Initialize DP to the first available dictionary space ($1000) 103 | lda #$00 104 | sta DP 105 | lda #$10 106 | sta DP+1 107 | 108 | ;; jump to text interpreter 109 | jmp startinterp 110 | 111 | 112 | 113 | ;;; 114 | ;;; DICTIONARY 115 | ;;; 116 | ;;; Each entry in the dictionary comprises: 117 | ;;; - one byte that is both tags (three upper bits) and word length 118 | ;;; five lower bits) 119 | ;;; - the characters making up the word definition name 120 | ;;; - pointer to next entry 121 | ;;; - the "code word" (address of code handling this instruction, which 122 | ;;; will often be DOLIST for compiled words) 123 | ;;; - the parameter space (often the list of addresses for executing 124 | ;;; this word, and often ending with EXIT) 125 | ;;; 126 | 127 | d0entry 128 | .byte 4 129 | .byte "exit" 130 | d0link 131 | .word $0000 132 | d0code 133 | .word exit 134 | 135 | d1entry 136 | .byte 1 137 | .byte "+" 138 | d1link 139 | .word d0entry 140 | d1code 141 | .word doplus 142 | 143 | d2entry 144 | .byte 1 145 | .byte "*" 146 | d2link 147 | .word d1entry 148 | d2code 149 | .word dotimes 150 | 151 | d3entry 152 | .byte 4 153 | .byte "test" 154 | d3link 155 | .word d2entry 156 | d3code 157 | .word dolist 158 | d3param 159 | .word d2code 160 | .word d1code 161 | .word d0code 162 | 163 | d4entry 164 | .byte 4 165 | .byte "meta" 166 | d4link 167 | .word d3entry 168 | d4code 169 | .word dolist 170 | d4param 171 | .word d3code 172 | .word d3code 173 | .word d0code 174 | 175 | d5entry 176 | .byte 5 177 | .byte "dolit" 178 | d5link 179 | .word d4entry 180 | d5code 181 | .word dolit 182 | 183 | d6entry 184 | .byte 1 185 | .byte "." 186 | d6link 187 | .word d5entry 188 | d6code 189 | .word doprint 190 | 191 | d7entry 192 | .byte 5 193 | .byte "twice" 194 | d7link 195 | .word d6entry 196 | d7code 197 | .word dolist 198 | d7param 199 | .word d5code ; code for dolit 200 | .word 0002 201 | .word d2code 202 | .word d0code 203 | 204 | d8entry 205 | .byte 5 206 | .byte "meta2" 207 | d8link 208 | .word d7entry 209 | d8code 210 | .word dolist 211 | d8param 212 | .word d7code 213 | .word d6code 214 | .word d0code 215 | 216 | d9entry 217 | .byte 3 218 | .byte "dup" 219 | d9link 220 | .word d8entry 221 | d9code 222 | .word dodup 223 | 224 | d10entry 225 | .byte 4 226 | .byte "swap" 227 | d10link 228 | .word d9entry 229 | d10code 230 | .word doswap 231 | 232 | d11entry 233 | .byte 4 234 | .byte "drop" 235 | d11link 236 | .word d10entry 237 | d11code 238 | .word dodrop 239 | 240 | d12entry 241 | .byte 1 242 | .byte "/" 243 | d12link 244 | .word d11entry 245 | d12code 246 | .word dodiv 247 | 248 | d13entry 249 | .byte 3 250 | .byte "mod" 251 | d13link 252 | .word d12entry 253 | d13code 254 | .word domod 255 | 256 | d14entry 257 | .byte 1 258 | .byte "=" 259 | d14link 260 | .word d13entry 261 | d14code 262 | .word doequal 263 | 264 | d15entry 265 | .byte 5 266 | .byte "depth" 267 | d15link 268 | .word d14entry 269 | d15code 270 | .word dodepth 271 | 272 | d16entry 273 | .byte 1 274 | .byte ">" 275 | d16link 276 | .word d15entry 277 | d16code 278 | .word dogreater 279 | 280 | d17entry 281 | .byte 1 282 | .byte "<" 283 | d17link 284 | .word d16entry 285 | d17code 286 | .word doless 287 | 288 | d18entry 289 | .byte 2 290 | .byte "cr" 291 | d18link 292 | .word d17entry 293 | d18code 294 | .word docr 295 | 296 | d19entry 297 | .byte 4 298 | .byte "emit" 299 | d19link 300 | .word d18entry 301 | d19code 302 | .word doemit 303 | 304 | d20entry 305 | .byte 4 306 | .byte "over" 307 | d20link 308 | .word d19entry 309 | d20code 310 | .word doover 311 | 312 | d21entry 313 | .byte 3 314 | .byte "rot" 315 | d21link 316 | .word d20entry 317 | d21code 318 | .word dorot 319 | 320 | d22entry 321 | .byte 7 322 | .byte "testvar" 323 | d22link 324 | .word d21entry 325 | d22code 326 | .word dovaddr 327 | d22param 328 | .word $1234 329 | 330 | d23entry 331 | .byte 1 332 | .byte "@" 333 | d23link 334 | .word d22entry 335 | d23code 336 | .word dofetch 337 | 338 | d24entry 339 | .byte 2 340 | .byte "c@" 341 | d24link 342 | .word d23entry 343 | d24code 344 | .word docfetch 345 | 346 | d25entry 347 | .byte 1 348 | .byte "!" 349 | d25link 350 | .word d24entry 351 | d25code 352 | .word dostore 353 | 354 | d26entry 355 | .byte 2 356 | .byte "c!" 357 | d26link 358 | .word d25entry 359 | d26code 360 | .word docstore 361 | 362 | d27entry 363 | .byte 5 364 | .byte "cells" 365 | d27link 366 | .word d26entry 367 | d27code 368 | .word docells 369 | 370 | d28entry 371 | .byte 8 372 | .byte "variable" 373 | d28link 374 | .word d27entry 375 | d28code 376 | .word dovariable 377 | 378 | d29entry 379 | .byte 1 380 | .byte "-" 381 | d29link 382 | .word d28entry 383 | d29code 384 | .word dominus 385 | 386 | d30entry 387 | .byte 4 388 | .byte "here" 389 | d30link 390 | .word d29entry 391 | d30code 392 | .word dohere 393 | 394 | d31entry 395 | .byte 5 396 | .byte "allot" 397 | d31link 398 | .word d30entry 399 | d31code 400 | .word doallot 401 | 402 | d32entry 403 | .byte 3 404 | .byte "bye" 405 | d32link 406 | .word d31entry 407 | d32code 408 | .word dobye 409 | 410 | ;; TOP OF DICTIONARY 411 | 412 | 413 | ;;; 414 | ;;; The words below are my experiment on calling things and getting 415 | ;;; back to the interpreter. Dummy is the word we'll enter in order to 416 | ;;; execute something; the point of it is to make sure that after we've 417 | ;;; executed what we want, we run "doquitword", which should take us 418 | ;;; back into the interpreter loop 419 | ;;; 420 | 421 | 422 | doquitword 423 | .byte 0 424 | doquitlink 425 | .word $0000 426 | doquitcode 427 | .word interploop 428 | 429 | dummy 430 | .byte 0 431 | dummylink 432 | .word $0000 433 | dummycode 434 | .word dolist ; won't actually run this, start with NEXT instead 435 | dummyparam 436 | .word $0000 ; will write in the actual code link word here 437 | .word doquitcode 438 | 439 | 440 | 441 | 442 | 443 | ;;; 444 | ;;; INNER INTERPRETER 445 | ;;; 446 | ;;; The three routines below -- NEXT, DOLIST, and EXIT -- are the core 447 | ;;; of the inner interpreter, which executes stored words. 448 | ;;; 449 | ;;; NEXT moves from one instruction to the next inside a defined word. 450 | ;;; This code is included at the end of each assembly language routine 451 | ;;; (or rather, we jump to it). 452 | ;;; 453 | ;;; DOLIST begins the execution of a compiled word. It stores the IP 454 | ;;; on the return stack, resets the IP to the new word, and then calls 455 | ;;; NEXT to start on it. 456 | ;;; 457 | ;;; EXIT is compiled in as the last address of each compiled word. It 458 | ;;; undoes what DOLIST has done, and moves back to the earlier execution 459 | ;;; context. 460 | ;;; 461 | ;;; Note that none of these are subroutines -- everything is connected 462 | ;;; as direct jumps (actually, indirect jumps!) with the RSTACK used 463 | ;;; to keep track of what's going on. 464 | 465 | 466 | 467 | ;;; DOLIST is the executing code for a colon-defined word. 468 | dolist 469 | ;; first, push the current instruction pointer onto the 470 | ;; return stack 471 | ;; NB-- this was previously done via jsr rpush but I unrolled it 472 | ;; here to save some loads/stores and a JSR. Old code is left in 473 | ;; comments as documentation. 474 | lda IP 475 | ;sta stackaccess 476 | sta (RP) 477 | inc RP 478 | lda IP+1 479 | ;sta stackaccess+1 480 | sta (RP) 481 | inc RP 482 | ;jsr rpush ; push onto the return stack 483 | 484 | ;; next, grab the address stored at the location signaled by 485 | ;; the instruction pointer (ie, doubly-indirect through IP) and 486 | ;; store it back in IP 487 | lda (IP) 488 | sta SCRATCH 489 | ldy #1 490 | lda (IP),y 491 | sta IP+1 492 | lda SCRATCH 493 | sta IP 494 | 495 | ;; IP now points to the CODE word of the defined word we want 496 | ;; to execute. So, call NEXT to increment IP and execute 497 | ;jmp next ; commented out because we can just fall through 498 | 499 | ;;; ** PUT NOTHING HERE... depending on fall-through from DOLIST to NEXT! 500 | 501 | ;;; NEXT moves to the next instruction in the sequence defined in 502 | ;;; a colon-defined word. Increments the instruction pointer, loads 503 | ;;; what it points to into a defined place, and then does the jump. 504 | next 505 | .( 506 | inc IP ; lower byte first 507 | bne continue ; skip upper byte if we haven't rolled over 508 | inc IP+1 509 | continue 510 | .) 511 | .( 512 | inc IP ; now same again, because we need to inc by 2 513 | bne continue 514 | inc IP+1 515 | continue 516 | .) 517 | ldy #0 ; IP now points to the location storing the next 518 | lda (IP),y ; word we need to execute. fetch that location, 519 | sta XT ; and store it in XT. 520 | iny 521 | lda (IP),y 522 | sta XT+1 523 | 524 | lda (XT),y ; TMP contains a pointer to a code word. Load 525 | sta CODEVEC+1 ; the code address stored there into CODEVEC. 526 | dey 527 | lda (XT) 528 | sta CODEVEC 529 | 530 | jmp (CODEVEC) ; execute the code for this instruction/word 531 | 532 | 533 | 534 | ;;; EXIT is the routine that is called at the end of each colon-defined 535 | ;;; word (it's compiled in as the last address to be called). It undoes 536 | ;;; DOLIST... it removes an address from the return stack, puts it back 537 | ;;; as the instruction pointer, and calls next. 538 | exit 539 | ;; formerly, jsr rpull, now unrolled. 540 | dec RP ; take two bytes off the return stack 541 | dec RP 542 | ldy #1 ; now take the value that was on the return stack 543 | lda (RP),y ; and place it in the instruction pointer 544 | sta IP+1 545 | lda (RP) 546 | sta IP 547 | jmp next ; go execute the next instruction 548 | 549 | 550 | ;;; 551 | ;;; PRIMITIVES 552 | ;;; 553 | 554 | doplus 555 | jsr add16 556 | jmp next 557 | 558 | dominus 559 | jsr sub16 560 | jmp next 561 | 562 | dotimes 563 | jsr mult16 564 | jmp next 565 | 566 | dodiv 567 | jsr div16 568 | jmp next 569 | 570 | domod 571 | jsr mod16 572 | jmp next 573 | 574 | doprint 575 | jsr print16dec 576 | jmp next 577 | 578 | docr 579 | jsr crlf 580 | jmp next 581 | 582 | dodup 583 | jsr dup16 584 | jmp next 585 | 586 | dodrop 587 | jsr pop16 588 | jmp next 589 | 590 | doswap 591 | jsr swap16 592 | jmp next 593 | 594 | doequal 595 | .( 596 | lda stackbase+1,x 597 | cmp stackbase+3,x 598 | bne notequal 599 | lda stackbase+2,x 600 | cmp stackbase+4,x 601 | bne notequal 602 | equal 603 | inx 604 | inx 605 | lda #$01 606 | sta stackbase+1,x 607 | stz stackbase+2,x 608 | bra done 609 | notequal 610 | inx 611 | inx 612 | stz stackbase+1,x 613 | stz stackbase+2,x 614 | done 615 | .) 616 | jmp next 617 | 618 | ;; on the 6502, there's no simple "greater than" instruction; 619 | ;; BCS is "greater than or equal to". So, use BCC for "less than" 620 | ;; and invert result. also need different tests for upper and 621 | ;; lower bytes. This is also confused by the fact that the item that's 622 | ;; "lower" on the stack is higher in memory. 623 | dogreater 624 | .( 625 | lda stackbase+4,x ; most significant byte 626 | cmp stackbase+2,x ; is "lower" on stack less than "upper"? 627 | beq testlsb ; equal, so go to lower byte 628 | bmi notgreater ; less than, so answer is "no" 629 | bra greater ; greater than, so answer is "yes" 630 | testlsb 631 | lda stackbase+3,x ; less signficant byte 632 | cmp stackbase+1,x ; is "higher" on stack less than "lower"? 633 | beq notgreater 634 | bmi notgreater 635 | greater 636 | inx 637 | inx 638 | lda #$01 639 | sta stackbase+1,x 640 | stz stackbase+2,x 641 | bra done 642 | notgreater 643 | inx 644 | inx 645 | stz stackbase+1,x 646 | stz stackbase+2,x 647 | done 648 | .) 649 | jmp next 650 | 651 | doless 652 | .( 653 | lda stackbase+4,x 654 | cmp stackbase+2,x 655 | bmi yes 656 | beq testlsb 657 | bra no 658 | testlsb 659 | lda stackbase+3,x 660 | cmp stackbase+1,x 661 | beq no 662 | bpl no 663 | yes 664 | inx 665 | inx 666 | lda #$01 667 | sta stackbase+1,x 668 | stz stackbase+2,x 669 | bra done 670 | no 671 | inx 672 | inx 673 | stz stackbase+1,x 674 | stz stackbase+2,x 675 | done 676 | .) 677 | jmp next 678 | 679 | dodepth 680 | stx SCRATCH 681 | lda #$ff 682 | sec 683 | sbc SCRATCH 684 | clc 685 | lsr 686 | stz stackbase,x 687 | dex 688 | sta stackbase,x 689 | dex 690 | jmp next 691 | 692 | doemit 693 | lda stackbase+1,x 694 | jsr puta 695 | inx 696 | inx 697 | jmp next 698 | 699 | doover 700 | dex 701 | dex 702 | lda stackbase+5,x 703 | sta stackbase+1,x 704 | lda stackbase+6,x 705 | lda stackbase+2,x 706 | jmp next 707 | 708 | dorot 709 | dex ; make some new space on the stack 710 | dex 711 | lda stackbase+7,x ; first, copy the item from three down on the stack 712 | sta stackbase+1,x ; into the new space 713 | lda stackbase+8,x ; so, 7/8 -> 1/2 714 | sta stackbase+2,x 715 | 716 | lda stackbase+5,x ; now move everything back 717 | sta stackbase+7,x ; first, 5/6 -> 7/8 718 | lda stackbase+6,x 719 | sta stackbase+8,x 720 | lda stackbase+3,x ; then 3/4 -> 5/6 721 | sta stackbase+5,x 722 | lda stackbase+4,x 723 | sta stackbase+6,x 724 | lda stackbase+1,x ; then 1/2 -> 3/4 725 | sta stackbase+3,x 726 | lda stackbase+2,x 727 | sta stackbase+4,x 728 | 729 | inx ; clean up 730 | inx 731 | 732 | jmp next 733 | 734 | 735 | ;;; DOLIT is a little funky. DOLIT is a word, but it operates on the word 736 | ;;; list of the word from which it is called. So we look on the return stack, 737 | ;;; increment the value by two to advance to the next word, read the 738 | ;;; data at that location, put it on the stack, and then return, letting 739 | ;;; let NEXT advance the IP further. 740 | dolit 741 | .( 742 | inc IP ; increment IP to next cell (which stores the value) 743 | bne continue 744 | inc IP+1 745 | continue 746 | .) 747 | .( 748 | inc IP 749 | bne continue 750 | inc IP+1 751 | continue 752 | .) 753 | ldy #0 ; load the value there 754 | lda (IP),y 755 | sta stackaccess ; and store in stackaccess 756 | iny ; (now the second byte) 757 | lda (IP),y 758 | sta stackaccess+1 759 | jsr push16 ; add to the data stack 760 | jmp next 761 | 762 | 763 | ;;; dovaddr is the internal code for variables... look up the current 764 | ;;; XT and use it to find the address reserved for the variable, and 765 | ;;; push that. 766 | dovaddr 767 | lda XT 768 | sta stackaccess 769 | lda XT+1 770 | sta stackaccess+1 771 | .( 772 | inc stackaccess 773 | bne continue 774 | inc stackaccess+1 775 | continue 776 | .) 777 | .( 778 | inc stackaccess 779 | bne continue 780 | inc stackaccess+1 781 | continue 782 | .) 783 | jsr push16 784 | jmp next 785 | 786 | ;;; dofetch is the code for "@". Pull an address off the stack and 787 | ;;; look up the 16-bit data stored at that address 788 | dofetch 789 | jsr pop16 ; pop value into stackaccess 790 | dex ; make space on the stack 791 | dex 792 | ldy #1 793 | lda (stackaccess),y ; load MSB and store on stack 794 | sta stackbase+2,x ; store in the new space on the stack 795 | dey 796 | lda (stackaccess),y ; then LSB 797 | sta stackbase+1,x 798 | jmp next 799 | 800 | ;;; docfetch is the same as dofetch except for just one byte 801 | docfetch 802 | jsr pop16 ; pop value into stackaccess 803 | dex ; make space on the stack 804 | dex 805 | stz stackbase+2,x ; set MSB to zero 806 | lda (stackaccess) ; grab single byte 807 | sta stackbase+1,x ; and store in LSB 808 | jmp next 809 | 810 | 811 | ;;; dostore is the code for "!". Pull an address of the stack as in 812 | ;;; dofetch; but store the address pointed to by the next stack 813 | ;;; location in it. 814 | dostore 815 | jsr pop16 ; put address into stackaccess 816 | ldy #1 817 | lda stackbase+1,x ; load LSB off stack and 818 | sta (stackaccess) ; store at location we popped 819 | lda stackbase+2,x ; then for MSB 820 | sta (stackaccess),y ; with y=1 821 | inx ; drop the value from the stack 822 | inx 823 | jmp next 824 | 825 | ;;; cstore is just like store except stores just one byte (LSB from stack) 826 | docstore 827 | jsr pop16 ; put address into stackaccess 828 | lda stackbase+1,x ; load LSB off stack and 829 | sta (stackaccess) ; store at location we popped 830 | inx ; drop the value from the stack 831 | inx 832 | jmp next 833 | 834 | 835 | 836 | 837 | ;;; Turn an integer count of cells into a count of bytes. Since 838 | ;;; my cells are two bytes, that means multiplying item on top of 839 | ;;; stack by two (shift left). 840 | docells 841 | asl stackbase+1,x 842 | rol stackbase+2,x 843 | jmp next 844 | 845 | 846 | 847 | dovariable 848 | ;; grab next word from the input buffer 849 | jsr readnext ; next word from input buffer into WORD 850 | 851 | ;; copy word from WORD 852 | lda WORD ; first, copy the count 853 | sta (DP) 854 | tay ; store count in Y 855 | .( 856 | copynext ; now copy the rest of the word, backwards 857 | lda WORD,y ; copy Yth letter 858 | sta (DP),y ; store it in dictionary space 859 | dey ; count down to 0 860 | bne copynext 861 | .) 862 | 863 | lda (DP) ; set Y to next available byte 864 | tay 865 | iny 866 | 867 | ;; set link to location pointed to by DT 868 | lda DT 869 | sta (DP),y 870 | iny 871 | lda DT+1 872 | sta (DP),y 873 | iny 874 | 875 | ;; set code to dovaddr 876 | lda #dovaddr 880 | sta (DP),y 881 | iny 882 | 883 | iny ; bump twice more to allow parameter space 884 | iny ; for storage 885 | 886 | ;; set DT to new top entry, the one we've just created here 887 | lda DP 888 | sta DT 889 | lda DP+1 890 | sta DT+1 891 | 892 | clc ; update DP to next available space 893 | tya ; by adding bytes consumed to DP 894 | adc DP 895 | sta DP 896 | lda DP+1 897 | adc #0 898 | sta DP+1 899 | 900 | jmp next 901 | 902 | 903 | ;;; dohere implements "HERE" and just returns the pointer to the next 904 | ;;; available dictionary spot. 905 | dohere 906 | lda DP 907 | sta stackaccess 908 | lda DP+1 909 | sta stackaccess+1 910 | jsr push16 911 | jmp next 912 | 913 | 914 | ;;; ALLOT takes a number of bytes and bumps DP, which makes that many 915 | ;;; bytes available to whatever is at the top of the dictionary. It's 916 | ;;; used to allocate array space to variables. 917 | doallot 918 | jsr pop16 919 | clc 920 | lda DP 921 | adc stackaccess 922 | sta DP 923 | lda DP+1 924 | adc stackaccess+1 925 | sta DP+1 926 | jmp next 927 | 928 | 929 | ;;; Leave the system after printing a termination message. This 930 | ;;; just ends with an RTS, which should take us back to the monitor 931 | ;;; if we were called that way, or will crash things if we weren't, 932 | ;;; which has the same effect! 933 | dobye 934 | ldy #0 935 | .( 936 | next_char 937 | wait_txd_empty 938 | lda ACIA_STATUS 939 | and #$10 940 | beq wait_txd_empty 941 | lda exitmsg,y 942 | beq done 943 | sta ACIA_DATA 944 | iny 945 | jmp next_char 946 | done 947 | rts 948 | .) 949 | 950 | 951 | 952 | ;;; 953 | ;;; TEXT INTERPRETER 954 | ;;; 955 | ;;; For the moment, this is a basically a stopgap. The real FORTH 956 | ;;; text interpreter has many individual components that manifest 957 | ;;; themselves as words in the dictionary, and we'll get there. 958 | ;;; (The fact that the text interpreter is called QUIT in true Forth 959 | ;;; is the ultimate testement to Chuck Moore's twisted nature.) 960 | ;;; This is just something to get us going. Again, much borrowed here 961 | ;;; from the code of the monitor. 962 | ;;; 963 | 964 | 965 | 966 | ;;; initialize the interpreter 967 | ;;; 968 | startinterp 969 | 970 | ;; set up buffer (nothing to do) 971 | 972 | ;; set up buffer pointer (current pointer within text buffer) 973 | stz TPTR 974 | 975 | ;; set up buffer counter (number of characters input) 976 | stz TCNT 977 | 978 | ;; print greeting 979 | ldy #0 980 | .( 981 | next_char 982 | wait_txd_empty 983 | lda ACIA_STATUS 984 | and #$10 985 | beq wait_txd_empty 986 | lda greeting,y 987 | beq interploop 988 | sta ACIA_DATA 989 | iny 990 | jmp next_char 991 | .) 992 | 993 | 994 | interploop 995 | 996 | ;; get the next input word into WORD, potentially refilling 997 | ;; the text buffer in the process 998 | jsr readnext 999 | 1000 | ;; check for match 1001 | 1002 | matchword 1003 | ;; set up search by initializing dictionary pointer 1004 | lda DT 1005 | sta DPTR 1006 | lda DT+1 1007 | sta DPTR+1 1008 | 1009 | nextentry 1010 | ;; have we run out of dictionary entries? (when DPTR is $0000) 1011 | lda DPTR 1012 | bne compareentry 1013 | lda DPTR+1 1014 | beq nomatch 1015 | 1016 | compareentry 1017 | ;; compare words. counted strings can be compared directly, will compare 1018 | ;; counts first. But we need to mask out the tags in the count. 1019 | 1020 | ldy #0 1021 | lda (DPTR),y 1022 | and #%00011111 ; mask off the tags 1023 | cmp WORD,y ; compare word lengths 1024 | bne trynext ; no match 1025 | 1026 | ;; now compare words. do this from the end (for easier testing) 1027 | ldy WORD 1028 | .( 1029 | nextchar 1030 | lda (DPTR),y 1031 | cmp WORD,y 1032 | bne trynext 1033 | dey 1034 | bne nextchar 1035 | .) 1036 | ;; successful match! 1037 | bra gotmatch 1038 | 1039 | ;; loop to next entry 1040 | trynext 1041 | lda (DPTR) ; get word length... 1042 | tay ; store in Y, and add one... 1043 | iny ; for the pointer to the next entry 1044 | lda (DPTR),y ; update DPTR to point to next entry 1045 | sta SCRATCH 1046 | iny 1047 | lda (DPTR),y 1048 | sta DPTR+1 1049 | lda SCRATCH 1050 | sta DPTR 1051 | bra nextentry 1052 | 1053 | ;; we found a match for a word to execute. Set up the context 1054 | ;; and call NEXT to get started. 1055 | gotmatch 1056 | 1057 | ;; DPTR stores the start of the entry for the word to execute. 1058 | ;; So its code word is at (DPTR) + wordlength + 1 (len) + 2 (link) 1059 | lda (DPTR) ; word length 1060 | and #%00011111 ; mask off tag bits 1061 | inc ; +1 for the length byte 1062 | inc 1063 | inc ; + 2 more for the link word 1064 | clc 1065 | adc DPTR ; add to address and store in dummy word entry 1066 | sta dummyparam 1067 | lda DPTR+1 1068 | adc #$0 1069 | sta dummyparam+1 1070 | 1071 | ;; put the dummy parameter address into IP (actually, the code 1072 | ;; address because NEXT will inc it). 1073 | lda #dummycode 1076 | sta IP+1 1077 | 1078 | ;; jump to NEXT to start running it 1079 | jmp next 1080 | 1081 | ;; we didn't find a match in the dictionary, so see if we can parse 1082 | ;; it as a number. 1083 | nomatch 1084 | ;; before we do the conversion, check that all the letters are digits 1085 | 1086 | ldy WORD 1087 | numcheck 1088 | lda WORD,y 1089 | cmp #$30 1090 | bcc nointerpret ; BCC = branch if less than 1091 | cmp #$40 1092 | bcs nointerpret ; BCS = branch if greater or equal 1093 | dey 1094 | bne numcheck 1095 | 1096 | ;; convert number and put it on the stack 1097 | ;; my routines for this us a null-terminated string, so add a null 1098 | ldy WORD 1099 | iny 1100 | lda #0 1101 | sta WORD,y ; add a null 1102 | lda #WORD 1105 | sta stackaccess+1 1106 | .( 1107 | inc stackaccess ; bump it by one to avoid the count 1108 | bne done 1109 | inc stackaccess+1 1110 | done 1111 | .) 1112 | jsr push16 1113 | jsr readdec16 ; convert it, leave it on the stack 1114 | jmp interploop 1115 | 1116 | ;; if we get here, we couldn't find a match, nor could we read it as 1117 | ;; a number. there's no interpretation, so issue an error, flush 1118 | ;; the input, and loop 1119 | nointerpret 1120 | 1121 | ;; print an error, in three stages. first, a space; then, the 1122 | ;; undefined word; finally, the error message. 1123 | 1124 | .( 1125 | wait_txd_empty3 1126 | lda ACIA_STATUS 1127 | and #$10 1128 | beq wait_txd_empty3 1129 | lda #$20 1130 | sta ACIA_DATA 1131 | .) 1132 | 1133 | ldy #1 1134 | .( 1135 | next_char 1136 | wait_txd_empty3 1137 | lda ACIA_STATUS 1138 | and #$10 1139 | beq wait_txd_empty3 1140 | lda WORD,y 1141 | sta ACIA_DATA 1142 | iny 1143 | cpy WORD 1144 | bcc next_char 1145 | beq next_char 1146 | .) 1147 | 1148 | ldy #0 1149 | .( 1150 | next_char 1151 | wait_txd_empty 1152 | lda ACIA_STATUS 1153 | and #$10 1154 | beq wait_txd_empty 1155 | lda cantinterpret,y 1156 | beq nextstr 1157 | sta ACIA_DATA 1158 | iny 1159 | bra next_char 1160 | nextstr 1161 | .) 1162 | 1163 | ;; flush input. 1164 | lda TCNT 1165 | sta TPTR ; wait... off by one? 1166 | jmp interploop 1167 | 1168 | 1169 | ;;; readnext 1170 | ;;; read the next word into the area at WORD, potentially refilling 1171 | ;;; the entire buffer in the process. 1172 | ;;; this is a subroutine so that I can also use it in dovariable, 1173 | ;;; although it is mainly used by the text interpreter. 1174 | readnext 1175 | ;; if no more input, ->nomoreinput 1176 | 1177 | lda TPTR ; current pointer 1178 | cmp TCNT ; is that as much text as was read? 1179 | beq nomoreinput ; if yes, print prompt and get more 1180 | 1181 | tay ; put TPTR into Y 1182 | interpword 1183 | ;; begin loop 1184 | 1185 | .( 1186 | ;; look for next word 1187 | lda INPUT,y 1188 | cmp #$20 ; space 1189 | beq nextchar 1190 | cmp #$09 ; tab 1191 | beq nextchar 1192 | bne readword ; not white space, so go and read a word 1193 | 1194 | ;; continue skipping past space 1195 | nextchar 1196 | iny 1197 | cpy TCNT 1198 | beq nomoreinput 1199 | bra interpword 1200 | .) 1201 | 1202 | ;; no more input -- we have exhausted the text buffer. refill. 1203 | nomoreinput 1204 | jsr okcrlf ; signal completion 1205 | refill 1206 | jsr readline ; read another line of text 1207 | stz TPTR ; reset the pointer 1208 | bra readnext ; loop around 1209 | 1210 | ;; we have detected the start of a non-space sequence. read a word 1211 | ;; into a counted string at WORD. 1212 | readword 1213 | .( 1214 | stz WORD 1215 | phx 1216 | ldx #1 ; X starts at 1 because 0 is the count 1217 | nextchar 1218 | lda INPUT,y 1219 | beq doneword ; done if we hit NULL 1220 | cmp #$20 1221 | beq doneword ; done if we hit space 1222 | cmp #$09 1223 | beq doneword ; done if we hit tab 1224 | sta WORD,x ; X starts at 1 because 0 is the count 1225 | stx WORD 1226 | iny 1227 | cpy TCNT ; run off the end of the buffer? 1228 | beq doneword 1229 | inx 1230 | bra nextchar 1231 | doneword 1232 | plx 1233 | sty TPTR ; update the pointer (and free up Y) 1234 | .) 1235 | rts 1236 | 1237 | 1238 | 1239 | 1240 | ;;; Read a new line into the INPUT buffer 1241 | ;;; 1242 | readline 1243 | ldy #0 1244 | stz TCNT ; reset the counter 1245 | readchar 1246 | .( 1247 | wait_rxd_full 1248 | lda ACIA_STATUS 1249 | and #$08 1250 | beq wait_rxd_full 1251 | .) 1252 | lda ACIA_DATA 1253 | cmp #$08 ; check for backspace 1254 | beq backspace 1255 | cmp #$0D ; check for newline 1256 | beq doneline 1257 | sta INPUT,y ; track the input 1258 | iny 1259 | jsr puta ; echo the typed character 1260 | jmp readchar ; loop to repeat 1261 | backspace 1262 | cpy #0 ; beginning of line? 1263 | beq readchar 1264 | dey ; if not, go back one character 1265 | jsr puta ; move cursor back 1266 | jmp readchar 1267 | 1268 | ;; this is where we land if the line input has finished 1269 | ;; 1270 | doneline 1271 | lda #0 1272 | sta INPUT,y ; add a null terminator 1273 | sty TCNT ; update character count 1274 | rts 1275 | 1276 | 1277 | 1278 | 1279 | 1280 | ;;; 1281 | ;;; test harness 1282 | 1283 | gotest 1284 | ;;; initialize the stack. 5 on top, then 4, then 2, 2, 2. 1285 | lda #$02 1286 | sta stackaccess 1287 | stz stackaccess+1 1288 | jsr push16 1289 | jsr push16 1290 | jsr push16 1291 | lda #04 1292 | sta stackaccess 1293 | jsr push16 1294 | lda #05 1295 | sta stackaccess 1296 | jsr push16 1297 | 1298 | ;;; load the instruction pointer 1299 | ;;; pretend we are executing the first "line" of "meta" 1300 | ; lda #d4code 1303 | ; sta IP+1 1304 | ;;; pretend we are executing the first "line" of "meta2" 1305 | lda #d8code 1308 | sta IP+1 1309 | 1310 | ;;; go -- fetch the address indirectly through the IP 1311 | lda (IP) 1312 | sta CODEVEC 1313 | ldy #1 1314 | lda (IP),y 1315 | sta CODEVEC+1 1316 | 1317 | ;; before we jump, reset the IP 1318 | ; lda #d4param 1321 | ; sta IP+1 1322 | lda #d8param 1325 | sta IP+1 1326 | 1327 | jmp (CODEVEC) 1328 | 1329 | ;;; stop 1330 | 1331 | 1332 | 1333 | ;;; 1334 | ;;; support routines 1335 | ;;; 1336 | 1337 | rpush 1338 | lda stackaccess 1339 | sta (RP) 1340 | inc RP 1341 | lda stackaccess+1 1342 | sta (RP) 1343 | inc RP ; BUG presumes that RP doesn't roll over page boundary 1344 | rts 1345 | 1346 | 1347 | rpull 1348 | dec RP 1349 | dec RP 1350 | ldy #1 1351 | lda (RP),y 1352 | sta stackaccess+1 1353 | lda (RP) 1354 | sta stackaccess 1355 | rts 1356 | 1357 | 1358 | 1359 | ;;; 1360 | ;;; I/O SUPPORT ROUTINES 1361 | ;;; These have been "borrowed" from mitemon 1362 | ;;; 1363 | 1364 | putax 1365 | .( 1366 | phy 1367 | 1368 | pha 1369 | wait_txd_empty 1370 | lda ACIA_STATUS 1371 | and #$10 1372 | beq wait_txd_empty 1373 | pla 1374 | pha ; put a copy back 1375 | clc 1376 | and #$f0 1377 | ror 1378 | ror 1379 | ror 1380 | ror 1381 | tay 1382 | lda hextable,y 1383 | sta ACIA_DATA 1384 | wait_txd_empty2 1385 | lda ACIA_STATUS 1386 | and #$10 1387 | beq wait_txd_empty2 1388 | pla 1389 | clc 1390 | and #$0f 1391 | tay 1392 | lda hextable,y 1393 | sta ACIA_DATA 1394 | .) 1395 | ply 1396 | rts 1397 | 1398 | 1399 | puta 1400 | .( 1401 | pha 1402 | wait_txd_empty 1403 | lda ACIA_STATUS 1404 | and #$10 1405 | beq wait_txd_empty 1406 | pla 1407 | sta ACIA_DATA 1408 | .) 1409 | rts 1410 | 1411 | okcrlf 1412 | ldy #0 1413 | .( 1414 | next_char 1415 | wait_txd_empty 1416 | lda ACIA_STATUS 1417 | and #$10 1418 | beq wait_txd_empty 1419 | lda ok,y 1420 | beq done 1421 | sta ACIA_DATA 1422 | iny 1423 | jmp next_char 1424 | done 1425 | rts 1426 | .) 1427 | 1428 | 1429 | crlf 1430 | pha 1431 | .( 1432 | wait_txd_empty 1433 | lda ACIA_STATUS 1434 | and #$10 1435 | beq wait_txd_empty 1436 | .) 1437 | lda #$0d 1438 | sta ACIA_DATA 1439 | .( 1440 | wait_txd_empty 1441 | lda ACIA_STATUS 1442 | and #$10 1443 | beq wait_txd_empty 1444 | .) 1445 | lda #$0a 1446 | sta ACIA_DATA 1447 | pla 1448 | rts 1449 | 1450 | 1451 | hextable: .byte "0123456789ABCDEF" 1452 | greeting .byte "SECND Forth v02 (Paul Dourish, 2017-12)", $00 1453 | ok: .byte " OK", $0d, $0a, $00 1454 | cantinterpret: .byte ": not defined", $0d, $0a, $00 1455 | match: .byte " match!", $00 1456 | exitmsg: .byte $0d, $0a, $0d, $0a, "Exiting.", $0d, $0a, $00 1457 | -------------------------------------------------------------------------------- /secnd3.a65: -------------------------------------------------------------------------------- 1 | 2 | ;;; 3 | ;;; SECND - A FORTH FOR 6502 4 | ;;; 5 | ;;; Since "FORTH" is actually an abbreviation of "FOURTH", "SECND" 6 | ;;; is an abbreviation of "SECOND", it being my second FORTH 7 | ;;; implementation. The last one was over 30 years ago, but let's 8 | ;;; not worry about that now. This time, I'm sticking closer to 9 | ;;; standards, albeit outdated ones; the starting point for this 10 | ;;; is FigFORTH although it may get ANSIfied along the way. 11 | ;;; 12 | ;;; I'm building this for my single-board 6502 computer, the Mite. 13 | ;;; For now at least, this is written to be loaded in RAM. 14 | ;;; 15 | ;;; Paul Dourish, December 2017 16 | ;;; 17 | ;;; Version history: 18 | ;;; v01 first basic version of interpreter up and running 19 | ;;; v02 adding R-stack operators, variables, arrays, allot. 20 | ;;; v03 first steps for compiler, basic lists, strings, loops, conditionals 21 | 22 | 23 | * = $0300 24 | 25 | ;;; 26 | ;;; Variables/space setup 27 | ;;; 28 | 29 | SCRATCH = $0010 ; through to $001F (adopted from monitor) 30 | 31 | ;;; MEMORY MAP 32 | ;;; 33 | ;;; 0000 through 004F is reserved for the monitor (reusing SCRATCH) 34 | ;;; 0050 through 007F is available for variables (below) 35 | ;;; 0080 through 00FF is operand stack 36 | ;;; 0100 through 01FF is the hardware stack as usual 37 | ;;; 0200 through 02FF is the return stack (more space than needed) 38 | ;;; 0300 through 11FF is the interpreter and compiler code (this file) 39 | ;;; 1200 through 77FF is user dictionary space 40 | ;;; 7800 through 7DFF is CURRENTLY UNASSIGNED 41 | ;;; 7E00 through 7EBF is the PAD (string assembly area) 42 | ;;; 7EC0 through 7EFF is temporary string processing space 43 | ;;; 7F00 through 7FFF is the input buffer (TIB) 44 | 45 | ;;; 46 | ;;; KEY SYSTEM VARIABLES 47 | ;;; 48 | ;;; IP is the instruction pointer 49 | ;;; DT (dictionary top) pointer to start (actually, end) of dictionary 50 | ;;; RP is return stack pointer 51 | ;;; XT holds execution token of currently executing word 52 | ;;; CODEVEC holds the location of the code for the next instruction 53 | ;;; DP holds pointer to the next available dictionary space 54 | ;;; TPTR holds the offset of the most recently processed input character 55 | ;;; TCNT holds the number of characters held in the buffer 56 | ;;; DPTR is an internal variable for traversing the dictionary 57 | ;;; STATUS is the system status flags (e.g. compilation flag) 58 | ;;; CWORD holds a pointer to the word currently being compiled 59 | ;;; INPUT points to the input buffer 60 | ;;; WORD points to the temporary string processing space 61 | ;;; 62 | ;;; 63 | IP=$0050 ; and 0051 64 | RP=$0052 ; and 0053 65 | DT=$0054 ; and 0055 66 | XT=$0056 ; and 0057 67 | CODEVEC=$0058 ; and 0059 68 | TPTR=$005A 69 | TCNT=$005B 70 | DPTR=$005C ; and 005D 71 | DP=$005E ; and 005F 72 | STATUS=$0060 ; status word 73 | CWORD=$0061 ; and 0062 74 | PADPTR=$0063 ; and 0064 75 | PAD=$7E00 ; PAD (string assembly area) 76 | WORD=$7EC0 ; temporary space for parsing words (max 63 chars) 77 | INPUT=$7F00 ; input space 78 | 79 | COMPILE=%00000001 ; status flags 80 | 81 | IMM=%00100000 ; flag for IMMEDIATE word (ie executed in compile mode) 82 | 83 | jmp coldstart ; jump past code defined in stack routines 84 | 85 | #include "../mitemon/decl.a65" 86 | #include "../mitemon/stack.a65" 87 | 88 | 89 | ;;; 90 | ;;; initialization and configuration 91 | ;;; 92 | coldstart 93 | ;; initialize stack... 94 | jsr initstack 95 | 96 | ;; initialize variables... 97 | 98 | ;; IP is the Forth instruction pointer 99 | stz IP 100 | stz IP+1 101 | 102 | stz STATUS ; turn of compilation 103 | 104 | ;; Initialize the return stack. I'm just putting that on page 2, 105 | ;; growing upwards, until I have a better idea. 106 | stz RP 107 | lda #$02 108 | sta RP+1 109 | 110 | ;; Initialize DT to the last entry on the dictionary (below) 111 | lda #dtop 114 | sta DT+1 115 | 116 | ;; Initialize DP to the first available dictionary space ($1200) 117 | lda #$00 118 | sta DP 119 | lda #$12 120 | sta DP+1 121 | 122 | ;; jump to text interpreter 123 | jmp startinterp 124 | 125 | 126 | 127 | ;;; 128 | ;;; DICTIONARY 129 | ;;; 130 | ;;; Each entry in the dictionary comprises: 131 | ;;; - one byte that is both tags (three upper bits) and word length 132 | ;;; five lower bits) 133 | ;;; - the characters making up the word definition name 134 | ;;; - pointer to next entry 135 | ;;; - the "code word" (address of code handling this instruction, which 136 | ;;; will often be DOLIST for compiled words) 137 | ;;; - the parameter space (often the list of addresses for executing 138 | ;;; this word, and often ending with EXIT) 139 | ;;; 140 | 141 | d0entry 142 | .byte 4 143 | .byte "exit" 144 | d0link 145 | .word $0000 146 | exitcode 147 | d0code 148 | .word exit 149 | 150 | d1entry 151 | .byte 1 152 | .byte "+" 153 | d1link 154 | .word d0entry 155 | d1code 156 | .word doplus 157 | 158 | d2entry 159 | .byte 1 160 | .byte "*" 161 | d2link 162 | .word d1entry 163 | d2code 164 | .word dotimes 165 | 166 | d3entry 167 | .byte 7 168 | .byte "0branch" 169 | d3link 170 | .word d2entry 171 | zerobracode 172 | d3code 173 | .word dozerobra 174 | 175 | d4entry 176 | .byte 4 177 | .byte "test" 178 | d4link 179 | .word d3entry 180 | d4code 181 | .word dolist 182 | d4param 183 | .word zerobracode 184 | .word $0008 185 | .word dotquotecode 186 | .byte 3 187 | .byte "yes" 188 | .word d0code 189 | 190 | d5entry 191 | .byte 5 192 | .byte "dolit" 193 | d5link 194 | .word d4entry 195 | dolitcode 196 | d5code 197 | .word dolit 198 | 199 | d6entry 200 | .byte 1 201 | .byte "." 202 | d6link 203 | .word d5entry 204 | d6code 205 | .word doprint 206 | 207 | d7entry 208 | .byte 5 209 | .byte "twice" 210 | d7link 211 | .word d6entry 212 | d7code 213 | .word dolist 214 | d7param 215 | .word d5code ; code for dolit 216 | .word 0002 217 | .word d2code 218 | .word d0code 219 | 220 | d8entry 221 | .byte %00100110 ; IMM + code for 6 222 | .byte "branch" 223 | d8link 224 | .word d7entry 225 | branchcode 226 | d8code 227 | .word dobranch 228 | 229 | d9entry 230 | .byte 3 231 | .byte "dup" 232 | d9link 233 | .word d8entry 234 | d9code 235 | .word dodup 236 | 237 | d10entry 238 | .byte 4 239 | .byte "swap" 240 | d10link 241 | .word d9entry 242 | d10code 243 | .word doswap 244 | 245 | d11entry 246 | .byte 4 247 | .byte "drop" 248 | d11link 249 | .word d10entry 250 | d11code 251 | .word dodrop 252 | 253 | d12entry 254 | .byte 1 255 | .byte "/" 256 | d12link 257 | .word d11entry 258 | d12code 259 | .word dodiv 260 | 261 | d13entry 262 | .byte 3 263 | .byte "mod" 264 | d13link 265 | .word d12entry 266 | d13code 267 | .word domod 268 | 269 | d14entry 270 | .byte 1 271 | .byte "=" 272 | d14link 273 | .word d13entry 274 | d14code 275 | .word doequal 276 | 277 | d15entry 278 | .byte 5 279 | .byte "depth" 280 | d15link 281 | .word d14entry 282 | d15code 283 | .word dodepth 284 | 285 | d16entry 286 | .byte 1 287 | .byte ">" 288 | d16link 289 | .word d15entry 290 | d16code 291 | .word dogreater 292 | 293 | d17entry 294 | .byte 1 295 | .byte "<" 296 | d17link 297 | .word d16entry 298 | d17code 299 | .word doless 300 | 301 | d18entry 302 | .byte 2 303 | .byte "cr" 304 | d18link 305 | .word d17entry 306 | d18code 307 | .word docr 308 | 309 | d19entry 310 | .byte 4 311 | .byte "emit" 312 | d19link 313 | .word d18entry 314 | d19code 315 | .word doemit 316 | 317 | d20entry 318 | .byte 4 319 | .byte "over" 320 | d20link 321 | .word d19entry 322 | d20code 323 | .word doover 324 | 325 | d21entry 326 | .byte 3 327 | .byte "rot" 328 | d21link 329 | .word d20entry 330 | d21code 331 | .word dorot 332 | 333 | d22entry 334 | .byte 7 335 | .byte "testvar" 336 | d22link 337 | .word d21entry 338 | d22code 339 | .word dovaddr 340 | d22param 341 | .word $1234 342 | 343 | d23entry 344 | .byte 1 345 | .byte "@" 346 | d23link 347 | .word d22entry 348 | d23code 349 | .word dofetch 350 | 351 | d24entry 352 | .byte 2 353 | .byte "c@" 354 | d24link 355 | .word d23entry 356 | d24code 357 | .word docfetch 358 | 359 | d25entry 360 | .byte 1 361 | .byte "!" 362 | d25link 363 | .word d24entry 364 | d25code 365 | .word dostore 366 | 367 | d26entry 368 | .byte 2 369 | .byte "c!" 370 | d26link 371 | .word d25entry 372 | d26code 373 | .word docstore 374 | 375 | d27entry 376 | .byte 5 377 | .byte "cells" 378 | d27link 379 | .word d26entry 380 | d27code 381 | .word docells 382 | 383 | d28entry 384 | .byte 8 385 | .byte "variable" 386 | d28link 387 | .word d27entry 388 | d28code 389 | .word dovariable 390 | 391 | d29entry 392 | .byte 1 393 | .byte "-" 394 | d29link 395 | .word d28entry 396 | d29code 397 | .word dominus 398 | 399 | d30entry 400 | .byte 4 401 | .byte "here" 402 | d30link 403 | .word d29entry 404 | d30code 405 | .word dohere 406 | 407 | d31entry 408 | .byte 5 409 | .byte "allot" 410 | d31link 411 | .word d30entry 412 | d31code 413 | .word doallot 414 | 415 | d32entry 416 | .byte 3 417 | .byte "bye" 418 | d32link 419 | .word d31entry 420 | d32code 421 | .word dobye 422 | 423 | d33entry 424 | .byte 1 425 | .byte ":" 426 | d33link 427 | .word d32entry 428 | d33code 429 | .word docolon 430 | 431 | d34entry 432 | .byte %00100001 ; set the immediate bit plus count of 1 433 | .byte ";" 434 | d34link 435 | .word d33entry 436 | d34code 437 | .word dosemic 438 | 439 | d35entry 440 | .byte 2 441 | .byte ">r" 442 | d35link 443 | .word d34entry 444 | d35code 445 | .word dotor 446 | 447 | d36entry 448 | .byte 2 449 | .byte "r>" 450 | d36link 451 | .word d35entry 452 | d36code 453 | .word dofromr 454 | 455 | d37entry 456 | .byte 2 457 | .byte "r@" 458 | d37link 459 | .word d36entry 460 | d37code 461 | .word dorcopy 462 | 463 | d38entry 464 | .byte 1 465 | .byte "i" 466 | d38link 467 | .word d37entry 468 | d38code 469 | .word dorcopy 470 | 471 | d39entry 472 | .byte %00100010 ; IMM flag plus count of two 473 | .byte $2e, $22 ; dot, quote (.") 474 | d39link 475 | .word d38entry 476 | dotquotecode 477 | d39code 478 | .word dodotqu 479 | 480 | d40entry 481 | .byte %00100010 ; IMM flag plus count of two 482 | .byte "if" 483 | d40link 484 | .word d39entry 485 | d40code 486 | .word doif 487 | 488 | d41entry 489 | .byte %00100100 ; IMM flag plus count of four 490 | .byte "then" 491 | d41link 492 | .word d40entry 493 | d41code 494 | .word dothen 495 | 496 | d42entry 497 | .byte %00100101 ; IMM flag plus count of five 498 | .byte "begin" 499 | d42link 500 | .word d41entry 501 | d42code 502 | .word dobegin 503 | 504 | d43entry 505 | .byte %00100101 ; IMM flag plus count of five 506 | .byte "until" 507 | d43link 508 | .word d42entry 509 | d43code 510 | .word dountil 511 | 512 | d44entry 513 | .byte %00100100 ; IMM plus count of four 514 | .byte "else" 515 | d44link 516 | .word d43entry 517 | d44code 518 | .word doelse 519 | 520 | d45entry 521 | .byte 5 522 | .byte "words" 523 | d45link 524 | .word d44entry 525 | d45code 526 | .word dowords 527 | 528 | d46entry 529 | .byte %00100010 ; IMM plus count of two 530 | .byte "do" 531 | d46link 532 | .word d45entry 533 | d46code 534 | .word dodo 535 | 536 | d47entry 537 | .byte 4 538 | .byte "(do)" 539 | d47link 540 | .word d46entry 541 | parendocode 542 | d47code 543 | .word doparendo 544 | 545 | d48entry 546 | .byte %00100100 ; IMM plus count of four 547 | .byte "loop" 548 | d48link 549 | .word d47entry 550 | d48code 551 | .word doloop 552 | 553 | dtop 554 | d49entry 555 | .byte 6 556 | .byte "(loop)" 557 | d49link 558 | .word d48entry 559 | parenloopcode 560 | d49code 561 | .word doparenloop 562 | 563 | ;; TOP OF DICTIONARY 564 | 565 | 566 | ;;; 567 | ;;; The words below are my experiment on calling things and getting 568 | ;;; back to the interpreter. Dummy is the word we'll enter in order to 569 | ;;; execute something; the point of it is to make sure that after we've 570 | ;;; executed what we want, we run "doquitword", which should take us 571 | ;;; back into the interpreter loop 572 | ;;; 573 | 574 | 575 | doquitword 576 | .byte 0 577 | doquitlink 578 | .word $0000 579 | doquitcode 580 | .word interploop 581 | 582 | dummy 583 | .byte 0 584 | dummylink 585 | .word $0000 586 | dummycode 587 | .word dolist ; won't actually run this, start with NEXT instead 588 | dummyparam 589 | .word $0000 ; will write in the actual code link word here 590 | dummyexit 591 | .word doquitcode 592 | 593 | 594 | 595 | 596 | 597 | ;;; 598 | ;;; INNER INTERPRETER 599 | ;;; 600 | ;;; The three routines below -- NEXT, DOLIST, and EXIT -- are the core 601 | ;;; of the inner interpreter, which executes stored words. 602 | ;;; 603 | ;;; NEXT moves from one instruction to the next inside a defined word. 604 | ;;; This code is included at the end of each assembly language routine 605 | ;;; (or rather, we jump to it). 606 | ;;; 607 | ;;; DOLIST begins the execution of a compiled word. It stores the IP 608 | ;;; on the return stack, resets the IP to the new word, and then calls 609 | ;;; NEXT to start on it. 610 | ;;; 611 | ;;; EXIT is compiled in as the last address of each compiled word. It 612 | ;;; undoes what DOLIST has done, and moves back to the earlier execution 613 | ;;; context. 614 | ;;; 615 | ;;; Note that none of these are subroutines -- everything is connected 616 | ;;; as direct jumps (actually, indirect jumps!) with the RSTACK used 617 | ;;; to keep track of what's going on. 618 | 619 | 620 | 621 | ;;; DOLIST is the executing code for a colon-defined word. 622 | dolist 623 | ;; first, push the current instruction pointer onto the 624 | ;; return stack 625 | ;; NB-- this was previously done via jsr rpush but I unrolled it 626 | ;; here to save some loads/stores and a JSR. Old code is left in 627 | ;; comments as documentation. 628 | lda IP 629 | sta (RP) 630 | inc RP 631 | lda IP+1 632 | sta (RP) 633 | inc RP 634 | 635 | ;; next, grab the first address in the parameter block for this 636 | ;; colon-defined word. We know that XT points to the code word. 637 | ;; so we grab that address and then add one cell (two bytes) 638 | ;; store this in IP. 639 | 640 | clc 641 | lda XT 642 | adc #$2 643 | sta IP 644 | lda XT+1 645 | adc #0 646 | sta IP+1 647 | 648 | ; DELETE THIS LATER 649 | ; lda (IP) 650 | ; sta SCRATCH 651 | ; ldy #1 652 | ; lda (IP),y 653 | ; sta IP+1 654 | ; lda SCRATCH 655 | ; sta IP 656 | 657 | ;; IP now points to the next isntruction we want to execute, in 658 | ;; this word. Proceed to execute it. 659 | ;jmp next ; commented out because we can just fall through 660 | 661 | ;;; ** PUT NOTHING HERE... depending on fall-through from DOLIST to NEXT! 662 | 663 | ;;; NEXT executes the next word. Before it does the jump, it increments 664 | ;;; IP so that IP always designates the next word to be executed. 665 | next 666 | ldy #0 ; IP points to the location storing the next 667 | lda (IP),y ; word we need to execute. fetch that location, 668 | sta XT ; and store it in XT. 669 | iny 670 | lda (IP),y 671 | sta XT+1 672 | 673 | lda (XT),y ; TMP contains a pointer to a code word. Load 674 | sta CODEVEC+1 ; the code address stored there into CODEVEC. 675 | dey 676 | lda (XT) 677 | sta CODEVEC 678 | 679 | ;; increment IP before we move on 680 | .( 681 | inc IP ; lower byte first 682 | bne continue ; skip upper byte if we haven't rolled over 683 | inc IP+1 684 | continue 685 | .) 686 | .( 687 | inc IP ; now same again, because we need to inc by 2 688 | bne continue 689 | inc IP+1 690 | continue 691 | .) 692 | 693 | jmp (CODEVEC) ; execute the code for this instruction/word 694 | 695 | 696 | 697 | ;;; EXIT is the routine that is called at the end of each colon-defined 698 | ;;; word (it's compiled in as the last address to be called). It undoes 699 | ;;; DOLIST... it removes an address from the return stack, puts it back 700 | ;;; as the instruction pointer, and calls next. 701 | exit 702 | ;; formerly, jsr rpull, now unrolled. 703 | dec RP ; take two bytes off the return stack 704 | dec RP 705 | ldy #1 ; now take the value that was on the return stack 706 | lda (RP),y ; and place it in the instruction pointer 707 | sta IP+1 708 | lda (RP) 709 | sta IP 710 | jmp next ; go execute the next instruction 711 | 712 | 713 | ;;; 714 | ;;; PRIMITIVES 715 | ;;; 716 | 717 | doplus 718 | jsr add16 719 | jmp next 720 | 721 | dominus 722 | jsr sub16 723 | jmp next 724 | 725 | dotimes 726 | jsr mult16 727 | jmp next 728 | 729 | dodiv 730 | jsr div16 731 | jmp next 732 | 733 | domod 734 | jsr mod16 735 | jmp next 736 | 737 | doprint 738 | jsr print16dec 739 | jmp next 740 | 741 | docr 742 | jsr crlf 743 | jmp next 744 | 745 | dodup 746 | jsr dup16 747 | jmp next 748 | 749 | dodrop 750 | jsr pop16 751 | jmp next 752 | 753 | doswap 754 | jsr swap16 755 | jmp next 756 | 757 | doequal 758 | .( 759 | lda stackbase+1,x 760 | cmp stackbase+3,x 761 | bne notequal 762 | lda stackbase+2,x 763 | cmp stackbase+4,x 764 | bne notequal 765 | equal 766 | inx 767 | inx 768 | lda #$01 769 | sta stackbase+1,x 770 | stz stackbase+2,x 771 | bra done 772 | notequal 773 | inx 774 | inx 775 | stz stackbase+1,x 776 | stz stackbase+2,x 777 | done 778 | .) 779 | jmp next 780 | 781 | ;; on the 6502, there's no simple "greater than" instruction; 782 | ;; BCS is "greater than or equal to". So, use BCC for "less than" 783 | ;; and invert result. also need different tests for upper and 784 | ;; lower bytes. This is also confused by the fact that the item that's 785 | ;; "lower" on the stack is higher in memory. 786 | dogreater 787 | .( 788 | lda stackbase+4,x ; most significant byte 789 | cmp stackbase+2,x ; is "lower" on stack less than "upper"? 790 | beq testlsb ; equal, so go to lower byte 791 | bmi notgreater ; less than, so answer is "no" 792 | bra greater ; greater than, so answer is "yes" 793 | testlsb 794 | lda stackbase+3,x ; less signficant byte 795 | cmp stackbase+1,x ; is "higher" on stack less than "lower"? 796 | beq notgreater 797 | bmi notgreater 798 | greater 799 | inx 800 | inx 801 | lda #$01 802 | sta stackbase+1,x 803 | stz stackbase+2,x 804 | bra done 805 | notgreater 806 | inx 807 | inx 808 | stz stackbase+1,x 809 | stz stackbase+2,x 810 | done 811 | .) 812 | jmp next 813 | 814 | doless 815 | .( 816 | lda stackbase+4,x 817 | cmp stackbase+2,x 818 | bmi yes 819 | beq testlsb 820 | bra no 821 | testlsb 822 | lda stackbase+3,x 823 | cmp stackbase+1,x 824 | beq no 825 | bpl no 826 | yes 827 | inx 828 | inx 829 | lda #$01 830 | sta stackbase+1,x 831 | stz stackbase+2,x 832 | bra done 833 | no 834 | inx 835 | inx 836 | stz stackbase+1,x 837 | stz stackbase+2,x 838 | done 839 | .) 840 | jmp next 841 | 842 | dodepth 843 | stx SCRATCH 844 | lda #$ff 845 | sec 846 | sbc SCRATCH 847 | clc 848 | lsr 849 | stz stackbase,x 850 | dex 851 | sta stackbase,x 852 | dex 853 | jmp next 854 | 855 | doemit 856 | lda stackbase+1,x 857 | jsr puta 858 | inx 859 | inx 860 | jmp next 861 | 862 | doover 863 | dex 864 | dex 865 | lda stackbase+5,x 866 | sta stackbase+1,x 867 | lda stackbase+6,x 868 | lda stackbase+2,x 869 | jmp next 870 | 871 | dorot 872 | dex ; make some new space on the stack 873 | dex 874 | lda stackbase+7,x ; first, copy the item from three down on the stack 875 | sta stackbase+1,x ; into the new space 876 | lda stackbase+8,x ; so, 7/8 -> 1/2 877 | sta stackbase+2,x 878 | 879 | lda stackbase+5,x ; now move everything back 880 | sta stackbase+7,x ; first, 5/6 -> 7/8 881 | lda stackbase+6,x 882 | sta stackbase+8,x 883 | lda stackbase+3,x ; then 3/4 -> 5/6 884 | sta stackbase+5,x 885 | lda stackbase+4,x 886 | sta stackbase+6,x 887 | lda stackbase+1,x ; then 1/2 -> 3/4 888 | sta stackbase+3,x 889 | lda stackbase+2,x 890 | sta stackbase+4,x 891 | 892 | inx ; clean up 893 | inx 894 | 895 | jmp next 896 | 897 | 898 | ;;; DOLIT is the run-time code for literal values. Read the contents of 899 | ;;; the next parameter as a value to be pushed onto the stack. 900 | ;;; We enter with IP indicating the literal value; we increment IP 901 | ;;; by two bytes (one cell) so that skips to the next instruction to be 902 | ;;; executed. 903 | dolit 904 | ldy #0 ; load the value there 905 | lda (IP),y 906 | sta stackaccess ; and store in stackaccess 907 | iny ; (now the second byte) 908 | lda (IP),y 909 | sta stackaccess+1 910 | jsr push16 ; add to the data stack 911 | 912 | .( 913 | inc IP ; increment IP to next cell (which stores the value) 914 | bne continue 915 | inc IP+1 916 | continue 917 | .) 918 | .( 919 | inc IP 920 | bne continue 921 | inc IP+1 922 | continue 923 | .) 924 | jmp next 925 | 926 | 927 | ;;; dovaddr is the internal code for variables... look up the current 928 | ;;; XT and use it to find the address reserved for the variable, and 929 | ;;; push that. 930 | dovaddr 931 | lda XT 932 | sta stackaccess 933 | lda XT+1 934 | sta stackaccess+1 935 | .( 936 | inc stackaccess 937 | bne continue 938 | inc stackaccess+1 939 | continue 940 | .) 941 | .( 942 | inc stackaccess 943 | bne continue 944 | inc stackaccess+1 945 | continue 946 | .) 947 | jsr push16 948 | jmp next 949 | 950 | ;;; dofetch is the code for "@". Pull an address off the stack and 951 | ;;; look up the 16-bit data stored at that address 952 | dofetch 953 | jsr pop16 ; pop value into stackaccess 954 | dex ; make space on the stack 955 | dex 956 | ldy #1 957 | lda (stackaccess),y ; load MSB and store on stack 958 | sta stackbase+2,x ; store in the new space on the stack 959 | dey 960 | lda (stackaccess),y ; then LSB 961 | sta stackbase+1,x 962 | jmp next 963 | 964 | ;;; docfetch is the same as dofetch except for just one byte 965 | docfetch 966 | jsr pop16 ; pop value into stackaccess 967 | dex ; make space on the stack 968 | dex 969 | stz stackbase+2,x ; set MSB to zero 970 | lda (stackaccess) ; grab single byte 971 | sta stackbase+1,x ; and store in LSB 972 | jmp next 973 | 974 | 975 | ;;; dostore is the code for "!". Pull an address of the stack as in 976 | ;;; dofetch; but store the address pointed to by the next stack 977 | ;;; location in it. 978 | dostore 979 | jsr pop16 ; put address into stackaccess 980 | ldy #1 981 | lda stackbase+1,x ; load LSB off stack and 982 | sta (stackaccess) ; store at location we popped 983 | lda stackbase+2,x ; then for MSB 984 | sta (stackaccess),y ; with y=1 985 | inx ; drop the value from the stack 986 | inx 987 | jmp next 988 | 989 | ;;; cstore is just like store except stores just one byte (LSB from stack) 990 | docstore 991 | jsr pop16 ; put address into stackaccess 992 | lda stackbase+1,x ; load LSB off stack and 993 | sta (stackaccess) ; store at location we popped 994 | inx ; drop the value from the stack 995 | inx 996 | jmp next 997 | 998 | 999 | ;;; Turn an integer count of cells into a count of bytes. Since 1000 | ;;; my cells are two bytes, that means multiplying item on top of 1001 | ;;; stack by two (shift left). 1002 | docells 1003 | asl stackbase+1,x 1004 | rol stackbase+2,x 1005 | jmp next 1006 | 1007 | 1008 | ;;; variable reads the next word from input and allocates space 1009 | ;;; for it in the dictionary as a variable (ie with the "dovaddr" 1010 | ;;; code). 1011 | dovariable 1012 | ;; grab next word from the input buffer 1013 | jsr readnext ; next word from input buffer into WORD 1014 | 1015 | ;; copy word from WORD 1016 | lda WORD ; first, copy the count 1017 | sta (DP) 1018 | tay ; store count in Y 1019 | .( 1020 | copynext ; now copy the rest of the word, backwards 1021 | lda WORD,y ; copy Yth letter 1022 | sta (DP),y ; store it in dictionary space 1023 | dey ; count down to 0 1024 | bne copynext 1025 | .) 1026 | 1027 | lda (DP) ; set Y to next available byte 1028 | tay 1029 | iny 1030 | 1031 | ;; set link to location pointed to by DT 1032 | lda DT 1033 | sta (DP),y 1034 | iny 1035 | lda DT+1 1036 | sta (DP),y 1037 | iny 1038 | 1039 | ;; set code to dovaddr 1040 | lda #dovaddr 1044 | sta (DP),y 1045 | iny 1046 | 1047 | iny ; bump twice more to allow parameter space 1048 | iny ; for storage 1049 | 1050 | ;; set DT to new top entry, the one we've just created here 1051 | lda DP 1052 | sta DT 1053 | lda DP+1 1054 | sta DT+1 1055 | 1056 | clc ; update DP to next available space 1057 | tya ; by adding bytes consumed to DP 1058 | adc DP 1059 | sta DP 1060 | lda DP+1 1061 | adc #0 1062 | sta DP+1 1063 | 1064 | jmp next 1065 | 1066 | 1067 | ;;; dohere implements "HERE" and just returns the pointer to the next 1068 | ;;; available dictionary spot. 1069 | dohere 1070 | lda DP 1071 | sta stackaccess 1072 | lda DP+1 1073 | sta stackaccess+1 1074 | jsr push16 1075 | jmp next 1076 | 1077 | 1078 | ;;; ALLOT takes a number of bytes and bumps DP, which makes that many 1079 | ;;; bytes available to whatever is at the top of the dictionary. It's 1080 | ;;; used to allocate array space to variables. 1081 | doallot 1082 | jsr pop16 1083 | clc 1084 | lda DP 1085 | adc stackaccess 1086 | sta DP 1087 | lda DP+1 1088 | adc stackaccess+1 1089 | sta DP+1 1090 | jmp next 1091 | 1092 | 1093 | ;;; Leave the system after printing a termination message. This 1094 | ;;; just ends with an RTS, which should take us back to the monitor 1095 | ;;; if we were called that way, or will crash things if we weren't, 1096 | ;;; which has the same effect! 1097 | dobye 1098 | ldy #0 1099 | .( 1100 | next_char 1101 | wait_txd_empty 1102 | lda ACIA_STATUS 1103 | and #$10 1104 | beq wait_txd_empty 1105 | lda exitmsg,y 1106 | beq done 1107 | sta ACIA_DATA 1108 | iny 1109 | jmp next_char 1110 | done 1111 | rts 1112 | .) 1113 | 1114 | ;;; rcopy (for the Forth word "R") -- copy top of R stack onto data stack 1115 | ;;; 1116 | dorcopy 1117 | dec RP 1118 | lda (RP) 1119 | sta stackaccess+1 1120 | dec RP 1121 | lda (RP) 1122 | sta stackaccess 1123 | inc RP 1124 | inc RP 1125 | jsr push16 1126 | jmp next 1127 | 1128 | ;; dotor (for the Forth word ">R" -- move from top of stack onto r-stack 1129 | ;;; 1130 | dotor 1131 | jsr pop16 1132 | jsr rpush 1133 | jmp next 1134 | 1135 | ;; dofromr (for Forth word "R>" -- move from r-stack to top of stack 1136 | ;;; 1137 | dofromr 1138 | jsr rpull 1139 | jsr push16 1140 | jmp next 1141 | 1142 | ;;; docolon implements the colon-word... basically, acts like 1143 | ;;; variable in that it opens up a dictionary word, althogh this 1144 | ;;; time for a dolist definition. Also, it sets the compile flag. 1145 | ;;; 1146 | ;;; NB things will go wrong if we enconter a colon inside a colon 1147 | ;;; definition or start to process variables or something. We presume 1148 | ;;; that nothing is going to mess with DP while compilation is in 1149 | ;;; progress. 1150 | ;;; 1151 | docolon 1152 | ;; first, set the compiler flag 1153 | lda STATUS 1154 | ora #COMPILE 1155 | sta STATUS 1156 | 1157 | ;; grab next word from the input buffer 1158 | jsr readnext ; next word from input buffer into WORD 1159 | 1160 | ;; copy word from WORD 1161 | lda WORD ; first, copy the count 1162 | sta (DP) 1163 | tay ; store count in Y 1164 | .( 1165 | copynext ; now copy the rest of the word, backwards 1166 | lda WORD,y ; copy Yth letter 1167 | sta (DP),y ; store it in dictionary space 1168 | dey ; count down to 0 1169 | bne copynext 1170 | .) 1171 | 1172 | lda (DP) ; set Y to next available byte 1173 | tay 1174 | iny 1175 | 1176 | ;; set link to location pointed to by DT 1177 | lda DT 1178 | sta (DP),y 1179 | iny 1180 | lda DT+1 1181 | sta (DP),y 1182 | iny 1183 | 1184 | ;; set code to dolist 1185 | lda #dolist 1189 | sta (DP),y 1190 | iny 1191 | 1192 | lda DP ; cache the address of the word we're now compiling 1193 | sta CWORD ; we wait until we're done (dosemic) before we update 1194 | lda DP+1 ; the top-of-dictionary pointer 1195 | sta CWORD+1 1196 | 1197 | clc ; update DP to next available space 1198 | tya ; by adding bytes consumed to DP 1199 | adc DP 1200 | sta DP 1201 | lda DP+1 1202 | adc #0 1203 | sta DP+1 1204 | 1205 | jmp next ; not sure which of these is right... 1206 | ;jmp interploop ; in the compiler, we don't execute NEXT 1207 | 1208 | 1209 | ;;; do-semi-colon, ie, tidy up when we're finishing compiling a word 1210 | ;;; 1211 | dosemic 1212 | ;; turn off the compiler 1213 | lda STATUS 1214 | and #%11111110 1215 | sta STATUS 1216 | 1217 | ;; add call to exit at the end of the entry 1218 | ldy #0 1219 | lda #d0code 1223 | sta (DP),y 1224 | 1225 | ;; update DP for those two last bytes 1226 | .( 1227 | inc DP 1228 | bne continue 1229 | inc DP+1 1230 | continue 1231 | .) 1232 | .( 1233 | inc DP 1234 | bne continue 1235 | inc DP+1 1236 | continue 1237 | .) 1238 | 1239 | ;; set DT to new top entry, the word we've just finished compiling 1240 | lda CWORD 1241 | sta DT 1242 | lda CWORD+1 1243 | sta DT+1 1244 | 1245 | jmp next 1246 | 1247 | 1248 | ;;; Do dot-quote. I'm not entirely happy with my solution for this yet. 1249 | ;;; This word has three different context-dependent behaviors: 1250 | ;;; 1. when we are compiling (determined by compiler flag), assemble 1251 | ;;; string from the text stream and compile it into the word. 1252 | ;;; 2. when we are called as part of a regular execution cycle, print 1253 | ;;; the word that's compiled in following this instruction. 1254 | ;;; 3. when we are running in the interpreter, as determined by IP 1255 | ;;; pointing to the dummy word, assemble the string that follows 1256 | ;;; in the input buffer and print it. 1257 | dodotqu 1258 | .( 1259 | ;; are we compiling? 1260 | lda STATUS 1261 | bit #COMPILE 1262 | beq nocompile 1263 | 1264 | ;; Yes. compile it (case 1) 1265 | ;; first, add in the execution word 1266 | lda #dotquotecode 1270 | sta (DP),y 1271 | 1272 | ;; then update DP by 2, to account for that word 1273 | .( 1274 | inc DP 1275 | bne skip 1276 | inc DP+1 1277 | skip 1278 | .) 1279 | .( 1280 | inc DP 1281 | bne skip 1282 | inc DP+1 1283 | skip 1284 | .) 1285 | 1286 | ;; next, assemble the string on the PAD 1287 | jsr assemblestr 1288 | 1289 | ;; now we copy it into space where we are comping, pointed to by DP. 1290 | lda PAD ; first, copy the length 1291 | sta (DP) 1292 | 1293 | tay ; now copy the rest of the string (backwards) 1294 | charloop 1295 | lda PAD,y 1296 | sta (DP),y 1297 | dey 1298 | bne charloop 1299 | 1300 | ;; now update DP to account for the string 1301 | clc 1302 | lda PAD ; that's the length count for the string 1303 | inc ; add one for the count byte 1304 | adc DP ; bump DP by that many bytes 1305 | sta DP 1306 | lda DP+1 1307 | adc #$0 1308 | sta DP+1 1309 | 1310 | jmp next ; and proceed. we're done. 1311 | 1312 | nocompile 1313 | ;; are we interactive? 1314 | ;; we can tell if IP points to dummyexit 1315 | lda IP 1316 | cmp #dummyexit 1320 | bne nointerp 1321 | 1322 | ;; Yes, so we need the interactive behaviour (case 3) 1323 | 1324 | ;; first. assemble the string to be printed 1325 | jsr assemblestr 1326 | 1327 | ;; now print it 1328 | ;; but first, write in a space over the length indicator, 1329 | ;; which we don't need because it's null-terminated 1330 | lda #$20 1331 | sta PAD 1332 | 1333 | ldy #0 1334 | .( 1335 | next_char 1336 | wait_txd_empty 1337 | lda ACIA_STATUS 1338 | and #$10 1339 | beq wait_txd_empty 1340 | lda PAD,y 1341 | beq done 1342 | sta ACIA_DATA 1343 | iny 1344 | jmp next_char 1345 | done 1346 | .) 1347 | 1348 | jmp next ; we're done so proceed to next instruction 1349 | 1350 | nointerp 1351 | ;; Finally, this is the regular behavior (case 2). We're executing 1352 | ;; from a compiled word. So IP points to a counted string. Print 1353 | ;; it, and increment the instruction pointer appropriately. 1354 | 1355 | .( 1356 | wait_txd_empty 1357 | lda ACIA_STATUS 1358 | and #$10 1359 | beq wait_txd_empty 1360 | lda #$20 ; print a space to begin 1361 | sta ACIA_DATA 1362 | .) 1363 | 1364 | phx ; save X, since we're about to use it 1365 | lda (IP) ; load the string length 1366 | tax ; transfer to X. X counts down as Y counts up 1367 | ldy #1 1368 | 1369 | ;; now print X characters 1370 | .( 1371 | next_char 1372 | wait_txd_empty 1373 | lda ACIA_STATUS 1374 | and #$10 1375 | beq wait_txd_empty 1376 | lda (IP),y 1377 | sta ACIA_DATA 1378 | iny 1379 | dex 1380 | bne next_char 1381 | done 1382 | .) 1383 | 1384 | plx ; restore X 1385 | 1386 | ;; finally, update the instruction pointer 1387 | ;; Y is the number of characters plus one (because of the last iny) 1388 | ;; so that's actually just the right number to add to the IP. 1389 | tya ; transfer Y to A and add it to IP 1390 | clc 1391 | adc IP ; LSB 1392 | sta IP 1393 | lda IP+1 1394 | adc #$0 ; MSB (for carry) 1395 | sta IP+1 1396 | .) 1397 | 1398 | jmp next ; continue to the next instruction 1399 | 1400 | 1401 | ;;; Read text from the input buffer up until a single quote mark 1402 | ;;; and assemble it onto the PAD. At the end, we'll have a string 1403 | ;;; that is both counted and null-terminated. This is used in both 1404 | ;;; compile mode and run mode of dotquote. 1405 | assemblestr 1406 | 1407 | ;; first, set up the PAD ptr 1408 | lda #PAD 1411 | sta PADPTR+1 1412 | 1413 | .( 1414 | ;; read the next word into WORD 1415 | continue 1416 | jsr readnext 1417 | 1418 | ;; is it a closing quote? count of 1, char is $22 1419 | lda WORD 1420 | cmp #$01 ; check the string length 1421 | bne assemble 1422 | lda WORD+1 ; we know it's a single-character string 1423 | cmp #$22 ; check the single character 1424 | beq finished 1425 | 1426 | assemble 1427 | ;; concatenate onto the string we're assembling at PAD 1428 | lda #$20 ; space 1429 | sta (PADPTR) 1430 | ldy WORD ; the character count 1431 | .( 1432 | nextchar 1433 | lda WORD,y 1434 | sta (PADPTR),y ; Y is off-by-one but it's okay (leading space) 1435 | dey 1436 | bne nextchar 1437 | .) 1438 | 1439 | ;; update PADPTR 1440 | lda WORD ; length of this most recent word 1441 | inc ; plus leading space 1442 | clc 1443 | adc PADPTR 1444 | sta PADPTR ; update the pointer 1445 | lda PADPTR+1 1446 | adc #0 ; in case we generated a carry... 1447 | sta PADPTR+1 1448 | 1449 | ;; update count 1450 | sec ; BUG this will stop working if PAD crosses word boundary 1451 | lda PADPTR 1452 | sbc #zerobracode 1549 | sta (DP),y 1550 | 1551 | .( 1552 | inc DP 1553 | bne skip 1554 | inc DP+1 1555 | skip 1556 | .) 1557 | .( 1558 | inc DP 1559 | bne skip 1560 | inc DP+1 1561 | skip 1562 | .) 1563 | 1564 | lda DP 1565 | sta stackaccess 1566 | lda DP+1 1567 | sta stackaccess+1 1568 | jsr push16 1569 | 1570 | .( 1571 | inc DP 1572 | bne skip 1573 | inc DP+1 1574 | skip 1575 | .) 1576 | .( 1577 | inc DP 1578 | bne skip 1579 | inc DP+1 1580 | skip 1581 | .) 1582 | 1583 | 1584 | nocompile 1585 | jmp next 1586 | .) 1587 | 1588 | 1589 | ;;; This is the compiler behavior for THEN. We look on the stack for 1590 | ;;; address of the branch offset, then calculate the offset and 1591 | ;;; write it in. 1592 | ;;; 1593 | ;;; BUG should exit with error if we're not in compile mode 1594 | ;;; BUG not testing nesting appropriately 1595 | dothen 1596 | .( 1597 | lda STATUS 1598 | bit #COMPILE 1599 | beq nocompile 1600 | 1601 | ;; take the current DP pointer, and subtract from it the value on 1602 | ;; the stack. The result is the offset that should be stored in 1603 | ;; the word pointed to by the item on the stack. Pop it from the stack. 1604 | 1605 | jsr pop16 ; pop branch address into stackaccess 1606 | 1607 | sec ; calculate offset 1608 | lda DP 1609 | sbc stackaccess 1610 | sta SCRATCH 1611 | lda DP+1 1612 | sbc stackaccess+1 1613 | sta SCRATCH+1 1614 | 1615 | lda SCRATCH ; write it into the branch instruction 1616 | sta (stackaccess) 1617 | ldy #1 1618 | lda SCRATCH+1 1619 | sta (stackaccess),y 1620 | 1621 | nocompile 1622 | jsr next ; done. proceed to next instruction. 1623 | .) 1624 | 1625 | 1626 | ;;; doelse is the compiler behavior for ELSE. Like THEN, it updates 1627 | ;;; the prior branch address that's been left on the stack. Like IF, 1628 | ;;; it compiles in a branch (not 0branch this time) and leaves an address 1629 | ;;; on the stack for THEN to fill in. 1630 | ;;; 1631 | ;;; BUG doesn't check nesting 1632 | ;;; BIG doesn't check for compiler 1633 | doelse 1634 | .( 1635 | lda STATUS 1636 | bit #COMPILE 1637 | beq nocompile 1638 | 1639 | ;; First, compile in the branch instruction and keep a copy of 1640 | ;; the branch address to be put on the stack in a moment. 1641 | ;; this way, a successful IF clause should hit a branch that causes 1642 | ;; it to jump to the end (skipping the ELSE clause) 1643 | lda #branchcode 1647 | sta (DP),y 1648 | 1649 | .( 1650 | inc DP 1651 | bne skip 1652 | inc DP+1 1653 | skip 1654 | .) 1655 | .( 1656 | inc DP 1657 | bne skip 1658 | inc DP+1 1659 | skip 1660 | .) 1661 | 1662 | lda DP 1663 | sta SCRATCH+2 1664 | lda DP+1 1665 | sta SCRATCH+3 1666 | 1667 | .( 1668 | inc DP 1669 | bne skip 1670 | inc DP+1 1671 | skip 1672 | .) 1673 | .( 1674 | inc DP 1675 | bne skip 1676 | inc DP+1 1677 | skip 1678 | .) 1679 | 1680 | ;; Next, do the THEN-like behavior and update the address left by IF. 1681 | ;; Take the current DP pointer, and subtract from it the value on 1682 | ;; the stack. The result is the offset that should be stored in 1683 | ;; the word pointed to by the item on the stack. Pop it from the stack. 1684 | 1685 | jsr pop16 ; pop branch address into stackaccess 1686 | 1687 | sec ; calculate offset 1688 | lda DP 1689 | sbc stackaccess 1690 | sta SCRATCH 1691 | lda DP+1 1692 | sbc stackaccess+1 1693 | sta SCRATCH+1 1694 | 1695 | lda SCRATCH ; write it into the branch instruction 1696 | sta (stackaccess) 1697 | ldy #1 1698 | lda SCRATCH+1 1699 | sta (stackaccess),y 1700 | 1701 | ;; Finally, put that deferred branch instruction address onto 1702 | ;; the stack 1703 | lda SCRATCH+2 1704 | sta stackaccess 1705 | lda SCRATCH+3 1706 | sta stackaccess+1 1707 | jsr push16 1708 | 1709 | nocompile 1710 | jmp next 1711 | .) 1712 | 1713 | ;;; dobegin is compiler behavior for BEGIN. It simply pushes the current 1714 | ;;; DP onto the user stack, so that UNTIL can find it later and use it 1715 | ;;; to calculate the offset. 1716 | dobegin 1717 | .( 1718 | lda STATUS 1719 | bit #COMPILE 1720 | beq nocompile 1721 | 1722 | lda DP 1723 | sta stackaccess 1724 | lda DP+1 1725 | sta stackaccess+1 1726 | jsr push16 1727 | 1728 | 1729 | nocompile 1730 | jmp next 1731 | .) 1732 | 1733 | ;;; dountil is the compiler behaviour for UNTIL. It compiles a 0branch 1734 | ;;; with the offset calculated from the value left on the stack by 1735 | ;;; dobegin. 1736 | dountil 1737 | .( 1738 | lda STATUS 1739 | bit #COMPILE 1740 | beq nocompile 1741 | 1742 | ;; first, compile the zerobranch and update DP. 1743 | lda #zerobracode 1747 | sta (DP),y 1748 | 1749 | .( 1750 | inc DP 1751 | bne skip 1752 | inc DP+1 1753 | skip 1754 | .) 1755 | .( 1756 | inc DP 1757 | bne skip 1758 | inc DP+1 1759 | skip 1760 | .) 1761 | 1762 | ;; pull the address at the start of the loop 1763 | jsr pop16 1764 | 1765 | ;; now calculate the offset. Subtract current DP from the value 1766 | ;; on the stack. Result is negative number (the branch backwards). 1767 | sec 1768 | lda stackaccess 1769 | sbc DP 1770 | sta SCRATCH 1771 | lda stackaccess+1 1772 | sbc DP+1 1773 | sta SCRATCH+1 1774 | 1775 | ;; now write that in as a parameter to the branch. 1776 | ;; BUG lots of needless reads and writes going on here 1777 | lda SCRATCH 1778 | sta (DP) 1779 | ldy #1 1780 | lda SCRATCH+1 1781 | sta (DP),y 1782 | 1783 | ;; increment DP again 1784 | .( 1785 | inc DP 1786 | bne skip 1787 | inc DP+1 1788 | skip 1789 | .) 1790 | .( 1791 | inc DP 1792 | bne skip 1793 | inc DP+1 1794 | skip 1795 | .) 1796 | 1797 | nocompile 1798 | jmp next 1799 | .) 1800 | 1801 | 1802 | ;;; dodo is the compiler behavior for DO (the runtime behavior is 1803 | ;;; doparendo). It compiles in (do) and then pushes the next instruction 1804 | ;;; address (the loop target) onto the stack. 1805 | dodo 1806 | ;; compile (do) 1807 | lda #parendocode 1811 | sta (DP),y 1812 | 1813 | ;; increment DP 1814 | .( 1815 | inc DP 1816 | bne continue 1817 | inc DP+1 1818 | continue 1819 | .) 1820 | .( 1821 | inc DP 1822 | bne continue 1823 | inc DP+1 1824 | continue 1825 | .) 1826 | 1827 | ;; push this address on the stack 1828 | lda DP 1829 | sta stackaccess 1830 | lda DP+1 1831 | sta stackaccess+1 1832 | jsr push16 1833 | 1834 | jmp next ; done! 1835 | 1836 | 1837 | ;;; doparendo is the implementation of (DO), the run-time behavior for 1838 | ;;; DO. It pulls two values off the data stack (the loop limit and the 1839 | ;;; loop index) and places them on the return stack (in inverted order). 1840 | ;;; BUG i could unroll this and it would be much more efficient. 1841 | doparendo 1842 | jsr pop16 ; pop loop index 1843 | lda stackaccess ; stash it for a moment 1844 | sta SCRATCH 1845 | lda stackaccess+1 1846 | sta SCRATCH+1 1847 | jsr pop16 ; pop loop limit 1848 | jsr rpush ; push it onto the return stack 1849 | lda SCRATCH ; retreive the caches loop index 1850 | sta stackaccess 1851 | lda SCRATCH+1 1852 | sta stackaccess+1 1853 | jsr rpush ; push it 1854 | jmp next ; done 1855 | 1856 | 1857 | ;;; doloop is the compiler behavior for LOOP. It compiles (LOOP) and a 1858 | ;;; branch address to the address left on the stack. 1859 | doloop 1860 | .( 1861 | lda STATUS 1862 | bit #COMPILE 1863 | beq nocompile 1864 | 1865 | lda #parenloopcode 1869 | sta (DP),y 1870 | 1871 | ;; increment DP 1872 | .( 1873 | inc DP 1874 | bne continue 1875 | inc DP+1 1876 | continue 1877 | .) 1878 | .( 1879 | inc DP 1880 | bne continue 1881 | inc DP+1 1882 | continue 1883 | .) 1884 | 1885 | ;; now compile in the branch offset. first, 1886 | ;; pull the address at the start of the loop 1887 | jsr pop16 1888 | 1889 | ;; now calculate the offset. Subtract current DP from the value 1890 | ;; on the stack. Result is negative number (the branch backwards). 1891 | sec 1892 | lda stackaccess 1893 | sbc DP 1894 | sta SCRATCH 1895 | lda stackaccess+1 1896 | sbc DP+1 1897 | sta SCRATCH+1 1898 | 1899 | ;; now write that in as a parameter to the branch. 1900 | ;; BUG lots of needless reads and writes going on here 1901 | lda SCRATCH 1902 | sta (DP) 1903 | ldy #1 1904 | lda SCRATCH+1 1905 | sta (DP),y 1906 | 1907 | ;; increment DP again 1908 | .( 1909 | inc DP 1910 | bne skip 1911 | inc DP+1 1912 | skip 1913 | .) 1914 | .( 1915 | inc DP 1916 | bne skip 1917 | inc DP+1 1918 | skip 1919 | .) 1920 | 1921 | nocompile 1922 | jmp next 1923 | .) 1924 | 1925 | 1926 | ;;; doparenloop implements (LOOP), which is the run-time code for LOOP. 1927 | ;;; increment and test index and optionally branch back to address 1928 | ;;; provided. 1929 | doparenloop 1930 | ;; grab the index from RP and stash it at SCRATCH 1931 | dec RP 1932 | lda (RP) 1933 | sta SCRATCH+1 1934 | dec RP 1935 | lda (RP) 1936 | sta SCRATCH 1937 | 1938 | ;; increment it 1939 | .( 1940 | inc SCRATCH 1941 | bne continue 1942 | inc SCRATCH+1 1943 | continue 1944 | .) 1945 | 1946 | ;; grab the loop limit and stash it in SCRATCH+2/3. 1947 | dec RP 1948 | lda (RP) 1949 | sta SCRATCH+3 1950 | dec RP 1951 | lda (RP) 1952 | sta SCRATCH+2 1953 | 1954 | ;; compare it to the loop limit. if it's greater than or equal to, 1955 | ;; we will leave the loop. 1956 | lda SCRATCH+1 1957 | cmp SCRATCH+3 1958 | bmi takeloop ; bmi means that +3 (limit) is greater than +1 (index) 1959 | beq testlsb ; eq means we need to test further 1960 | bra noloop ; otherwise, index is greater than limit, so we're done 1961 | 1962 | testlsb ; we get here only if MSBs are equal 1963 | lda SCRATCH 1964 | cmp SCRATCH+2 1965 | bmi takeloop ; index still less than limit, so we take the loop 1966 | bra noloop ; otherwise, quit the loop 1967 | 1968 | 1969 | takeloop 1970 | ;; put index and limit back on return stack. (for limit, just inc 1971 | ;; RP, becuase it hasn't changed 1972 | inc RP 1973 | inc RP 1974 | lda SCRATCH 1975 | sta (RP) 1976 | inc RP 1977 | lda SCRATCH+1 1978 | sta (RP) 1979 | inc RP 1980 | 1981 | ;; grab the branch address and add it to IP 1982 | lda (IP) ; now load the offset and put it at SCRATCH+2 1983 | sta SCRATCH+2 1984 | ldy #1 1985 | lda (IP),y 1986 | sta SCRATCH+3 1987 | 1988 | clc ; now add the offset to the IP 1989 | lda SCRATCH+2 1990 | adc IP 1991 | sta IP 1992 | lda SCRATCH+3 1993 | adc IP+1 1994 | sta IP+1 1995 | 1996 | jmp next 1997 | 1998 | 1999 | noloop 2000 | ;; we've already removed the values from the return stack 2001 | ;; we need to update IP to skip the branch address 2002 | .( 2003 | inc IP 2004 | bne continue 2005 | inc IP+1 2006 | continue 2007 | .) 2008 | .( 2009 | inc IP 2010 | bne continue 2011 | inc IP+1 2012 | continue 2013 | .) 2014 | jmp next 2015 | 2016 | 2017 | ;;; dowords. Print out the words defined in the dictionary (including 2018 | ;;; variables). 2019 | dowords 2020 | .( 2021 | jsr crlf 2022 | 2023 | ;; set up search by initializing dictionary pointer. reuse the 2024 | ;; same pointer (DPTR) used in matching (tick). 2025 | lda DT 2026 | sta DPTR 2027 | lda DT+1 2028 | sta DPTR+1 2029 | 2030 | nextentry 2031 | ;; have we run out of dictionary entries? (when DPTR is $0000) 2032 | lda DPTR 2033 | bne printit 2034 | lda DPTR+1 2035 | beq done 2036 | 2037 | printit 2038 | ldy #0 2039 | lda (DPTR),y 2040 | and #%00011111 ; mask off the tags 2041 | phx 2042 | tax 2043 | ldy #1 2044 | nextchar 2045 | lda (DPTR),y 2046 | jsr puta 2047 | iny 2048 | dex 2049 | bne nextchar 2050 | 2051 | lda #$20 ; end with a space 2052 | jsr puta 2053 | plx 2054 | 2055 | ;; move on to the next entry 2056 | ;; 2057 | lda (DPTR) ; get word length... 2058 | and #%00011111 ; mask off the tags 2059 | tay ; store in Y, and add one... 2060 | iny ; for the pointer to the next entry 2061 | lda (DPTR),y ; update DPTR to point to next entry 2062 | sta SCRATCH 2063 | iny 2064 | lda (DPTR),y 2065 | sta DPTR+1 2066 | lda SCRATCH 2067 | sta DPTR 2068 | bra nextentry 2069 | 2070 | done 2071 | jmp next 2072 | .) 2073 | 2074 | 2075 | ;;; 2076 | ;;; TEXT INTERPRETER 2077 | ;;; 2078 | ;;; For the moment, this is a basically a stopgap. The real FORTH 2079 | ;;; text interpreter has many individual components that manifest 2080 | ;;; themselves as words in the dictionary, and we'll get there. 2081 | ;;; (The fact that the text interpreter is called QUIT in true Forth 2082 | ;;; is the ultimate testement to Chuck Moore's twisted nature.) 2083 | ;;; This is just something to get us going. Again, much borrowed here 2084 | ;;; from the code of the monitor. 2085 | ;;; 2086 | 2087 | 2088 | ;;; initialize the interpreter 2089 | ;;; 2090 | startinterp 2091 | 2092 | ;; set up buffer (nothing to do) 2093 | 2094 | ;; set up buffer pointer (current pointer within text buffer) 2095 | stz TPTR 2096 | 2097 | ;; set up buffer counter (number of characters input) 2098 | stz TCNT 2099 | 2100 | ;; print greeting 2101 | ldy #0 2102 | .( 2103 | next_char 2104 | wait_txd_empty 2105 | lda ACIA_STATUS 2106 | and #$10 2107 | beq wait_txd_empty 2108 | lda greeting,y 2109 | beq interploop 2110 | sta ACIA_DATA 2111 | iny 2112 | jmp next_char 2113 | .) 2114 | 2115 | 2116 | ;;; This is the main loop of the interpreter -- which also includes 2117 | ;;; hooks to the compiler, because in Forth those are deeply 2118 | ;;; conjoined. 2119 | ;;; 2120 | interploop 2121 | 2122 | ;; get the next input word into WORD, potentially refilling 2123 | ;; the text buffer in the process 2124 | jsr readnext 2125 | 2126 | ;; check for match 2127 | 2128 | matchword 2129 | ;; set up search by initializing dictionary pointer 2130 | lda DT 2131 | sta DPTR 2132 | lda DT+1 2133 | sta DPTR+1 2134 | 2135 | nextentry 2136 | ;; have we run out of dictionary entries? (when DPTR is $0000) 2137 | lda DPTR 2138 | bne compareentry 2139 | lda DPTR+1 2140 | beq nomatch 2141 | 2142 | compareentry 2143 | ;; compare words. counted strings can be compared directly, will compare 2144 | ;; counts first. But we need to mask out the tags in the count. 2145 | 2146 | ldy #0 2147 | lda (DPTR),y 2148 | and #%00011111 ; mask off the tags 2149 | cmp WORD,y ; compare word lengths 2150 | bne trynext ; no match 2151 | 2152 | ;; now compare words. do this from the end (for easier testing) 2153 | ldy WORD 2154 | .( 2155 | nextchar 2156 | lda (DPTR),y 2157 | cmp WORD,y 2158 | bne trynext 2159 | dey 2160 | bne nextchar 2161 | .) 2162 | ;; successful match! 2163 | bra gotmatch 2164 | 2165 | ;; loop to next entry 2166 | trynext 2167 | lda (DPTR) ; get word length... 2168 | and #%00011111 ; mask off the tags 2169 | tay ; store in Y, and add one... 2170 | iny ; for the pointer to the next entry 2171 | lda (DPTR),y ; update DPTR to point to next entry 2172 | sta SCRATCH 2173 | iny 2174 | lda (DPTR),y 2175 | sta DPTR+1 2176 | lda SCRATCH 2177 | sta DPTR 2178 | bra nextentry 2179 | 2180 | ;; we found a match for a word to execute. Set up the context 2181 | ;; and call NEXT to get started. 2182 | gotmatch 2183 | 2184 | ;; first, check if we're compiling. if we are not, then we can continue 2185 | lda STATUS 2186 | bit #COMPILE 2187 | beq nocompile 2188 | 2189 | ;; now check if the word is immediate... because if it is, we should 2190 | ;; go ahead and execute 2191 | lda (DPTR) 2192 | bit #IMM 2193 | bne nocompile 2194 | 2195 | ;; compile this into the currently-compiling word. that means we 2196 | ;; should add the address of the code word into the location 2197 | ;; pointed to by DP and increment DP. 2198 | ;; DPTR stores the start of the entry for the word to execute. 2199 | ;; So its code word is at (DPTR) + wordlength + 1 (len) + 2 (link) 2200 | ldy #1 2201 | lda (DPTR) ; word length 2202 | and #%00011111 ; mask off tag bits 2203 | inc ; +1 for the length byte 2204 | inc 2205 | inc ; + 2 more for the link word 2206 | clc 2207 | adc DPTR ; add to address and store in dummy word entry 2208 | sta (DP) 2209 | lda DPTR+1 2210 | adc #$0 2211 | sta (DP),y 2212 | 2213 | ;; increment DP by 2 2214 | inc DP 2215 | .( 2216 | bne continue 2217 | inc DP+1 2218 | continue 2219 | .) 2220 | .( 2221 | inc DP 2222 | bne continue 2223 | inc DP+1 2224 | continue 2225 | .) 2226 | ;; proceed with the interpreter loop 2227 | jmp interploop 2228 | 2229 | nocompile 2230 | ;; DPTR stores the start of the entry for the word to execute. 2231 | ;; So its code word is at (DPTR) + wordlength + 1 (len) + 2 (link) 2232 | lda (DPTR) ; word length 2233 | and #%00011111 ; mask off tag bits 2234 | inc ; +1 for the length byte 2235 | inc 2236 | inc ; + 2 more for the link word 2237 | clc 2238 | adc DPTR ; add to address and store in dummy word entry 2239 | sta dummyparam 2240 | lda DPTR+1 2241 | adc #$0 2242 | sta dummyparam+1 2243 | 2244 | ;; put the dummy parameter address into IP. 2245 | lda #dummyparam 2248 | sta IP+1 2249 | 2250 | ;; jump to NEXT to start running it 2251 | jmp next 2252 | 2253 | ;; we didn't find a match in the dictionary, so see if we can parse 2254 | ;; it as a number. 2255 | nomatch 2256 | ;; before we do the conversion, check that all the letters are digits 2257 | 2258 | ldy WORD 2259 | numcheck 2260 | lda WORD,y 2261 | cmp #$30 2262 | bcc nointerpret ; BCC = branch if less than 2263 | cmp #$40 2264 | bcs nointerpret ; BCS = branch if greater or equal 2265 | dey 2266 | bne numcheck 2267 | 2268 | ;; convert number and put it on the stack 2269 | ;; my routines for this us a null-terminated string, so add a null 2270 | ldy WORD 2271 | iny 2272 | lda #0 2273 | sta WORD,y ; add a null 2274 | lda #WORD 2277 | sta stackaccess+1 2278 | .( 2279 | inc stackaccess ; bump it by one to avoid the count 2280 | bne done 2281 | inc stackaccess+1 2282 | done 2283 | .) 2284 | jsr push16 2285 | jsr readdec16 ; convert it, leave it on the stack 2286 | 2287 | 2288 | ;; if we are compiling, we need to take it off the stack again 2289 | ;; and compile it into the word. 2290 | lda STATUS 2291 | bit #COMPILE 2292 | beq normal 2293 | 2294 | ;; we are compiling. so we need to add this to the current 2295 | ;; word as a literal. that means adding the code for DOLIT 2296 | ;; and then the number. 2297 | jsr pop16 2298 | ldy #0 2299 | lda #dolitcode 2303 | sta (DP),y 2304 | iny 2305 | lda stackaccess 2306 | sta (DP),y 2307 | iny 2308 | lda stackaccess+1 2309 | sta (DP),y 2310 | iny 2311 | 2312 | ;; add Y to DP 2313 | clc 2314 | tya 2315 | adc DP 2316 | sta DP 2317 | lda DP+1 2318 | adc #0 2319 | sta DP+1 2320 | 2321 | normal 2322 | jmp interploop 2323 | 2324 | ;; if we get here, we couldn't find a match, nor could we read it as 2325 | ;; a number. there's no interpretation, so issue an error, flush 2326 | ;; the input, and loop 2327 | nointerpret 2328 | 2329 | ;; turn off the compiler, if we were compiling 2330 | stz STATUS 2331 | 2332 | ;; print an error, in three stages. first, a space; then, the 2333 | ;; undefined word; finally, the error message. 2334 | 2335 | .( 2336 | wait_txd_empty3 2337 | lda ACIA_STATUS 2338 | and #$10 2339 | beq wait_txd_empty3 2340 | lda #$20 2341 | sta ACIA_DATA 2342 | .) 2343 | 2344 | ldy #1 2345 | .( 2346 | next_char 2347 | wait_txd_empty3 2348 | lda ACIA_STATUS 2349 | and #$10 2350 | beq wait_txd_empty3 2351 | lda WORD,y 2352 | sta ACIA_DATA 2353 | iny 2354 | cpy WORD 2355 | bcc next_char 2356 | beq next_char 2357 | .) 2358 | 2359 | ldy #0 2360 | .( 2361 | next_char 2362 | wait_txd_empty 2363 | lda ACIA_STATUS 2364 | and #$10 2365 | beq wait_txd_empty 2366 | lda cantinterpret,y 2367 | beq nextstr 2368 | sta ACIA_DATA 2369 | iny 2370 | bra next_char 2371 | nextstr 2372 | .) 2373 | 2374 | ;; flush input. 2375 | lda TCNT 2376 | sta TPTR ; wait... off by one? 2377 | jmp interploop 2378 | 2379 | 2380 | ;;; readnext 2381 | ;;; read the next word into the area at WORD, potentially refilling 2382 | ;;; the entire buffer in the process. 2383 | ;;; this is a subroutine so that I can also use it in dovariable, 2384 | ;;; although it is mainly used by the text interpreter. 2385 | readnext 2386 | ;; if no more input, ->nomoreinput 2387 | 2388 | lda TPTR ; current pointer 2389 | cmp TCNT ; is that as much text as was read? 2390 | beq nomoreinput ; if yes, print prompt and get more 2391 | 2392 | tay ; put TPTR into Y 2393 | interpword 2394 | ;; begin loop 2395 | 2396 | .( 2397 | ;; look for next word 2398 | lda INPUT,y 2399 | cmp #$20 ; space 2400 | beq nextchar 2401 | cmp #$09 ; tab 2402 | beq nextchar 2403 | bne readword ; not white space, so go and read a word 2404 | 2405 | ;; continue skipping past space 2406 | nextchar 2407 | iny 2408 | cpy TCNT 2409 | beq nomoreinput 2410 | bra interpword 2411 | .) 2412 | 2413 | ;; no more input -- we have exhausted the text buffer. refill. 2414 | nomoreinput 2415 | ;; are we compiling? 2416 | lda STATUS 2417 | beq usualprompt ; not compiling so say "OK" as usual 2418 | jsr cprompt ; different prompt to say we're still compiling 2419 | bra refill 2420 | usualprompt 2421 | jsr okcrlf ; signal completion 2422 | refill 2423 | jsr readline ; read another line of text 2424 | stz TPTR ; reset the pointer 2425 | bra readnext ; loop around 2426 | 2427 | ;; we have detected the start of a non-space sequence. read a word 2428 | ;; into a counted string at WORD. 2429 | readword 2430 | .( 2431 | stz WORD 2432 | phx 2433 | ldx #1 ; X starts at 1 because 0 is the count 2434 | nextchar 2435 | lda INPUT,y 2436 | beq doneword ; done if we hit NULL 2437 | cmp #$20 2438 | beq doneword ; done if we hit space 2439 | cmp #$09 2440 | beq doneword ; done if we hit tab 2441 | sta WORD,x ; X starts at 1 because 0 is the count 2442 | stx WORD 2443 | iny 2444 | cpy TCNT ; run off the end of the buffer? 2445 | beq doneword 2446 | inx 2447 | bra nextchar 2448 | doneword 2449 | plx 2450 | sty TPTR ; update the pointer (and free up Y) 2451 | .) 2452 | rts 2453 | 2454 | 2455 | 2456 | 2457 | ;;; Read a new line into the INPUT buffer 2458 | ;;; 2459 | readline 2460 | ldy #0 2461 | stz TCNT ; reset the counter 2462 | readchar 2463 | .( 2464 | wait_rxd_full 2465 | lda ACIA_STATUS 2466 | and #$08 2467 | beq wait_rxd_full 2468 | .) 2469 | lda ACIA_DATA 2470 | cmp #$08 ; check for backspace 2471 | beq backspace 2472 | cmp #$0D ; check for newline 2473 | beq doneline 2474 | sta INPUT,y ; track the input 2475 | iny 2476 | jsr puta ; echo the typed character 2477 | jmp readchar ; loop to repeat 2478 | backspace 2479 | cpy #0 ; beginning of line? 2480 | beq readchar 2481 | dey ; if not, go back one character 2482 | jsr puta ; move cursor back 2483 | jmp readchar 2484 | 2485 | ;; this is where we land if the line input has finished 2486 | ;; 2487 | doneline 2488 | lda #0 2489 | sta INPUT,y ; add a null terminator 2490 | sty TCNT ; update character count 2491 | rts 2492 | 2493 | 2494 | 2495 | 2496 | 2497 | ;;; 2498 | ;;; support routines 2499 | ;;; 2500 | 2501 | rpush 2502 | lda stackaccess 2503 | sta (RP) 2504 | inc RP 2505 | lda stackaccess+1 2506 | sta (RP) 2507 | inc RP ; BUG presumes that RP doesn't roll over page boundary 2508 | rts 2509 | 2510 | 2511 | rpull 2512 | dec RP 2513 | dec RP 2514 | ldy #1 2515 | lda (RP),y 2516 | sta stackaccess+1 2517 | lda (RP) 2518 | sta stackaccess 2519 | rts 2520 | 2521 | 2522 | 2523 | ;;; 2524 | ;;; I/O SUPPORT ROUTINES 2525 | ;;; These have been "borrowed" from mitemon 2526 | ;;; 2527 | 2528 | putax 2529 | .( 2530 | phy 2531 | 2532 | pha 2533 | wait_txd_empty 2534 | lda ACIA_STATUS 2535 | and #$10 2536 | beq wait_txd_empty 2537 | pla 2538 | pha ; put a copy back 2539 | clc 2540 | and #$f0 2541 | ror 2542 | ror 2543 | ror 2544 | ror 2545 | tay 2546 | lda hextable,y 2547 | sta ACIA_DATA 2548 | wait_txd_empty2 2549 | lda ACIA_STATUS 2550 | and #$10 2551 | beq wait_txd_empty2 2552 | pla 2553 | clc 2554 | and #$0f 2555 | tay 2556 | lda hextable,y 2557 | sta ACIA_DATA 2558 | .) 2559 | ply 2560 | rts 2561 | 2562 | 2563 | puta 2564 | .( 2565 | pha 2566 | wait_txd_empty 2567 | lda ACIA_STATUS 2568 | and #$10 2569 | beq wait_txd_empty 2570 | pla 2571 | sta ACIA_DATA 2572 | .) 2573 | rts 2574 | 2575 | okcrlf 2576 | ldy #0 2577 | .( 2578 | next_char 2579 | wait_txd_empty 2580 | lda ACIA_STATUS 2581 | and #$10 2582 | beq wait_txd_empty 2583 | lda ok,y 2584 | beq done 2585 | sta ACIA_DATA 2586 | iny 2587 | jmp next_char 2588 | done 2589 | rts 2590 | .) 2591 | 2592 | cprompt 2593 | ldy #0 2594 | .( 2595 | next_char 2596 | wait_txd_empty 2597 | lda ACIA_STATUS 2598 | and #$10 2599 | beq wait_txd_empty 2600 | lda dots,y 2601 | beq done 2602 | sta ACIA_DATA 2603 | iny 2604 | jmp next_char 2605 | done 2606 | rts 2607 | .) 2608 | 2609 | 2610 | crlf 2611 | pha 2612 | .( 2613 | wait_txd_empty 2614 | lda ACIA_STATUS 2615 | and #$10 2616 | beq wait_txd_empty 2617 | .) 2618 | lda #$0d 2619 | sta ACIA_DATA 2620 | .( 2621 | wait_txd_empty 2622 | lda ACIA_STATUS 2623 | and #$10 2624 | beq wait_txd_empty 2625 | .) 2626 | lda #$0a 2627 | sta ACIA_DATA 2628 | pla 2629 | rts 2630 | 2631 | 2632 | hextable: .byte "0123456789ABCDEF" 2633 | greeting .byte "SECND 6502 Forth v03 (Paul Dourish, 2017-12)", $00 2634 | ok: .byte " OK", $0d, $0a, $00 2635 | dots: .byte " ...", $0d, $0a, $00 2636 | cantinterpret: .byte ": not defined", $0d, $0a, $00 2637 | match: .byte " match!", $00 2638 | exitmsg: .byte $0d, $0a, $0d, $0a, "Exiting.", $0d, $0a, $00 2639 | --------------------------------------------------------------------------------